diff --git a/.editorconfig b/.editorconfig index 24503cfc21..ca6aaebbd5 100644 --- a/.editorconfig +++ b/.editorconfig @@ -9,3 +9,6 @@ indent_style = space insert_final_newline = true max_line_length = 120 trim_trailing_whitespace = true + +[*.u] +max_line_length = off diff --git a/.github/ISSUE_TEMPLATE/bug_report.md b/.github/ISSUE_TEMPLATE/bug_report.md index 17adbc9c3e..f57cddbd1d 100644 --- a/.github/ISSUE_TEMPLATE/bug_report.md +++ b/.github/ISSUE_TEMPLATE/bug_report.md @@ -8,33 +8,18 @@ assignees: '' --- **Describe and demonstrate the bug** -Please attach a [ucm transcript](https://www.unison-lang.org/docs/tooling/transcripts/) if possible, calling out the unexpected behavior in the text. e.g. +This should be written as a [ucm transcript](https://www.unison-lang.org/docs/tooling/transcripts/) if possible, calling out the unexpected behavior in the text. e.g. -Input: -```` -```unison:hide -a = 1 -``` -Here I typo the next command and `ucm` silently does nothing. I would have expected an error message: -```ucm -.> add b -``` -```` - -Output: -```` -```unison +``` unison :hide a = 1 ``` Here I typo the next command and `ucm` silently does nothing, I would have expected an error message: -```ucm -.> add b - +``` ucm +scratch/main> add b ``` -```` **Screenshots** If applicable, add screenshots to help explain your problem. diff --git a/.github/workflows/bundle-ucm.yaml b/.github/workflows/bundle-ucm.yaml index d77ba14030..e97da0292a 100644 --- a/.github/workflows/bundle-ucm.yaml +++ b/.github/workflows/bundle-ucm.yaml @@ -13,7 +13,7 @@ on: required: true env: - racket_version: "8.7" + racket_version: "8.14" defaults: run: @@ -25,7 +25,7 @@ jobs: strategy: fail-fast: false matrix: - os: [ubuntu-20.04, macos-12, windows-2019] + os: [ubuntu-20.04, macos-13, macos-14, windows-2019] runs-on: ${{matrix.os}} steps: - uses: actions/checkout@v4 @@ -39,6 +39,8 @@ jobs: - name: install stack uses: unisonweb/actions/stack/install@main + with: + stack-version: 2.15.5 - name: build run: | @@ -54,9 +56,10 @@ jobs: tries=5 for (( i = 0; i < $tries; i++ )); do stack build :unison \ - --flag unison-parser-typechecker:optimized \ + --ghc-options='-O2' \ --local-bin-path ucm-bin \ --copy-bins \ + --flag unison-runtime:optchecks \ && break; done @@ -89,7 +92,16 @@ jobs: runs-on: ${{matrix.os}} steps: - name: set up environment - run: echo "ucm=${{ runner.temp }}/unison" >> $GITHUB_ENV + run: | + echo "ucm=${{ runner.temp }}/unison" >> $GITHUB_ENV + case "$RUNNER_ARCH" in + X86) racket_arch=x86 ;; + X64) racket_arch=x64 ;; + ARM) racket_arch=arm32 ;; + ARM64) racket_arch=arm64 ;; + *) echo "Unsupported architecture: ${{runner.arch}}"; exit 1 ;; + esac + echo "racket_arch=$racket_arch" >> $GITHUB_ENV - name: download racket `unison` source uses: actions/checkout@v4 with: @@ -105,7 +117,7 @@ jobs: ${{ env.ucm }} transcript unison-src/transcripts-manual/gen-racket-libs.md - uses: Bogdanp/setup-racket@v1.11 with: - architecture: "x64" + architecture: ${{ env.racket_arch }} distribution: "full" variant: "CS" version: ${{env.racket_version}} @@ -130,7 +142,8 @@ jobs: matrix: os: - ubuntu-20.04 - - macos-12 + - macos-13 + - macos-14 - windows-2019 runs-on: ${{matrix.os}} steps: @@ -153,9 +166,19 @@ jobs: # This isn't right because unison.zip is going to include different dates each time. # Maybe we can unpack it and hash the contents. key: ${{ runner.os }}-racket-${{env.racket_version}}-${{hashFiles('scheme-libs/racket/unison.zip')}} + - name: set up environment + run: | + case "$RUNNER_ARCH" in + X86) racket_arch=x86 ;; + X64) racket_arch=x64 ;; + ARM) racket_arch=arm32 ;; + ARM64) racket_arch=arm64 ;; + *) echo "Unsupported architecture: ${{runner.arch}}"; exit 1 ;; + esac + echo "racket_arch=$racket_arch" >> $GITHUB_ENV - uses: Bogdanp/setup-racket@v1.11 with: - architecture: "x64" + architecture: ${{ env.racket_arch }} distribution: "full" variant: "CS" version: ${{env.racket_version}} @@ -189,12 +212,12 @@ jobs: strategy: fail-fast: false matrix: - os: [ubuntu-20.04, macos-12, windows-2019] + os: [ubuntu-20.04, macos-13, macos-14, windows-2019] steps: - name: set up environment run: | staging_dir="${RUNNER_TEMP//\\//}/ucm-staging" - artifact_os="$(echo $RUNNER_OS | tr '[:upper:]' '[:lower:]')" + artifact_os="$(echo "${RUNNER_OS}-${RUNNER_ARCH}" | tr '[:upper:]' '[:lower:]')" echo "staging_dir=$staging_dir" >> $GITHUB_ENV echo "artifact_os=$artifact_os" >> $GITHUB_ENV - name: download ucm @@ -244,7 +267,7 @@ jobs: file: ucm.cmd content: | @echo off - SET UCM_WEB_UI="%~dp0ui" + SET UCM_WEB_UI=%~dp0ui "%~dp0unison\unison.exe" --runtime-path "%~dp0runtime\unison-runtime.exe" %* - name: package everything together run: | diff --git a/.github/workflows/ci-build-jit-binary.yaml b/.github/workflows/ci-build-jit-binary.yaml index 5b3244e2f0..446d3c187a 100644 --- a/.github/workflows/ci-build-jit-binary.yaml +++ b/.github/workflows/ci-build-jit-binary.yaml @@ -10,7 +10,7 @@ defaults: env: jit_src: unison-jit-src/ jit_dist: unison-jit-dist/ - racket_version: "8.7" + racket_version: "8.14" jobs: build-jit-binary: @@ -18,7 +18,7 @@ jobs: strategy: fail-fast: false matrix: - os: [ubuntu-20.04, macOS-12, windows-2019] + os: [ubuntu-20.04, macOS-13, windows-2019] runs-on: ${{matrix.os}} steps: - name: set up environment @@ -54,7 +54,7 @@ jobs: with: name: jit-source path: ${{ env.jit_src }} - + - name: cache/restore jit binaries id: cache-jit-binaries uses: actions/cache/restore@v4 diff --git a/.github/workflows/ci-test-jit.yaml b/.github/workflows/ci-test-jit.yaml index 6162c535f2..6760304cfb 100644 --- a/.github/workflows/ci-test-jit.yaml +++ b/.github/workflows/ci-test-jit.yaml @@ -4,7 +4,7 @@ on: workflow_call: env: - runtime_tests_version: "@unison/runtime-tests/main" + runtime_tests_version: "@unison/runtime-tests/releases/0.0.1" # for best results, this should match the path in ci.yaml too; but GH doesn't make it easy to share them. runtime_tests_codebase: "~/.cache/unisonlanguage/runtime-tests.unison" @@ -24,7 +24,7 @@ jobs: matrix: os: - ubuntu-20.04 - - macOS-12 + - macOS-13 # - windows-2019 runs-on: ${{matrix.os}} steps: diff --git a/.github/workflows/ci.md b/.github/workflows/ci.md index 4f0de29bf9..f29ae442d4 100644 --- a/.github/workflows/ci.md +++ b/.github/workflows/ci.md @@ -6,23 +6,8 @@ At a high level, the CI process is: 3. On all platforms, build the `unison-runtime` Racket program save the resulting binaries as build artifacts. ### `env` vars at the top of `CI.yaml`: -Some version numbers that are used during CI: -- `ormolu_version: "0.5.0.1"` -- `racket_version: "8.7"` -- `jit_version: "@unison/internal/releases/0.0.17"` - -Some cached directories: - - `ucm_local_bin` a temp path for caching a built `ucm` - - `jit_src_scheme` a temp path for caching generated jit sources - - `unison-jit-dist` - - `base-codebase` a codebase path for caching a codebase generated by `unison-src/builtin-tests/base.md` - - `unison_src_test_results` a temp path for caching the result of passing tests that depend on `unison-src/`, which includes: - - `round-trip-tests` - - `transcripts` - - `unison-src/builtin-tests/interpreter-tests.md` -`jit_generator_os: ubuntu-20.04` - - afaik, the jit sources are generated in a platform-independent way, so we just choose one platform to generate them on. +These variables pin some dependency versions, set up some directories to cache, etc. Please see the `env` section in [ci.yaml](./ci.yaml) for specifics. ### Cached directories: diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 4ee48187bd..554e175205 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -5,40 +5,40 @@ defaults: shell: bash on: - # Build on every pull request (and new PR commit) + # Run on the post-merge result of every PR commit pull_request: - # Build on new pushes to trunk (E.g. Merge commits) - # Without the branch filter, each commit on a branch with a PR is triggered twice. - # See: https://github.community/t/how-to-trigger-an-action-on-push-or-pull-request-but-not-both/16662 + # Build on the pre-merge result of every branch commit push: - branches: - - trunk - tags: - - release/* workflow_dispatch: env: - ormolu_version: 0.5.2.0 + ## Some version numbers that are used during CI + ormolu_version: 0.7.2.0 + jit_version: "@unison/internal/releases/0.0.25" + runtime_tests_version: "@unison/runtime-tests/releases/0.0.1" + + ## Some cached directories + # a temp path for caching a built `ucm` ucm_local_bin: ucm-local-bin - jit_version: "@unison/internal/releases/0.0.17" + # a temp path for caching generated jit sources jit_src_scheme: unison-jit-src/scheme-libs/racket jit_dist: unison-jit-dist - jit_generator_os: ubuntu-20.04 - runtime_tests_version: "@unison/runtime-tests/main" + # a codebase path for caching a codebase generated by `unison-src/builtin-tests/interpreter-tests.md` runtime_tests_codebase: "~/.cache/unisonlanguage/runtime-tests.unison" - # locations of some files that will indicate whether we need to re-run certain steps transcript_test_results: transcript-test-results interpreter_test_results: interpreter-test-results + ## afaik, the jit sources are generated in a platform-independent way, so we choose one platform to generate them on. + jit_generator_os: ubuntu-20.04 + jobs: ormolu: runs-on: ubuntu-20.04 steps: - uses: actions/checkout@v4 - name: Get changed files - id: changed-files - uses: tj-actions/changed-files@v41 + uses: tj-actions/changed-files@v44 with: # globs copied from default settings for run-ormolu files: | @@ -71,7 +71,7 @@ jobs: os: # While iterating on this file, you can disable one or more of these to speed things up - ubuntu-20.04 - - macOS-12 + - macOS-13 - windows-2019 # - windows-2022 steps: @@ -96,7 +96,8 @@ jobs: uses: actions/cache@v4 with: path: ${{env.ucm_local_bin}} - key: ucm-${{ matrix.os }}-${{ hashFiles('**/stack.yaml', '**/package.yaml', '**/*.hs')}} + key: ucm-${{ matrix.os }}-${{ hashFiles('**/stack.yaml', '**/package.yaml', '**/*.hs', '**/unison-cli-integration/integrationtests/IntegrationTests/*')}} + # added the integration test dependencies here as if they were source, for simplicity - name: restore stack caches if: steps.cache-ucm-binaries.outputs.cache-hit != 'true' @@ -108,6 +109,8 @@ jobs: - name: install stack if: steps.cache-ucm-binaries.outputs.cache-hit != 'true' uses: unisonweb/actions/stack/install@main + with: + stack-version: 2.15.5 # Build deps, then build local code. Splitting it into two steps just allows us to see how much time each step # takes. @@ -215,7 +218,7 @@ jobs: os: # While iterating on this file, you can disable one or more of these to speed things up - ubuntu-20.04 - - macOS-12 + - macos-13 - windows-2019 # - windows-2022 steps: @@ -241,7 +244,7 @@ jobs: uses: actions/cache@v4 with: path: ${{env.transcript_test_results}} - key: transcripts-results-${{ matrix.os }}-${{ hashFiles('**/stack.yaml', '**/package.yaml', '**/*.hs')}}-${{ hashFiles('**/unison-src/**/*.md') }} + key: transcripts-results-${{ matrix.os }}-${{ hashFiles('**/stack.yaml', '**/package.yaml', '**/*.hs')}}-${{ hashFiles('**/unison-src/**/*.md', '**/unison-src/**/*.u') }} - name: restore binaries uses: actions/cache/restore@v4 if: steps.cache-transcript-test-results.outputs.cache-hit != 'true' @@ -270,6 +273,18 @@ jobs: ${{env.transcripts}} # Fail if any transcripts cause git diffs. git diff --ignore-cr-at-eol --exit-code unison-src/transcripts + - name: shell-based regression tests + if: steps.cache-transcript-test-results.outputs.cache-hit != 'true' && runner.os == 'linux' + run: | + unison-src/tests/fix5507.sh ${{env.ucm}} + - name: docs.to-html + if: steps.cache-transcript-test-results.outputs.cache-hit != 'true' + run: | + ${{env.ucm}} transcript unison-src/transcripts-manual/docs.to-html.md + # Fail if the output or generated docs differ. + git diff --ignore-cr-at-eol --exit-code \ + unison-src/transcripts-manual/docs.to-html.output.md \ + unison-src/transcripts-manual/docs.to-html - name: mark transcripts as passing if: steps.cache-transcript-test-results.outputs.cache-hit != 'true' run: | @@ -286,7 +301,7 @@ jobs: os: # While iterating on this file, you can disable one or more of these to speed things up - ubuntu-20.04 - - macOS-12 + - macos-13 # - windows-2019 # - windows-2022 steps: @@ -376,14 +391,14 @@ jobs: path: ${{ runner.temp }}/setup-jit.md write-mode: overwrite contents: | - ```ucm - .> project.create-empty jit-setup + ``` ucm + scratch/main> project.create-empty jit-setup jit-setup/main> lib.install ${{ env.jit_version }} ``` - ```unison + ``` unison go = generateSchemeBoot "${{ env.jit_generated_src_scheme }}" ``` - ```ucm + ``` ucm jit-setup/main> run go ``` - name: download ucm artifact @@ -417,7 +432,7 @@ jobs: build-jit-binary: name: build jit binary needs: generate-jit-source - uses: ./.github/workflows/ci-build-jit-binary.yaml + uses: ./.github/workflows/ci-build-jit-binary.yaml test-jit: name: test jit diff --git a/.github/workflows/haddocks.yaml b/.github/workflows/haddocks.yaml index 4b9179e562..2fb12dad65 100644 --- a/.github/workflows/haddocks.yaml +++ b/.github/workflows/haddocks.yaml @@ -27,6 +27,8 @@ jobs: - name: install stack uses: unisonweb/actions/stack/install@main + with: + stack-version: 2.15.5 - name: build with haddocks working-directory: unison diff --git a/.github/workflows/nix-dev-cache.yaml b/.github/workflows/nix-dev-cache.yaml index e4e7aa4987..4fc2eb167e 100644 --- a/.github/workflows/nix-dev-cache.yaml +++ b/.github/workflows/nix-dev-cache.yaml @@ -1,14 +1,15 @@ name: Nix development cache on: - # Build on every pull request (and new PR commit) - pull_request: - # Build on new pushes to trunk (E.g. Merge commits) - # Without the branch filter, each commit on a branch with a PR is triggered twice. - # See: https://github.community/t/how-to-trigger-an-action-on-push-or-pull-request-but-not-both/16662 - push: - branches: - - trunk + workflow_dispatch: + # # Build on every pull request (and new PR commit) + # pull_request: + # # Build on new pushes to trunk (E.g. Merge commits) + # # Without the branch filter, each commit on a branch with a PR is triggered twice. + # # See: https://github.community/t/how-to-trigger-an-action-on-push-or-pull-request-but-not-both/16662 + # push: + # branches: + # - trunk jobs: nix: @@ -20,10 +21,16 @@ jobs: matrix: os: - ubuntu-20.04 - - macOS-12 - - macOS-14 + - macOS-13 + # - macOS-14 steps: - uses: actions/checkout@v4 + - name: mount Nix store on larger partition + # on the Linux runner `/` doesn't have enough space, but there's a `/mnt` which does. + if: runner.os == 'Linux' + run: | + sudo mkdir /nix /mnt/nix + sudo mount --bind /mnt/nix /nix - uses: cachix/install-nix-action@v27 if: runner.os == 'Linux' with: @@ -37,4 +44,7 @@ jobs: name: unison authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' - name: build all packages and development shells - run: nix -L build --accept-flake-config --no-link --keep-going '.#build-tools' + run: nix -L build --accept-flake-config --no-link --keep-going '.#all' + - name: print disk free status + if: always() + run: df -h diff --git a/.github/workflows/ormolu.yaml b/.github/workflows/ormolu.yaml index bc0f67f460..b070db0e61 100644 --- a/.github/workflows/ormolu.yaml +++ b/.github/workflows/ormolu.yaml @@ -7,7 +7,7 @@ on: workflow_dispatch: env: - ormolu_version: "0.5.2.0" + ormolu_version: "0.7.2.0" jobs: ormolu: @@ -21,7 +21,7 @@ jobs: - name: create pull request with formatting changes uses: peter-evans/create-pull-request@v6 with: - commit_message: automatically run ormolu + commit-message: automatically run ormolu branch: autoformat/${{github.ref_name}} - # branch_suffix: random + branch-suffix: short-commit-hash title: format `${{github.ref_name}}` with ormolu ${{env.ormolu_version}} diff --git a/.github/workflows/update-transcripts.yaml b/.github/workflows/update-transcripts.yaml index 3c35e9f04f..7b298656e9 100644 --- a/.github/workflows/update-transcripts.yaml +++ b/.github/workflows/update-transcripts.yaml @@ -12,7 +12,7 @@ jobs: strategy: matrix: os: - - macOS-12 + - macOS-13 steps: - uses: actions/checkout@v4 - uses: unisonweb/actions/stack/cache/restore@main @@ -22,6 +22,8 @@ jobs: - name: install stack uses: unisonweb/actions/stack/install@main + with: + stack-version: 2.15.5 # One of the transcripts fails if the user's git name hasn't been set. - name: set git user info @@ -36,6 +38,9 @@ jobs: stack exec unison transcript unison-src/transcripts-manual/rewrites.md - name: transcripts run: stack exec transcripts + - name: docs.to-html + run: | + stack exec unison transcript unison-src/transcripts-manual/docs.to-html.md - name: save transcript changes uses: stefanzweifel/git-auto-commit-action@v5 with: diff --git a/.gitignore b/.gitignore index e02fc7f2b2..374723167f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,9 +1,14 @@ # Unison .unison* test-output -transcript-* -scratch.u unisonLocal.zip +*.uc +# Ignore all scratch files... +*.u +# Except those in unison-src +!unison-src/**/*.u +# And integration tests +!unison-cli-integration/integration-tests/IntegrationTests/**/*.u # Auto-generated jit-tests.md @@ -19,6 +24,11 @@ dist-newstyle # GHC *.hie *.prof +*.prof.html +*.hp +*.ps +*.profiterole.html +*.profiterole.txt /.direnv/ /.envrc diff --git a/.mergify.yml b/.mergify.yml index e20da83972..a22da3eed2 100644 --- a/.mergify.yml +++ b/.mergify.yml @@ -3,20 +3,20 @@ pull_request_rules: conditions: - check-success=check-contributor - check-success=build ucm (ubuntu-20.04) - - check-success=build ucm (macOS-12) + - check-success=build ucm (macos-13) - check-success=build ucm (windows-2019) - check-success=run transcripts (ubuntu-20.04) - - check-success=run transcripts (macOS-12) + - check-success=run transcripts (macos-13) - check-success=run transcripts (windows-2019) - check-success=run interpreter tests (ubuntu-20.04) - - check-success=run interpreter tests (macOS-12) + - check-success=run interpreter tests (macos-13) # - check-success=run interpreter tests (windows-2019) - check-success=generate jit source - check-success=build jit binary / build jit binary (ubuntu-20.04) - - check-success=build jit binary / build jit binary (macOS-12) + - check-success=build jit binary / build jit binary (macos-13) - check-success=build jit binary / build jit binary (windows-2019) - check-success=test jit / test jit (ubuntu-20.04) - - check-success=test jit / test jit (macOS-12) + - check-success=test jit / test jit (macos-13) # - check-success=test jit / test jit (windows-2019) - label=ready-to-merge - "#approved-reviews-by>=1" diff --git a/.ormolu b/.ormolu new file mode 100644 index 0000000000..fb60d7db30 --- /dev/null +++ b/.ormolu @@ -0,0 +1,4 @@ +infixl 8 ^? +infixr 4 %%~, %~ +infixl 3 <|> +infixl 1 &, <&> diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 0000000000..6002d51193 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,7 @@ +{ + "haskell.toolchain": { + "cabal": "3.10.3.0", + "hls": "2.8.0.0", + "stack": "2.15.7" + } +} diff --git a/CONTRIBUTORS.markdown b/CONTRIBUTORS.markdown index 5649b15dd0..302d01f095 100644 --- a/CONTRIBUTORS.markdown +++ b/CONTRIBUTORS.markdown @@ -87,3 +87,7 @@ The format for this list: name, GitHub handle * Dan Doel (@dolio) * Eric Torreborre (@etorreborre) * Eduard Nicodei (@neduard) +* Brian McKenna (@puffnfresh) +* Ruslan Simchuk (@SimaDovakin) +* Brandon Barker (@bbarker) +* Manish Bhasin (@xmbhasin) diff --git a/CREDITS.md b/CREDITS.md index 321060f338..bd367b3aef 100644 --- a/CREDITS.md +++ b/CREDITS.md @@ -52,7 +52,6 @@ These are listed in alphabetical order. | [comonad-5.0.6](https://hackage.haskell.org/package/comonad-5.0.6) | [BSD3](https://hackage.haskell.org/package/comonad-5.0.6/src/LICENSE) | | [concurrent-supply-0.1.8](https://hackage.haskell.org/package/concurrent-supply-0.1.8) | [BSD3](https://hackage.haskell.org/package/concurrent-supply-0.1.8/src/LICENSE) | | [conduit-1.3.2](https://hackage.haskell.org/package/conduit-1.3.2) | [MIT](https://hackage.haskell.org/package/conduit-1.3.2/src/LICENSE) | -| [configurator-0.3.0.0](https://hackage.haskell.org/package/configurator-0.3.0.0) | [BSD3](https://hackage.haskell.org/package/configurator-0.3.0.0/src/LICENSE) | | [containers-0.6.2.1](https://hackage.haskell.org/package/containers-0.6.2.1) | [BSD3](https://hackage.haskell.org/package/containers-0.6.2.1/src/LICENSE) | | [contravariant-1.5.2](https://hackage.haskell.org/package/contravariant-1.5.2) | [BSD3](https://hackage.haskell.org/package/contravariant-1.5.2/src/LICENSE) | | [cryptohash-md5-0.11.100.1](https://hackage.haskell.org/package/cryptohash-md5-0.11.100.1) | [BSD3](https://hackage.haskell.org/package/cryptohash-md5-0.11.100.1/src/LICENSE) | diff --git a/README.md b/README.md index ee703bcc22..202fffff16 100644 --- a/README.md +++ b/README.md @@ -10,6 +10,8 @@ The Unison language * [Codebase Server](#codebase-server) * [Configuration](./docs/configuration.md) +![Alt](https://repobeats.axiom.co/api/embed/92b662a65fd842d49cb8d7d813043f5f5b4b550d.svg "Repobeats analytics image") + Overview -------- diff --git a/codebase2/codebase-sqlite-hashing-v2/package.yaml b/codebase2/codebase-sqlite-hashing-v2/package.yaml index 9e32e8546b..9087faf399 100644 --- a/codebase2/codebase-sqlite-hashing-v2/package.yaml +++ b/codebase2/codebase-sqlite-hashing-v2/package.yaml @@ -6,10 +6,7 @@ ghc-options: -Wall dependencies: - base - - bytes - - bytestring - containers - - generic-lens - lens - text - unison-codebase @@ -19,11 +16,8 @@ dependencies: - unison-hash - unison-hashing-v2 - unison-prelude - - unison-sqlite - unison-syntax - - unison-util-base32hex - unison-util-term - - vector library: source-dirs: src diff --git a/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Branch/Hashing.hs b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Branch/Hashing.hs index f8f7dc29e0..4085b8d784 100644 --- a/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Branch/Hashing.hs +++ b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Branch/Hashing.hs @@ -10,7 +10,7 @@ import U.Codebase.HashTags import Unison.Hashing.V2 qualified as Hashing import Unison.Hashing.V2.Convert2 (convertBranchV3, v2ToH2Branch) -hashBranch :: forall m. Monad m => Branch m -> m BranchHash +hashBranch :: forall m. (Monad m) => Branch m -> m BranchHash hashBranch branch = BranchHash . Hashing.contentHash <$> v2ToH2Branch branch diff --git a/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs b/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs index 53b4b72473..3ab63459b7 100644 --- a/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs +++ b/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs @@ -100,7 +100,7 @@ v2ToH2Referent = \case V2Referent.Ref r -> H2.ReferentRef (v2ToH2Reference r) V2Referent.Con r cid -> H2.ReferentCon (v2ToH2Reference r) cid -v2ToH2Branch :: Monad m => V2.Branch m -> m H2.Branch +v2ToH2Branch :: (Monad m) => V2.Branch m -> m H2.Branch v2ToH2Branch V2.Branch {terms, types, patches, children} = do hterms <- traverse sequenceA terms @@ -166,7 +166,7 @@ hashPatchFormatToH2Patch Memory.PatchFull.Patch {termEdits, typeEdits} = V2Referent.Con typeRef conId -> do (H2.ReferentCon (v2ToH2Reference $ second unComponentHash typeRef) conId) -v2ToH2Term :: forall v. Ord v => V2.Term.HashableTerm v -> H2.Term v () +v2ToH2Term :: forall v. (Ord v) => V2.Term.HashableTerm v -> H2.Term v () v2ToH2Term = ABT.transform convertF where convertF :: V2.Term.F' Text V2.Term.HashableTermRef V2.Term.TypeRef V2.Term.HashableTermLink V2.Term.TypeLink v a1 -> H2.TermF v () () a1 diff --git a/codebase2/codebase-sqlite-hashing-v2/unison-codebase-sqlite-hashing-v2.cabal b/codebase2/codebase-sqlite-hashing-v2/unison-codebase-sqlite-hashing-v2.cabal index 67e88874b7..b71dddd506 100644 --- a/codebase2/codebase-sqlite-hashing-v2/unison-codebase-sqlite-hashing-v2.cabal +++ b/codebase2/codebase-sqlite-hashing-v2/unison-codebase-sqlite-hashing-v2.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -56,10 +56,7 @@ library ghc-options: -Wall build-depends: base - , bytes - , bytestring , containers - , generic-lens , lens , text , unison-codebase @@ -69,9 +66,6 @@ library , unison-hash , unison-hashing-v2 , unison-prelude - , unison-sqlite , unison-syntax - , unison-util-base32hex , unison-util-term - , vector default-language: Haskell2010 diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs index afb2a54c26..c2df6ef2f6 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs @@ -173,7 +173,7 @@ decodeWatchResultFormat = ------------------------------------------------------------------------------------------------------------------------ -- unsyncs -unsyncTermComponent :: HasCallStack => TermFormat.SyncLocallyIndexedComponent' t d -> Either DecodeError (TermFormat.LocallyIndexedComponent' t d) +unsyncTermComponent :: (HasCallStack) => TermFormat.SyncLocallyIndexedComponent' t d -> Either DecodeError (TermFormat.LocallyIndexedComponent' t d) unsyncTermComponent (TermFormat.SyncLocallyIndexedComponent terms) = do let phi (localIds, bs) = do (a, b) <- decodeSyncTermAndType bs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs index 028c4d827f..6c0c264265 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs @@ -39,7 +39,7 @@ data HashHandle = HashHandle toReferenceDecl :: Hash -> C.Type.TypeD Symbol -> C.Reference, -- | Hash decl's mentions toReferenceDeclMentions :: Hash -> C.Type.TypeD Symbol -> Set C.Reference, - hashBranch :: forall m. Monad m => Branch m -> m BranchHash, + hashBranch :: forall m. (Monad m) => Branch m -> m BranchHash, hashBranchV3 :: forall m. BranchV3 m -> BranchHash, hashCausal :: -- The causal's namespace hash diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs index 1cfd697365..d8645b81ae 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs @@ -15,7 +15,7 @@ data LocalIds' t h = LocalIds { textLookup :: Vector t, defnLookup :: Vector h } - deriving (Show) + deriving (Functor, Show) type LocalIds = LocalIds' TextId ObjectId diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalizeObject.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalizeObject.hs index 74228c5d9b..4319249f4b 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalizeObject.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalizeObject.hs @@ -109,23 +109,23 @@ localizePatchG (Patch termEdits typeEdits) = -- General-purpose localization -- Contains references to branch objects. -class Ord c => ContainsBranches c s where +class (Ord c) => ContainsBranches c s where branches_ :: Lens' s (Map c LocalBranchChildId) -- Contains references to definition objects i.e. term/decl component objects. -class Ord d => ContainsDefns d s where +class (Ord d) => ContainsDefns d s where defns_ :: Lens' s (Map d LocalDefnId) -- Contains references to objects by their hash. -class Ord h => ContainsHashes h s where +class (Ord h) => ContainsHashes h s where hashes_ :: Lens' s (Map h LocalHashId) -- Contains references to patch objects. -class Ord p => ContainsPatches p s where +class (Ord p) => ContainsPatches p s where patches_ :: Lens' s (Map p LocalPatchObjectId) -- Contains text. -class Ord t => ContainsText t s where +class (Ord t) => ContainsText t s where texts_ :: Lens' s (Map t LocalTextId) -- The inner state of the localization of a branch object. @@ -137,16 +137,16 @@ data LocalizeBranchState t d p c = LocalizeBranchState } deriving (Show, Generic) -instance Ord t => ContainsText t (LocalizeBranchState t d p c) where +instance (Ord t) => ContainsText t (LocalizeBranchState t d p c) where texts_ = field @"texts" -instance Ord d => ContainsDefns d (LocalizeBranchState t d p c) where +instance (Ord d) => ContainsDefns d (LocalizeBranchState t d p c) where defns_ = field @"defns" -instance Ord p => ContainsPatches p (LocalizeBranchState t d p c) where +instance (Ord p) => ContainsPatches p (LocalizeBranchState t d p c) where patches_ = field @"patches" -instance Ord c => ContainsBranches c (LocalizeBranchState t d p c) where +instance (Ord c) => ContainsBranches c (LocalizeBranchState t d p c) where branches_ = field @"branches" -- | Run a computation that localizes a branch object, returning the local ids recorded within. @@ -171,13 +171,13 @@ data LocalizePatchState t h d = LocalizePatchState } deriving (Show, Generic) -instance Ord t => ContainsText t (LocalizePatchState t h d) where +instance (Ord t) => ContainsText t (LocalizePatchState t h d) where texts_ = field @"texts" -instance Ord h => ContainsHashes h (LocalizePatchState t h d) where +instance (Ord h) => ContainsHashes h (LocalizePatchState t h d) where hashes_ = field @"hashes" -instance Ord d => ContainsDefns d (LocalizePatchState t h d) where +instance (Ord d) => ContainsDefns d (LocalizePatchState t h d) where defns_ = field @"defns" -- Run a computation that localizes a patch object, returning the local ids recorded within. diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs index 2528aa177c..1f91746219 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs @@ -58,7 +58,7 @@ instance (FromRow ref) => FromRow (NamedRef ref) where newtype ScopedRow ref = ScopedRow (NamedRef ref) -instance ToRow ref => ToRow (ScopedRow ref) where +instance (ToRow ref) => ToRow (ScopedRow ref) where toRow (ScopedRow (NamedRef {reversedSegments = revSegments, ref})) = SQLText reversedName : SQLText namespace : SQLText lastNameSegment : toRow ref where diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index b402620333..5c4e083616 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -1,10 +1,5 @@ module U.Codebase.Sqlite.Operations ( -- * branches - saveRootBranch, - loadRootCausalHash, - expectRootCausalHash, - expectRootCausal, - expectRootBranchHash, loadCausalHashAtPath, expectCausalHashAtPath, loadCausalBranchAtPath, @@ -13,6 +8,7 @@ module U.Codebase.Sqlite.Operations saveBranchV3, loadCausalBranchByCausalHash, expectCausalBranchByCausalHash, + expectBranchByCausalHashId, expectBranchByBranchHash, expectBranchByBranchHashId, expectNamespaceStatsByHash, @@ -63,9 +59,11 @@ module U.Codebase.Sqlite.Operations causalHashesByPrefix, -- ** dependents index + directDependenciesOfScope, dependents, dependentsOfComponent, - dependentsWithinScope, + directDependentsWithinScope, + transitiveDependentsWithinScope, -- ** type index Q.addTypeToIndexForTerm, @@ -98,9 +96,16 @@ module U.Codebase.Sqlite.Operations fuzzySearchDefinitions, namesPerspectiveForRootAndPath, + -- * Projects + expectProjectAndBranchNames, + expectProjectBranchHead, + -- * reflog - getReflog, - appendReflog, + getDeprecatedRootReflog, + getProjectReflog, + getProjectBranchReflog, + getGlobalReflog, + appendProjectReflog, -- * low-level stuff expectDbBranch, @@ -181,6 +186,9 @@ import U.Codebase.Sqlite.Patch.TermEdit qualified as S import U.Codebase.Sqlite.Patch.TermEdit qualified as S.TermEdit import U.Codebase.Sqlite.Patch.TypeEdit qualified as S import U.Codebase.Sqlite.Patch.TypeEdit qualified as S.TypeEdit +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Reference qualified as S import U.Codebase.Sqlite.Reference qualified as S.Reference @@ -198,6 +206,7 @@ import U.Codebase.TypeEdit qualified as C.TypeEdit import U.Codebase.WatchKind (WatchKind) import U.Util.Base32Hex qualified as Base32Hex import U.Util.Serialization qualified as S +import Unison.Core.Project (ProjectBranchName, ProjectName) import Unison.Hash qualified as H import Unison.Hash32 qualified as Hash32 import Unison.NameSegment (NameSegment) @@ -205,6 +214,7 @@ import Unison.NameSegment.Internal qualified as NameSegment import Unison.Prelude import Unison.ShortHash (ShortCausalHash (..), ShortNamespaceHash (..)) import Unison.Sqlite +import Unison.Util.Defns (DefnsF) import Unison.Util.List qualified as List import Unison.Util.Map qualified as Map import Unison.Util.Monoid (foldMapM) @@ -229,23 +239,10 @@ expectValueHashByCausalHashId = loadValueHashById <=< Q.expectCausalValueHashId loadValueHashById :: Db.BranchHashId -> Transaction BranchHash loadValueHashById = fmap BranchHash . Q.expectHash . Db.unBranchHashId -expectRootCausalHash :: Transaction CausalHash -expectRootCausalHash = Q.expectCausalHash =<< Q.expectNamespaceRoot - -expectRootBranchHash :: Transaction BranchHash -expectRootBranchHash = do - rootCausalHashId <- Q.expectNamespaceRoot - expectValueHashByCausalHashId rootCausalHashId - -loadRootCausalHash :: Transaction (Maybe CausalHash) -loadRootCausalHash = - runMaybeT $ - lift . Q.expectCausalHash =<< MaybeT Q.loadNamespaceRoot - -- | Load the causal hash at the given path from the provided root, if Nothing, use the -- codebase root. -loadCausalHashAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction (Maybe CausalHash) -loadCausalHashAtPath mayRootCausalHash = +loadCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe CausalHash) +loadCausalHashAtPath rootCausalHash = let go :: Db.CausalHashId -> [NameSegment] -> MaybeT Transaction CausalHash go hashId = \case [] -> lift (Q.expectCausalHash hashId) @@ -255,15 +252,13 @@ loadCausalHashAtPath mayRootCausalHash = (_, hashId') <- MaybeT (pure (Map.lookup tid children)) go hashId' ts in \path -> do - hashId <- case mayRootCausalHash of - Nothing -> Q.expectNamespaceRoot - Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH + hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash runMaybeT (go hashId path) -- | Expect the causal hash at the given path from the provided root, if Nothing, use the -- codebase root. -expectCausalHashAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction CausalHash -expectCausalHashAtPath mayRootCausalHash = +expectCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction CausalHash +expectCausalHashAtPath rootCausalHash = let go :: Db.CausalHashId -> [NameSegment] -> Transaction CausalHash go hashId = \case [] -> Q.expectCausalHash hashId @@ -273,23 +268,21 @@ expectCausalHashAtPath mayRootCausalHash = let (_, hashId') = children Map.! tid go hashId' ts in \path -> do - hashId <- case mayRootCausalHash of - Nothing -> Q.expectNamespaceRoot - Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH + hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash go hashId path loadCausalBranchAtPath :: - Maybe CausalHash -> + CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.CausalBranch Transaction)) -loadCausalBranchAtPath maybeRootCausalHash path = - loadCausalHashAtPath maybeRootCausalHash path >>= \case +loadCausalBranchAtPath rootCausalHash path = + loadCausalHashAtPath rootCausalHash path >>= \case Nothing -> pure Nothing Just causalHash -> Just <$> expectCausalBranchByCausalHash causalHash -loadBranchAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction)) -loadBranchAtPath maybeRootCausalHash path = - loadCausalBranchAtPath maybeRootCausalHash path >>= \case +loadBranchAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction)) +loadBranchAtPath rootCausalHash path = + loadCausalBranchAtPath rootCausalHash path >>= \case Nothing -> pure Nothing Just causal -> Just <$> C.Causal.value causal @@ -610,16 +603,6 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = boId <- Q.expectBranchObjectIdByCausalHashId chId expectBranch boId -saveRootBranch :: - HashHandle -> - C.Branch.CausalBranch Transaction -> - Transaction (Db.BranchObjectId, Db.CausalHashId) -saveRootBranch hh c = do - when debug $ traceM $ "Operations.saveRootBranch " ++ show (C.causalHash c) - (boId, chId) <- saveBranch hh c - Q.setNamespaceRoot chId - pure (boId, chId) - -- saveBranch is kind of a "deep save causal" -- we want a "shallow save causal" that could take a @@ -746,9 +729,6 @@ saveCausalObject hh (C.Causal.Causal hc he parents _) = do Q.saveCausal hh chId bhId parentCausalHashIds pure (chId, bhId) -expectRootCausal :: Transaction (C.Branch.CausalBranch Transaction) -expectRootCausal = Q.expectNamespaceRoot >>= expectCausalBranchByCausalHashId - loadCausalBranchByCausalHash :: CausalHash -> Transaction (Maybe (C.Branch.CausalBranch Transaction)) loadCausalBranchByCausalHash hc = do Q.loadCausalHashIdByCausalHash hc >>= \case @@ -1121,6 +1101,21 @@ causalHashesByPrefix (ShortCausalHash b32prefix) = do hashes <- traverse (Q.expectHash . Db.unCausalHashId) hashIds pure $ Set.fromList . map CausalHash $ hashes +directDependenciesOfScope :: + DefnsF Set C.TermReferenceId C.TypeReferenceId -> + Transaction (DefnsF Set C.TermReference C.TypeReference) +directDependenciesOfScope scope0 = do + -- Convert C -> S + scope1 <- bitraverse (Set.traverse c2sReferenceId) (Set.traverse c2sReferenceId) scope0 + + -- Do the query + dependencies0 <- Q.getDirectDependenciesOfScope scope1 + + -- Convert S -> C + dependencies1 <- bitraverse (Set.traverse s2cReference) (Set.traverse s2cReference) dependencies0 + + pure dependencies1 + -- | returns a list of known definitions referencing `r` dependents :: Q.DependentsSelector -> C.Reference -> Transaction (Set C.Reference.Id) dependents selector r = do @@ -1137,19 +1132,43 @@ dependents selector r = do sIds <- Q.getDependentsForDependency selector r' Set.traverse s2cReferenceId sIds --- | `dependentsWithinScope scope query` returns all of transitive dependents of `query` that are in `scope` (not --- including `query` itself). Each dependent is also tagged with whether it is a term or decl. -dependentsWithinScope :: Set C.Reference.Id -> Set C.Reference -> Transaction (Map C.Reference.Id C.ReferenceType) -dependentsWithinScope scope query = do - scope' <- Set.traverse c2sReferenceId scope - query' <- Set.traverse c2sReference query - Q.getDependentsWithinScope scope' query' - >>= Map.bitraverse s2cReferenceId (pure . objectTypeToReferenceType) - where - objectTypeToReferenceType = \case - ObjectType.TermComponent -> C.RtTerm - ObjectType.DeclComponent -> C.RtType - _ -> error "Q.getDependentsWithinScope shouldn't return any other types" +-- | `directDependentsWithinScope scope query` returns all direct dependents of `query` that are in `scope` (not +-- including `query` itself). +directDependentsWithinScope :: + Set C.Reference.Id -> + Set C.Reference -> + Transaction (DefnsF Set C.TermReferenceId C.TypeReferenceId) +directDependentsWithinScope scope0 query0 = do + -- Convert C -> S + scope1 <- Set.traverse c2sReferenceId scope0 + query1 <- Set.traverse c2sReference query0 + + -- Do the query + dependents0 <- Q.getDirectDependentsWithinScope scope1 query1 + + -- Convert S -> C + dependents1 <- bitraverse (Set.traverse s2cReferenceId) (Set.traverse s2cReferenceId) dependents0 + + pure dependents1 + +-- | `transitiveDependentsWithinScope scope query` returns all transitive dependents of `query` that are in `scope` (not +-- including `query` itself). +transitiveDependentsWithinScope :: + Set C.Reference.Id -> + Set C.Reference -> + Transaction (DefnsF Set C.TermReferenceId C.TypeReferenceId) +transitiveDependentsWithinScope scope0 query0 = do + -- Convert C -> S + scope1 <- Set.traverse c2sReferenceId scope0 + query1 <- Set.traverse c2sReference query0 + + -- Do the query + dependents0 <- Q.getTransitiveDependentsWithinScope scope1 query1 + + -- Convert S -> C + dependents1 <- bitraverse (Set.traverse s2cReferenceId) (Set.traverse s2cReferenceId) dependents0 + + pure dependents1 -- | returns a list of known definitions referencing `h` dependentsOfComponent :: H.Hash -> Transaction (Set C.Reference.Id) @@ -1468,15 +1487,43 @@ namespaceStatsForDbBranch = \case expectNamespaceStatsByHashId bhId -- | Gets the specified number of reflog entries in chronological order, most recent first. -getReflog :: Int -> Transaction [Reflog.Entry CausalHash Text] -getReflog numEntries = do - entries <- Q.getReflog numEntries +getDeprecatedRootReflog :: Int -> Transaction [Reflog.Entry CausalHash Text] +getDeprecatedRootReflog numEntries = do + entries <- Q.getDeprecatedRootReflog numEntries traverse (bitraverse Q.expectCausalHash pure) entries -appendReflog :: Reflog.Entry CausalHash Text -> Transaction () -appendReflog entry = do - dbEntry <- (bitraverse Q.saveCausalHash pure) entry - Q.appendReflog dbEntry +-- | Gets the specified number of reflog entries for the given project in chronological order, most recent first. +getProjectReflog :: Int -> Db.ProjectId -> Transaction [ProjectReflog.Entry Project ProjectBranch CausalHash] +getProjectReflog numEntries projectId = do + entries <- Q.getProjectReflog numEntries projectId + traverse hydrateProjectReflogEntry entries + +-- | Gets the specified number of reflog entries for the specified ProjectBranch in chronological order, most recent first. +getProjectBranchReflog :: Int -> Db.ProjectBranchId -> Transaction [ProjectReflog.Entry Project ProjectBranch CausalHash] +getProjectBranchReflog numEntries projectBranchId = do + entries <- Q.getProjectBranchReflog numEntries projectBranchId + traverse hydrateProjectReflogEntry entries + +-- | Gets the specified number of reflog entries in chronological order, most recent first. +getGlobalReflog :: Int -> Transaction [ProjectReflog.Entry Project ProjectBranch CausalHash] +getGlobalReflog numEntries = do + entries <- Q.getGlobalReflog numEntries + traverse hydrateProjectReflogEntry entries + +hydrateProjectReflogEntry :: ProjectReflog.Entry Db.ProjectId Db.ProjectBranchId Db.CausalHashId -> Transaction (ProjectReflog.Entry Project ProjectBranch CausalHash) +hydrateProjectReflogEntry entry = do + traverse Q.expectCausalHash entry + >>= ProjectReflog.projectAndBranch_ + %%~ ( \(projId, branchId) -> do + proj <- Q.expectProject projId + branch <- Q.expectProjectBranch projId branchId + pure (proj, branch) + ) + +appendProjectReflog :: ProjectReflog.Entry Db.ProjectId Db.ProjectBranchId CausalHash -> Transaction () +appendProjectReflog entry = do + dbEntry <- traverse Q.saveCausalHash entry + Q.appendProjectBranchReflog dbEntry -- | Delete any name lookup that's not in the provided list. -- @@ -1542,3 +1589,14 @@ stripPrefixFromNamedRef (PathSegments prefix) namedRef = Nothing -> reversedName Just strippedReversedPath -> S.ReversedName (name NonEmpty.:| strippedReversedPath) in namedRef {S.reversedSegments = newReversedName} + +expectProjectAndBranchNames :: Db.ProjectId -> Db.ProjectBranchId -> Transaction (ProjectName, ProjectBranchName) +expectProjectAndBranchNames projectId projectBranchId = do + Project {name = pName} <- Q.expectProject projectId + ProjectBranch {name = bName} <- Q.expectProjectBranch projectId projectBranchId + pure (pName, bName) + +expectProjectBranchHead :: Db.ProjectId -> Db.ProjectBranchId -> Transaction CausalHash +expectProjectBranchHead projId projectBranchId = do + chId <- Q.expectProjectBranchHead projId projectBranchId + Q.expectCausalHash chId diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Full.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Full.hs index b2f1366932..749a87290c 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Full.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Full.hs @@ -55,7 +55,7 @@ patchT_ f Patch {termEdits, typeEdits} = do newTypeEdits <- traverseOf (Map.bitraversed (Reference.t_) (Set.traverse . traverseFirst)) f typeEdits pure Patch {termEdits = newTermEdits, typeEdits = newTypeEdits} where - traverseFirst :: Bitraversable b => Traversal (b a c) (b a' c) a a' + traverseFirst :: (Bitraversable b) => Traversal (b a c) (b a' c) a a' traverseFirst f = bitraverse f pure patchH_ :: (Ord t, Ord h') => Traversal (Patch' t h o) (Patch' t h' o) h h' diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TermEdit.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TermEdit.hs index bc93dd166c..e588dc7540 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TermEdit.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TermEdit.hs @@ -22,6 +22,12 @@ type Referent' t h = Referent.Referent' (Reference' t h) (Reference' t h) data TermEdit' t h = Replace (Referent' t h) Typing | Deprecate deriving (Eq, Ord, Show) +instance Functor (TermEdit' t) where + fmap :: (a -> b) -> TermEdit' t a -> TermEdit' t b + fmap f (Replace (Referent.Ref termRef) typing) = Replace (Referent.Ref (fmap f termRef)) typing + fmap f (Replace (Referent.Con typeRef consId) typing) = Replace (Referent.Con (fmap f typeRef) consId) typing + fmap _ Deprecate = Deprecate + _Replace :: Prism (TermEdit' t h) (TermEdit' t' h') (Referent' t h, Typing) (Referent' t' h', Typing) _Replace = prism embed project where diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TypeEdit.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TypeEdit.hs index 6b8d3ea48c..ae0816b6b9 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TypeEdit.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TypeEdit.hs @@ -17,7 +17,7 @@ type TypeEdit = TypeEdit' Db.TextId Db.ObjectId type HashTypeEdit = TypeEdit' Text ComponentHash data TypeEdit' t h = Replace (Reference' t h) | Deprecate - deriving (Eq, Ord, Show) + deriving (Eq, Functor, Ord, Show) _Replace :: Prism (TypeEdit' t h) (TypeEdit' t' h') (Reference' t h) (Reference' t' h') _Replace = prism Replace project diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs index 2707e09c74..94e90b5c00 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs @@ -14,5 +14,5 @@ data Project = Project { projectId :: !ProjectId, name :: !ProjectName } - deriving stock (Generic, Show) + deriving stock (Generic, Show, Eq) deriving anyclass (ToRow, FromRow) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs new file mode 100644 index 0000000000..b759df2586 --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module U.Codebase.Sqlite.ProjectReflog + ( Entry (..), + project_, + branch_, + projectAndBranch_, + ) +where + +import Control.Lens +import Data.Text (Text) +import Data.Time (UTCTime) +import U.Codebase.Sqlite.DbId (CausalHashId, ProjectBranchId, ProjectId) +import Unison.Sqlite (FromRow (..), ToRow (..), field) + +data Entry project branch causal = Entry + { project :: project, + branch :: branch, + time :: UTCTime, + fromRootCausalHash :: Maybe causal, + toRootCausalHash :: causal, + reason :: Text + } + deriving stock (Eq, Show, Functor, Foldable, Traversable) + +project_ :: Lens (Entry project branch causal) (Entry project' branch causal) project project' +project_ = lens project (\e p -> e {project = p}) + +branch_ :: Lens (Entry project branch causal) (Entry project branch' causal) branch branch' +branch_ = lens branch (\e b -> e {branch = b}) + +-- | Both Project and Branch Ids are required to load a branch, so this is often more useful. +projectAndBranch_ :: Lens (Entry project branch causal) (Entry project' branch' causal) (project, branch) (project', branch') +projectAndBranch_ = lens (\Entry {..} -> (project, branch)) (\e (project, branch) -> e {project = project, branch = branch}) + +instance ToRow (Entry ProjectId ProjectBranchId CausalHashId) where + toRow (Entry proj branch time fromRootCausalHash toRootCausalHash reason) = + toRow (proj, branch, time, fromRootCausalHash, toRootCausalHash, reason) + +instance FromRow (Entry ProjectId ProjectBranchId CausalHashId) where + fromRow = do + project <- field + branch <- field + time <- field + fromRootCausalHash <- field + toRootCausalHash <- field + reason <- field + pure $ Entry {..} diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 880d3cdf04..033efb8655 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -66,12 +66,6 @@ module U.Codebase.Sqlite.Queries loadTermObject, expectTermObject, - -- * namespace_root table - loadNamespaceRoot, - setNamespaceRoot, - expectNamespaceRoot, - expectNamespaceRootBranchHashId, - -- * namespace_statistics table saveNamespaceStats, loadNamespaceStatsByHashId, @@ -135,6 +129,8 @@ module U.Codebase.Sqlite.Queries insertProjectBranch, renameProjectBranch, deleteProjectBranch, + setProjectBranchHead, + expectProjectBranchHead, setMostRecentBranch, loadMostRecentBranch, @@ -165,7 +161,9 @@ module U.Codebase.Sqlite.Queries getDependenciesForDependent, getDependencyIdsForDependent, getDependenciesBetweenTerms, - getDependentsWithinScope, + getDirectDependenciesOfScope, + getDirectDependentsWithinScope, + getTransitiveDependentsWithinScope, -- ** type index addToTypeIndex, @@ -213,8 +211,11 @@ module U.Codebase.Sqlite.Queries fuzzySearchTypes, -- * Reflog - appendReflog, - getReflog, + getDeprecatedRootReflog, + appendProjectBranchReflog, + getProjectReflog, + getProjectBranchReflog, + getGlobalReflog, -- * garbage collection garbageCollectObjectsWithoutHashes, @@ -235,12 +236,12 @@ module U.Codebase.Sqlite.Queries -- * elaborate hashes elaborateHashes, - -- * most recent namespace - expectMostRecentNamespace, - setMostRecentNamespace, + -- * current project path + expectCurrentProjectPath, + setCurrentProjectPath, -- * migrations - createSchema, + runCreateSql, addTempEntityTables, addReflogTable, addNamespaceStatsTables, @@ -252,6 +253,9 @@ module U.Codebase.Sqlite.Queries addSquashResultTable, addSquashResultTableIfNotExists, cdToProjectRoot, + addCurrentProjectPathTable, + addProjectBranchReflogTable, + addProjectBranchCausalHashIdColumn, -- ** schema version currentSchemaVersion, @@ -285,6 +289,7 @@ module U.Codebase.Sqlite.Queries -- * Types NamespaceText, TextPathSegments, + JsonParseFailure (..), ) where @@ -313,6 +318,7 @@ import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Text.Lazy qualified as Text.Lazy +import Data.Time qualified as Time import Data.Vector qualified as Vector import GHC.Stack (callStack) import Network.URI (URI) @@ -321,7 +327,7 @@ import U.Codebase.Decl qualified as C import U.Codebase.Decl qualified as C.Decl import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) import U.Codebase.Reference (Reference' (..)) -import U.Codebase.Reference qualified as C +import U.Codebase.Reference qualified as C (Reference) import U.Codebase.Reference qualified as C.Reference import U.Codebase.Referent qualified as C.Referent import U.Codebase.Reflog qualified as Reflog @@ -365,10 +371,10 @@ import U.Codebase.Sqlite.Orphans () import U.Codebase.Sqlite.Patch.Format qualified as PatchFormat import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) -import U.Codebase.Sqlite.Reference qualified as Reference +import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog import U.Codebase.Sqlite.Reference qualified as S import U.Codebase.Sqlite.Reference qualified as S.Reference -import U.Codebase.Sqlite.Referent qualified as Referent +import U.Codebase.Sqlite.Referent qualified as S (TextReferent) import U.Codebase.Sqlite.Referent qualified as S.Referent import U.Codebase.Sqlite.RemoteProject (RemoteProject (..)) import U.Codebase.Sqlite.RemoteProjectBranch (RemoteProjectBranch) @@ -398,7 +404,9 @@ import Unison.NameSegment.Internal (NameSegment (NameSegment)) import Unison.NameSegment.Internal qualified as NameSegment import Unison.Prelude import Unison.Sqlite +import Unison.Sqlite qualified as Sqlite import Unison.Util.Alternative qualified as Alternative +import Unison.Util.Defns (Defns (..), DefnsF) import Unison.Util.FileEmbed (embedProjectStringFile) import Unison.Util.Lens qualified as Lens import Unison.Util.Map qualified as Map @@ -412,27 +420,11 @@ type TextPathSegments = [Text] -- * main squeeze currentSchemaVersion :: SchemaVersion -currentSchemaVersion = 16 +currentSchemaVersion = 17 -createSchema :: Transaction () -createSchema = do +runCreateSql :: Transaction () +runCreateSql = executeStatements $(embedProjectStringFile "sql/create.sql") - addTempEntityTables - addNamespaceStatsTables - addReflogTable - fixScopedNameLookupTables - addProjectTables - addMostRecentBranchTable - addNameLookupMountTables - addMostRecentNamespaceTable - execute insertSchemaVersionSql - addSquashResultTable - where - insertSchemaVersionSql = - [sql| - INSERT INTO schema_version (version) - VALUES (:currentSchemaVersion) - |] addTempEntityTables :: Transaction () addTempEntityTables = @@ -442,6 +434,7 @@ addNamespaceStatsTables :: Transaction () addNamespaceStatsTables = executeStatements $(embedProjectStringFile "sql/003-namespace-statistics.sql") +-- | Deprecated in favour of project-branch reflog addReflogTable :: Transaction () addReflogTable = executeStatements $(embedProjectStringFile "sql/002-reflog-table.sql") @@ -480,6 +473,19 @@ cdToProjectRoot :: Transaction () cdToProjectRoot = executeStatements $(embedProjectStringFile "sql/011-cd-to-project-root.sql") +addCurrentProjectPathTable :: Transaction () +addCurrentProjectPathTable = + executeStatements $(embedProjectStringFile "sql/012-add-current-project-path-table.sql") + +-- | Deprecated in favour of project-branch reflog +addProjectBranchReflogTable :: Transaction () +addProjectBranchReflogTable = + executeStatements $(embedProjectStringFile "sql/013-add-project-branch-reflog-table.sql") + +addProjectBranchCausalHashIdColumn :: Transaction () +addProjectBranchCausalHashIdColumn = + executeStatements $(embedProjectStringFile "sql/014-add-project-branch-causal-hash-id.sql") + schemaVersion :: Transaction SchemaVersion schemaVersion = queryOneCol @@ -1335,33 +1341,7 @@ loadCausalParentsByHash hash = WHERE h1.base32 = :hash COLLATE NOCASE |] -expectNamespaceRootBranchHashId :: Transaction BranchHashId -expectNamespaceRootBranchHashId = do - chId <- expectNamespaceRoot - expectCausalValueHashId chId - -expectNamespaceRoot :: Transaction CausalHashId -expectNamespaceRoot = - queryOneCol loadNamespaceRootSql - -loadNamespaceRoot :: Transaction (Maybe CausalHashId) -loadNamespaceRoot = - queryMaybeCol loadNamespaceRootSql - -loadNamespaceRootSql :: Sql -loadNamespaceRootSql = - [sql| - SELECT causal_id - FROM namespace_root - |] - -setNamespaceRoot :: CausalHashId -> Transaction () -setNamespaceRoot id = - queryOneCol [sql| SELECT EXISTS (SELECT 1 FROM namespace_root) |] >>= \case - False -> execute [sql| INSERT INTO namespace_root VALUES (:id) |] - True -> execute [sql| UPDATE namespace_root SET causal_id = :id |] - -saveWatch :: WatchKind -> Reference.IdH -> ByteString -> Transaction () +saveWatch :: WatchKind -> S.Reference.IdH -> ByteString -> Transaction () saveWatch k r blob = do execute [sql| @@ -1379,7 +1359,7 @@ saveWatch k r blob = do loadWatch :: SqliteExceptionReason e => WatchKind -> - Reference.IdH -> + S.Reference.IdH -> (ByteString -> Either e a) -> Transaction (Maybe a) loadWatch k r check = @@ -1395,7 +1375,7 @@ loadWatch k r check = |] check -loadWatchKindsByReference :: Reference.IdH -> Transaction [WatchKind] +loadWatchKindsByReference :: S.Reference.IdH -> Transaction [WatchKind] loadWatchKindsByReference r = queryListCol [sql| @@ -1407,7 +1387,7 @@ loadWatchKindsByReference r = AND watch.component_index = @ |] -loadWatchesByWatchKind :: WatchKind -> Transaction [Reference.IdH] +loadWatchesByWatchKind :: WatchKind -> Transaction [S.Reference.IdH] loadWatchesByWatchKind k = queryListRow [sql| @@ -1423,7 +1403,7 @@ clearWatches = do execute [sql| DELETE FROM watch |] -- * Index-building -addToTypeIndex :: Reference' TextId HashId -> Referent.Id -> Transaction () +addToTypeIndex :: S.ReferenceH -> S.Referent.Id -> Transaction () addToTypeIndex tp tm = execute [sql| @@ -1438,7 +1418,7 @@ addToTypeIndex tp tm = ON CONFLICT DO NOTHING |] -getReferentsByType :: Reference' TextId HashId -> Transaction [Referent.Id] +getReferentsByType :: S.ReferenceH -> Transaction [S.Referent.Id] getReferentsByType r = queryListRow [sql| @@ -1452,7 +1432,7 @@ getReferentsByType r = AND type_reference_component_index IS @ |] -getTypeReferenceForReferent :: Referent.Id -> Transaction (Reference' TextId HashId) +getTypeReferenceForReferent :: S.Referent.Id -> Transaction S.ReferenceH getTypeReferenceForReferent r = queryOneRow [sql| @@ -1467,7 +1447,7 @@ getTypeReferenceForReferent r = |] -- todo: error if no results -getTypeReferencesForComponent :: ObjectId -> Transaction [(Reference' TextId HashId, Referent.Id)] +getTypeReferencesForComponent :: ObjectId -> Transaction [(S.ReferenceH, S.Referent.Id)] getTypeReferencesForComponent oId = fmap (map fixupTypeIndexRow) $ queryListRow @@ -1553,7 +1533,7 @@ filterTermsByReferenceHavingType typ terms = create *> for_ terms insert *> sele drop = execute [sql|DROP TABLE filter_query|] -addToTypeMentionsIndex :: Reference' TextId HashId -> Referent.Id -> Transaction () +addToTypeMentionsIndex :: S.ReferenceH -> S.Referent.Id -> Transaction () addToTypeMentionsIndex tp tm = execute [sql| @@ -1568,7 +1548,7 @@ addToTypeMentionsIndex tp tm = ON CONFLICT DO NOTHING |] -getReferentsByTypeMention :: Reference' TextId HashId -> Transaction [Referent.Id] +getReferentsByTypeMention :: S.ReferenceH -> Transaction [S.Referent.Id] getReferentsByTypeMention r = queryListRow [sql| @@ -1583,7 +1563,7 @@ getReferentsByTypeMention r = |] -- todo: error if no results -getTypeMentionsReferencesForComponent :: ObjectId -> Transaction [(Reference' TextId HashId, Referent.Id)] +getTypeMentionsReferencesForComponent :: ObjectId -> Transaction [(S.ReferenceH, S.Referent.Id)] getTypeMentionsReferencesForComponent r = fmap (map fixupTypeIndexRow) $ queryListRow @@ -1599,7 +1579,7 @@ getTypeMentionsReferencesForComponent r = WHERE term_referent_object_id IS :r |] -fixupTypeIndexRow :: Reference' TextId HashId :. Referent.Id -> (Reference' TextId HashId, Referent.Id) +fixupTypeIndexRow :: S.ReferenceH :. S.Referent.Id -> (S.ReferenceH, S.Referent.Id) fixupTypeIndexRow (rh :. ri) = (rh, ri) -- | Delete objects without hashes. An object typically *would* have a hash, but (for example) during a migration in which an object's hash @@ -1653,7 +1633,7 @@ garbageCollectWatchesWithoutObjects = do (SELECT hash_object.hash_id FROM hash_object) |] -addToDependentsIndex :: [Reference.Reference] -> Reference.Id -> Transaction () +addToDependentsIndex :: [S.Reference] -> S.Reference.Id -> Transaction () addToDependentsIndex dependencies dependent = for_ dependencies \dependency -> execute @@ -1682,7 +1662,7 @@ data DependentsSelector | ExcludeOwnComponent -- | Get dependents of a dependency. -getDependentsForDependency :: DependentsSelector -> Reference.Reference -> Transaction (Set Reference.Id) +getDependentsForDependency :: DependentsSelector -> S.Reference -> Transaction (Set S.Reference.Id) getDependentsForDependency selector dependency = do dependents <- queryListRow @@ -1699,19 +1679,19 @@ getDependentsForDependency selector dependency = do ExcludeSelf -> filter isNotSelfReference dependents ExcludeOwnComponent -> filter isNotReferenceFromOwnComponent dependents where - isNotReferenceFromOwnComponent :: Reference.Id -> Bool + isNotReferenceFromOwnComponent :: S.Reference.Id -> Bool isNotReferenceFromOwnComponent = case dependency of ReferenceBuiltin _ -> const True ReferenceDerived (C.Reference.Id oid0 _pos0) -> \(C.Reference.Id oid1 _pos1) -> oid0 /= oid1 - isNotSelfReference :: Reference.Id -> Bool + isNotSelfReference :: S.Reference.Id -> Bool isNotSelfReference = case dependency of ReferenceBuiltin _ -> const True ReferenceDerived ref -> (ref /=) -getDependentsForDependencyComponent :: ObjectId -> Transaction [Reference.Id] +getDependentsForDependencyComponent :: ObjectId -> Transaction [S.Reference.Id] getDependentsForDependencyComponent dependency = filter isNotSelfReference <$> queryListRow @@ -1722,12 +1702,12 @@ getDependentsForDependencyComponent dependency = AND dependency_object_id IS :dependency |] where - isNotSelfReference :: Reference.Id -> Bool + isNotSelfReference :: S.Reference.Id -> Bool isNotSelfReference = \case (C.Reference.Id oid1 _pos1) -> dependency /= oid1 -- | Get non-self dependencies of a user-defined dependent. -getDependenciesForDependent :: Reference.Id -> Transaction [Reference.Reference] +getDependenciesForDependent :: S.Reference.Id -> Transaction [S.Reference] getDependenciesForDependent dependent@(C.Reference.Id oid0 _) = fmap (filter isNotSelfReference) $ queryListRow @@ -1738,13 +1718,13 @@ getDependenciesForDependent dependent@(C.Reference.Id oid0 _) = AND dependent_component_index IS @ |] where - isNotSelfReference :: Reference.Reference -> Bool + isNotSelfReference :: S.Reference -> Bool isNotSelfReference = \case ReferenceBuiltin _ -> True ReferenceDerived (C.Reference.Id oid1 _) -> oid0 /= oid1 -- | Get non-self, user-defined dependencies of a user-defined dependent. -getDependencyIdsForDependent :: Reference.Id -> Transaction [Reference.Id] +getDependencyIdsForDependent :: S.Reference.Id -> Transaction [S.Reference.Id] getDependencyIdsForDependent dependent@(C.Reference.Id oid0 _) = fmap (filter isNotSelfReference) $ queryListRow @@ -1756,7 +1736,7 @@ getDependencyIdsForDependent dependent@(C.Reference.Id oid0 _) = AND dependent_component_index = @ |] where - isNotSelfReference :: Reference.Id -> Bool + isNotSelfReference :: S.Reference.Id -> Bool isNotSelfReference (C.Reference.Id oid1 _) = oid0 /= oid1 @@ -1869,35 +1849,111 @@ getDependenciesBetweenTerms oid1 oid2 = WHERE path_elem IS NOT null |] --- | `getDependentsWithinScope scope query` returns all of transitive dependents of `query` that are in `scope` (not --- including `query` itself). Each dependent is also tagged with whether it is a term or decl. -getDependentsWithinScope :: Set Reference.Id -> Set S.Reference -> Transaction (Map Reference.Id ObjectType) -getDependentsWithinScope scope query = do +-- Mitchell says: why are we enabling and disabling ormolu all over this file? Let's just enable. But right now I'm only +-- adding this one query and don't want a big diff in my PR. + +{- ORMOLU_ENABLE -} + +getDirectDependenciesOfScope :: + DefnsF Set S.TermReferenceId S.TypeReferenceId -> + Transaction (DefnsF Set S.TermReference S.TypeReference) +getDirectDependenciesOfScope scope = do + let tempTableName = [sql| temp_dependents |] + -- Populate a temporary table with all of the references in `scope` - execute - [sql| - CREATE TEMPORARY TABLE dependents_search_scope ( - dependent_object_id INTEGER NOT NULL, - dependent_component_index INTEGER NOT NULL, - PRIMARY KEY (dependent_object_id, dependent_component_index) - ) - |] - for_ scope \r -> - execute [sql|INSERT INTO dependents_search_scope VALUES (@r, @)|] + createTemporaryTableOfReferenceIds tempTableName (Set.union scope.terms scope.types) + + -- Get their direct dependencies (tagged with object type) + dependencies0 <- + queryListRow @(S.Reference :. Only ObjectType) + [sql| + SELECT d.dependency_builtin, d.dependency_object_id, d.dependency_component_index, o.type_id + FROM dependents_index d + JOIN object o ON d.dependency_object_id = o.id + WHERE (d.dependent_object_id, d.dependent_component_index) IN ( + SELECT object_id, component_index + FROM $tempTableName + ) + |] + + -- Drop the temporary table + execute [sql| DROP TABLE $tempTableName |] + + -- Post-process the query result + let dependencies1 = + List.foldl' + ( \deps -> \case + dep :. Only TermComponent -> Defns (Set.insert dep deps.terms) deps.types + dep :. Only DeclComponent -> Defns deps.terms (Set.insert dep deps.types) + _ -> deps -- impossible; could error here + ) + (Defns Set.empty Set.empty) + dependencies0 + + pure dependencies1 + +-- | `getDirectDependentsWithinScope scope query` returns all direct dependents of `query` that are in `scope` (not +-- including `query` itself). +getDirectDependentsWithinScope :: + Set S.Reference.Id -> + Set S.Reference -> + Transaction (DefnsF Set S.TermReferenceId S.TypeReferenceId) +getDirectDependentsWithinScope scope query = do + -- Populate a temporary table with all of the references in `scope` + let scopeTableName = [sql| dependents_search_scope |] + createTemporaryTableOfReferenceIds scopeTableName scope -- Populate a temporary table with all of the references in `query` - execute - [sql| - CREATE TEMPORARY TABLE dependencies_query ( - dependency_builtin INTEGER NULL, - dependency_object_id INTEGER NULL, - dependency_component_index INTEGER NULL, - CHECK ((dependency_builtin IS NULL) = (dependency_object_id IS NOT NULL)), - CHECK ((dependency_object_id IS NULL) = (dependency_component_index IS NULL)) - ) - |] - for_ query \r -> - execute [sql|INSERT INTO dependencies_query VALUES (@r, @, @)|] + let queryTableName = [sql| dependencies_query |] + createTemporaryTableOfReferences queryTableName query + + -- Get their direct dependents (tagged with object type) + dependents0 <- + queryListRow @(S.Reference.Id :. Only ObjectType) + [sql| + SELECT s.object_id, s.component_index, o.type_id + FROM $queryTableName q + JOIN dependents_index d + ON q.builtin IS d.dependency_builtin + AND q.object_id IS d.dependency_object_id + AND q.component_index IS d.dependency_component_index + JOIN $scopeTableName s + ON d.dependent_object_id = s.object_id + AND d.dependent_component_index = s.component_index + JOIN object o ON s.object_id = o.id + |] + + -- Drop the temporary tables + execute [sql| DROP TABLE $scopeTableName |] + execute [sql| DROP TABLE $queryTableName |] + + -- Post-process the query result + let dependents1 = + List.foldl' + ( \deps -> \case + dep :. Only TermComponent -> Defns (Set.insert dep deps.terms) deps.types + dep :. Only DeclComponent -> Defns deps.terms (Set.insert dep deps.types) + _ -> deps -- impossible; could error here + ) + (Defns Set.empty Set.empty) + dependents0 + + pure dependents1 + +-- | `getTransitiveDependentsWithinScope scope query` returns all transitive dependents of `query` that are in `scope` +-- (not including `query` itself). +getTransitiveDependentsWithinScope :: + Set S.Reference.Id -> + Set S.Reference -> + Transaction (DefnsF Set S.TermReferenceId S.TypeReferenceId) +getTransitiveDependentsWithinScope scope query = do + -- Populate a temporary table with all of the references in `scope` + let scopeTableName = [sql| dependents_search_scope |] + createTemporaryTableOfReferenceIds scopeTableName scope + + -- Populate a temporary table with all of the references in `query` + let queryTableName = [sql| dependencies_query |] + createTemporaryTableOfReferences queryTableName query -- Say the query set is { #foo, #bar }, and the scope set is { #foo, #bar, #baz, #qux, #honk }. -- @@ -1917,34 +1973,80 @@ getDependentsWithinScope scope query = do -- We use `UNION` rather than `UNION ALL` so as to not track down the transitive dependents of any particular -- reference more than once. - result :: [Reference.Id :. Only ObjectType] <- queryListRow [sql| - WITH RECURSIVE transitive_dependents (dependent_object_id, dependent_component_index, type_id) AS ( - SELECT d.dependent_object_id, d.dependent_component_index, object.type_id - FROM dependents_index d - JOIN object ON d.dependent_object_id = object.id - JOIN dependencies_query q - ON q.dependency_builtin IS d.dependency_builtin - AND q.dependency_object_id IS d.dependency_object_id - AND q.dependency_component_index IS d.dependency_component_index - JOIN dependents_search_scope s - ON s.dependent_object_id = d.dependent_object_id - AND s.dependent_component_index = d.dependent_component_index - - UNION SELECT d.dependent_object_id, d.dependent_component_index, object.type_id - FROM dependents_index d - JOIN object ON d.dependent_object_id = object.id - JOIN transitive_dependents t - ON t.dependent_object_id = d.dependency_object_id - AND t.dependent_component_index = d.dependency_component_index - JOIN dependents_search_scope s - ON s.dependent_object_id = d.dependent_object_id - AND s.dependent_component_index = d.dependent_component_index - ) - SELECT * FROM transitive_dependents - |] - execute [sql|DROP TABLE dependents_search_scope|] - execute [sql|DROP TABLE dependencies_query|] - pure . Map.fromList $ [(r, t) | r :. Only t <- result] + result0 :: [S.Reference.Id :. Only ObjectType] <- + queryListRow + [sql| + WITH RECURSIVE transitive_dependents (dependent_object_id, dependent_component_index, type_id) AS ( + SELECT d.dependent_object_id, d.dependent_component_index, object.type_id + FROM dependents_index d + JOIN object ON d.dependent_object_id = object.id + JOIN $queryTableName q + ON q.builtin IS d.dependency_builtin + AND q.object_id IS d.dependency_object_id + AND q.component_index IS d.dependency_component_index + JOIN $scopeTableName s + ON s.object_id = d.dependent_object_id + AND s.component_index = d.dependent_component_index + + UNION SELECT d.dependent_object_id, d.dependent_component_index, object.type_id + FROM dependents_index d + JOIN object ON d.dependent_object_id = object.id + JOIN transitive_dependents t + ON t.dependent_object_id = d.dependency_object_id + AND t.dependent_component_index = d.dependency_component_index + JOIN $scopeTableName s + ON s.object_id = d.dependent_object_id + AND s.component_index = d.dependent_component_index + ) + SELECT * FROM transitive_dependents + |] + + execute [sql| DROP TABLE $scopeTableName |] + execute [sql| DROP TABLE $queryTableName |] + + -- Post-process the query result + let result1 = + List.foldl' + ( \deps -> \case + dep :. Only TermComponent -> Defns (Set.insert dep deps.terms) deps.types + dep :. Only DeclComponent -> Defns deps.terms (Set.insert dep deps.types) + _ -> deps -- impossible; could error here + ) + (Defns Set.empty Set.empty) + result0 + + pure result1 + +createTemporaryTableOfReferences :: Sql -> Set S.Reference -> Transaction () +createTemporaryTableOfReferences tableName refs = do + execute + [sql| + CREATE TEMPORARY TABLE $tableName ( + builtin INTEGER NULL, + object_id INTEGER NULL, + component_index INTEGER NULL + CHECK ((builtin IS NULL) = (object_id IS NOT NULL)), + CHECK ((object_id IS NULL) = (component_index IS NULL)) + ) + |] + + for_ refs \ref -> + execute [sql| INSERT INTO $tableName VALUES (@ref, @, @) |] + +createTemporaryTableOfReferenceIds :: Sql -> Set S.Reference.Id -> Transaction () +createTemporaryTableOfReferenceIds tableName refs = do + execute + [sql| + CREATE TEMPORARY TABLE $tableName ( + object_id INTEGER NOT NULL, + component_index INTEGER NOT NULL, + PRIMARY KEY (object_id, component_index) + ) + |] + for_ refs \ref -> + execute [sql| INSERT INTO $tableName VALUES (@ref, @) |] + +{- ORMOLU_DISABLE -} objectIdByBase32Prefix :: ObjectType -> Text -> Transaction [ObjectId] objectIdByBase32Prefix objType prefix = @@ -2086,7 +2188,7 @@ deleteNameLookupsExceptFor hashIds = do |] -- | Insert the given set of term names into the name lookup table -insertScopedTermNames :: BranchHashId -> [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)] -> Transaction () +insertScopedTermNames :: BranchHashId -> [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)] -> Transaction () insertScopedTermNames bhId = do traverse_ \name0 -> do let name = NamedRef.ScopedRow (refToRow <$> name0) @@ -2106,11 +2208,11 @@ insertScopedTermNames bhId = do VALUES (:bhId, @name, @, @, @, @, @, @, @) |] where - refToRow :: (Referent.TextReferent, Maybe NamedRef.ConstructorType) -> (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType)) + refToRow :: (S.TextReferent, Maybe NamedRef.ConstructorType) -> (S.TextReferent :. Only (Maybe NamedRef.ConstructorType)) refToRow (ref, ct) = ref :. Only ct -- | Insert the given set of type names into the name lookup table -insertScopedTypeNames :: BranchHashId -> [NamedRef Reference.TextReference] -> Transaction () +insertScopedTypeNames :: BranchHashId -> [NamedRef S.TextReference] -> Transaction () insertScopedTypeNames bhId = traverse_ \name0 -> do let name = NamedRef.ScopedRow name0 @@ -2129,7 +2231,7 @@ insertScopedTypeNames bhId = |] -- | Remove the given set of term names into the name lookup table -removeScopedTermNames :: BranchHashId -> [NamedRef Referent.TextReferent] -> Transaction () +removeScopedTermNames :: BranchHashId -> [NamedRef S.TextReferent] -> Transaction () removeScopedTermNames bhId names = do for_ names \name -> execute @@ -2144,7 +2246,7 @@ removeScopedTermNames bhId names = do |] -- | Remove the given set of term names into the name lookup table -removeScopedTypeNames :: BranchHashId -> [NamedRef Reference.TextReference] -> Transaction () +removeScopedTypeNames :: BranchHashId -> [NamedRef S.TextReference] -> Transaction () removeScopedTypeNames bhId names = do for_ names \name -> execute @@ -2203,9 +2305,9 @@ likeEscape escapeChar pat = -- -- Get the list of a term names in the provided name lookup and relative namespace. -- Includes dependencies, but not transitive dependencies. -termNamesWithinNamespace :: BranchHashId -> PathSegments -> Transaction [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)] +termNamesWithinNamespace :: BranchHashId -> PathSegments -> Transaction [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)] termNamesWithinNamespace bhId namespace = do - results :: [NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- + results :: [NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- queryListRow [sql| SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type @@ -2236,7 +2338,7 @@ termNamesWithinNamespace bhId namespace = do -- -- Get the list of a type names in the provided name lookup and relative namespace. -- Includes dependencies, but not transitive dependencies. -typeNamesWithinNamespace :: BranchHashId -> PathSegments -> Transaction [NamedRef Reference.TextReference] +typeNamesWithinNamespace :: BranchHashId -> PathSegments -> Transaction [NamedRef S.TextReference] typeNamesWithinNamespace bhId namespace = queryListRow [sql| @@ -2265,13 +2367,13 @@ typeNamesWithinNamespace bhId namespace = -- is only true on Share. -- -- Get the list of term names within a given namespace which have the given suffix. -termNamesBySuffix :: BranchHashId -> PathSegments -> ReversedName -> Transaction [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)] +termNamesBySuffix :: BranchHashId -> PathSegments -> ReversedName -> Transaction [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)] termNamesBySuffix bhId namespaceRoot suffix = do Debug.debugM Debug.Server "termNamesBySuffix" (namespaceRoot, suffix) let namespaceGlob = toNamespaceGlob namespaceRoot let lastSegment = NonEmpty.head . into @(NonEmpty Text) $ suffix let reversedNameGlob = toSuffixGlob suffix - results :: [NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- + results :: [NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- -- Note: It may seem strange that we do a last_name_segment constraint AND a reversed_name -- GLOB, but this helps improve query performance. -- The SQLite query optimizer is smart enough to do a prefix-search on globs, but will @@ -2304,7 +2406,7 @@ termNamesBySuffix bhId namespaceRoot suffix = do -- is only true on Share. -- -- Get the list of type names within a given namespace which have the given suffix. -typeNamesBySuffix :: BranchHashId -> PathSegments -> ReversedName -> Transaction [NamedRef Reference.TextReference] +typeNamesBySuffix :: BranchHashId -> PathSegments -> ReversedName -> Transaction [NamedRef S.TextReference] typeNamesBySuffix bhId namespaceRoot suffix = do Debug.debugM Debug.Server "typeNamesBySuffix" (namespaceRoot, suffix) let namespaceGlob = toNamespaceGlob namespaceRoot @@ -2343,10 +2445,10 @@ typeNamesBySuffix bhId namespaceRoot suffix = do -- id. It's the caller's job to select the correct name lookup for your exact name. -- -- See termRefsForExactName in U.Codebase.Sqlite.Operations -termRefsForExactName :: BranchHashId -> ReversedName -> Transaction [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)] +termRefsForExactName :: BranchHashId -> ReversedName -> Transaction [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)] termRefsForExactName bhId reversedSegments = do let reversedName = toReversedName reversedSegments - results :: [NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- + results :: [NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- queryListRow [sql| SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type @@ -2366,7 +2468,7 @@ termRefsForExactName bhId reversedSegments = do -- id. It's the caller's job to select the correct name lookup for your exact name. -- -- See termRefsForExactName in U.Codebase.Sqlite.Operations -typeRefsForExactName :: BranchHashId -> ReversedName -> Transaction [NamedRef Reference.TextReference] +typeRefsForExactName :: BranchHashId -> ReversedName -> Transaction [NamedRef S.TextReference] typeRefsForExactName bhId reversedSegments = do let reversedName = toReversedName reversedSegments queryListRow @@ -2382,7 +2484,7 @@ typeRefsForExactName bhId reversedSegments = do -- -- Get the list of term names for a given Referent within a given namespace. -- Considers one level of dependencies, but not transitive dependencies. -termNamesForRefWithinNamespace :: BranchHashId -> PathSegments -> Referent.TextReferent -> Maybe ReversedName -> Transaction [ReversedName] +termNamesForRefWithinNamespace :: BranchHashId -> PathSegments -> S.TextReferent -> Maybe ReversedName -> Transaction [ReversedName] termNamesForRefWithinNamespace bhId namespaceRoot ref maySuffix = do let namespaceGlob = toNamespaceGlob namespaceRoot let suffixGlob = case maySuffix of @@ -2431,7 +2533,7 @@ termNamesForRefWithinNamespace bhId namespaceRoot ref maySuffix = do -- -- Get the list of type names for a given Reference within a given namespace. -- Considers one level of dependencies, but not transitive dependencies. -typeNamesForRefWithinNamespace :: BranchHashId -> PathSegments -> Reference.TextReference -> Maybe ReversedName -> Transaction [ReversedName] +typeNamesForRefWithinNamespace :: BranchHashId -> PathSegments -> S.TextReference -> Maybe ReversedName -> Transaction [ReversedName] typeNamesForRefWithinNamespace bhId namespaceRoot ref maySuffix = do let namespaceGlob = toNamespaceGlob namespaceRoot let suffixGlob = case maySuffix of @@ -2511,7 +2613,7 @@ transitiveDependenciesSql rootBranchHashId = -- Note: this returns the first name it finds by searching in order of: -- Names in the current namespace, then names in the current namespace's dependencies, then -- through the current namespace's dependencies' dependencies, etc. -recursiveTermNameSearch :: BranchHashId -> Referent.TextReferent -> Transaction (Maybe ReversedName) +recursiveTermNameSearch :: BranchHashId -> S.TextReferent -> Transaction (Maybe ReversedName) recursiveTermNameSearch bhId ref = do queryMaybeColCheck [sql| @@ -2548,7 +2650,7 @@ recursiveTermNameSearch bhId ref = do -- Note: this returns the first name it finds by searching in order of: -- Names in the current namespace, then names in the current namespace's dependencies, then -- through the current namespace's dependencies' dependencies, etc. -recursiveTypeNameSearch :: BranchHashId -> Reference.TextReference -> Transaction (Maybe ReversedName) +recursiveTypeNameSearch :: BranchHashId -> S.TextReference -> Transaction (Maybe ReversedName) recursiveTypeNameSearch bhId ref = do queryMaybeColCheck [sql| @@ -2589,13 +2691,13 @@ recursiveTypeNameSearch bhId ref = do -- the longest matching suffix. -- -- Considers one level of dependencies, but not transitive dependencies. -longestMatchingTermNameForSuffixification :: BranchHashId -> PathSegments -> NamedRef Referent.TextReferent -> Transaction (Maybe (NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType))) +longestMatchingTermNameForSuffixification :: BranchHashId -> PathSegments -> NamedRef S.TextReferent -> Transaction (Maybe (NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType))) longestMatchingTermNameForSuffixification bhId namespaceRoot (NamedRef.NamedRef {reversedSegments = revSuffix@(ReversedName (lastSegment NonEmpty.:| _)), ref}) = do let namespaceGlob = toNamespaceGlob namespaceRoot <> ".*" - let loop :: [Text] -> MaybeT Transaction (NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)) + let loop :: [Text] -> MaybeT Transaction (NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)) loop [] = empty loop (suffGlob : rest) = do - result :: Maybe (NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))) <- + result :: Maybe (NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType))) <- lift $ queryMaybeRow -- Note: It may seem strange that we do a last_name_segment constraint AND a reversed_name @@ -2664,13 +2766,13 @@ longestMatchingTermNameForSuffixification bhId namespaceRoot (NamedRef.NamedRef -- the longest matching suffix. -- -- Considers one level of dependencies, but not transitive dependencies. -longestMatchingTypeNameForSuffixification :: BranchHashId -> PathSegments -> NamedRef Reference.TextReference -> Transaction (Maybe (NamedRef Reference.TextReference)) +longestMatchingTypeNameForSuffixification :: BranchHashId -> PathSegments -> NamedRef S.TextReference -> Transaction (Maybe (NamedRef S.TextReference)) longestMatchingTypeNameForSuffixification bhId namespaceRoot (NamedRef.NamedRef {reversedSegments = revSuffix@(ReversedName (lastSegment NonEmpty.:| _)), ref}) = do let namespaceGlob = toNamespaceGlob namespaceRoot <> ".*" - let loop :: [Text] -> MaybeT Transaction (NamedRef Reference.TextReference) + let loop :: [Text] -> MaybeT Transaction (NamedRef S.TextReference) loop [] = empty loop (suffGlob : rest) = do - result :: Maybe (NamedRef (Reference.TextReference)) <- + result :: Maybe (NamedRef (S.TextReference)) <- lift $ queryMaybeRow -- Note: It may seem strange that we do a last_name_segment constraint AND a reversed_name @@ -2761,32 +2863,45 @@ before x y = selectAncestorsOfY = ancestorSql y lca :: CausalHashId -> CausalHashId -> Transaction (Maybe CausalHashId) -lca x y = - queryStreamCol (ancestorSql x) \nextX -> - queryStreamCol (ancestorSql y) \nextY -> do - let getNext = (,) <$> nextX <*> nextY - loop2 seenX seenY = - getNext >>= \case - (Just px, Just py) -> - let seenX' = Set.insert px seenX - seenY' = Set.insert py seenY - in if Set.member px seenY' - then pure (Just px) - else - if Set.member py seenX' - then pure (Just py) - else loop2 seenX' seenY' - (Nothing, Nothing) -> pure Nothing - (Just px, Nothing) -> loop1 nextX seenY px - (Nothing, Just py) -> loop1 nextY seenX py - loop1 getNext matches v = - if Set.member v matches - then pure (Just v) - else - getNext >>= \case - Just v -> loop1 getNext matches v - Nothing -> pure Nothing - loop2 (Set.singleton x) (Set.singleton y) +lca alice bob = + queryMaybeCol + [sql| + WITH RECURSIVE history_one (causal_id) AS ( + SELECT :alice + UNION + SELECT causal_parent.parent_id + FROM history_one + JOIN causal_parent ON history_one.causal_id = causal_parent.causal_id + ), + history_two (causal_id) AS ( + SELECT :bob + UNION + SELECT causal_parent.parent_id + FROM history_two + JOIN causal_parent ON history_two.causal_id = causal_parent.causal_id + ), + common_ancestors (causal_id) AS ( + SELECT causal_id + FROM history_one + INTERSECT + SELECT causal_id + FROM history_two + ORDER BY causal_id DESC + ) + SELECT causal_id + FROM common_ancestors + WHERE NOT EXISTS ( + SELECT 1 + FROM causal_parent + WHERE causal_parent.parent_id = common_ancestors.causal_id + AND EXISTS ( + SELECT 1 + FROM common_ancestors c + WHERE c.causal_id = causal_parent.causal_id + ) + ) + LIMIT 1 + |] ancestorSql :: CausalHashId -> Sql ancestorSql h = @@ -3036,12 +3151,12 @@ saveTermComponent hh@HashHandle {toReference, toReferenceMentions} maybeEncodedT tpRefs' = Foldable.toList $ C.Type.dependencies tp getTermSRef :: S.Term.TermRef -> S.Reference getTermSRef = \case - C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t) + ReferenceBuiltin t -> ReferenceBuiltin (tIds Vector.! fromIntegral t) C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i getTypeSRef :: S.Term.TypeRef -> S.Reference getTypeSRef = \case - C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t) + ReferenceBuiltin t -> ReferenceBuiltin (tIds Vector.! fromIntegral t) C.Reference.Derived h i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i getSTypeLink = getTypeSRef getSTermLink :: S.Term.TermLink -> S.Reference @@ -3096,7 +3211,7 @@ saveDeclComponent hh@HashHandle {toReferenceDecl, toReferenceDeclMentions} maybe dependencies :: Set S.Decl.TypeRef = C.Decl.dependencies decl getSRef :: C.Reference.Reference' LocalTextId (Maybe LocalDefnId) -> S.Reference.Reference getSRef = \case - C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t) + ReferenceBuiltin t -> ReferenceBuiltin (tIds Vector.! fromIntegral t) C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i in (Set.map getSRef dependencies, self) @@ -3372,21 +3487,68 @@ loadNamespaceStatsByHashId bhId = do WHERE namespace_hash_id = :bhId |] -appendReflog :: Reflog.Entry CausalHashId Text -> Transaction () -appendReflog entry = +getDeprecatedRootReflog :: Int -> Transaction [Reflog.Entry CausalHashId Text] +getDeprecatedRootReflog numEntries = + queryListRow + [sql| + SELECT time, from_root_causal_id, to_root_causal_id, reason + FROM reflog + ORDER BY time DESC + LIMIT :numEntries + |] + +appendProjectBranchReflog :: ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId -> Transaction () +appendProjectBranchReflog entry = execute [sql| - INSERT INTO reflog (time, from_root_causal_id, to_root_causal_id, reason) - VALUES (@entry, @, @, @) + INSERT INTO project_branch_reflog (project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason) + VALUES (@entry, @, @, @, @, @) |] -getReflog :: Int -> Transaction [Reflog.Entry CausalHashId Text] -getReflog numEntries = +-- | Get x number of entries from the project reflog for the provided project +getProjectReflog :: Int -> ProjectId -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId] +getProjectReflog numEntries projectId = queryListRow [sql| - SELECT time, from_root_causal_id, to_root_causal_id, reason - FROM reflog - ORDER BY time DESC + SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason + FROM project_branch_reflog + WHERE project_id = :projectId + ORDER BY + time DESC, + -- Strictly for breaking ties in transcripts with the same time, + -- this will break ties in the correct order, sorting later inserted rows first. + ROWID DESC + LIMIT :numEntries + |] + +-- | Get x number of entries from the project reflog for the provided branch. +getProjectBranchReflog :: Int -> ProjectBranchId -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId] +getProjectBranchReflog numEntries projectBranchId = + queryListRow + [sql| + SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason + FROM project_branch_reflog + WHERE project_branch_id = :projectBranchId + ORDER BY + time DESC, + -- Strictly for breaking ties in transcripts with the same time, + -- this will break ties in the correct order, sorting later inserted rows first. + ROWID DESC + LIMIT :numEntries + |] + +-- | Get x number of entries from the global reflog spanning all projects +getGlobalReflog :: Int -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId] +getGlobalReflog numEntries = + queryListRow + [sql| + SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason + FROM project_branch_reflog + ORDER BY + time DESC, + -- Strictly for breaking ties in transcripts with the same time, + -- this will break ties in the correct order, sorting later inserted rows first. + ROWID DESC LIMIT :numEntries |] @@ -3679,12 +3841,15 @@ loadProjectAndBranchNames projectId branchId = |] -- | Insert a project branch. -insertProjectBranch :: ProjectBranch -> Transaction () -insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBranchId) = do +insertProjectBranch :: (HasCallStack) => Text -> CausalHashId -> ProjectBranch -> Transaction () +insertProjectBranch description causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do + -- Ensure we never point at a causal we don't have the branch for. + _ <- expectBranchObjectIdByCausalHashId causalHashId + execute [sql| - INSERT INTO project_branch (project_id, branch_id, name) - VALUES (:projectId, :branchId, :branchName) + INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id) + VALUES (:projectId, :branchId, :branchName, :causalHashId) |] whenJust maybeParentBranchId \parentBranchId -> execute @@ -3692,6 +3857,16 @@ insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBran INSERT INTO project_branch_parent (project_id, parent_branch_id, branch_id) VALUES (:projectId, :parentBranchId, :branchId) |] + time <- Sqlite.unsafeIO $ Time.getCurrentTime + appendProjectBranchReflog $ + ProjectReflog.Entry + { project = projectId, + branch = branchId, + time, + fromRootCausalHash = Nothing, + toRootCausalHash = causalHashId, + reason = description + } -- | Rename a project branch. -- @@ -3740,7 +3915,7 @@ deleteProject projectId = do -- After deleting `topic`: -- -- main <- topic2 -deleteProjectBranch :: ProjectId -> ProjectBranchId -> Transaction () +deleteProjectBranch :: (HasCallStack) => ProjectId -> ProjectBranchId -> Transaction () deleteProjectBranch projectId branchId = do maybeParentBranchId :: Maybe ProjectBranchId <- queryMaybeCol @@ -3764,6 +3939,38 @@ deleteProjectBranch projectId branchId = do WHERE project_id = :projectId AND branch_id = :branchId |] +-- | Set project branch HEAD +setProjectBranchHead :: Text -> ProjectId -> ProjectBranchId -> CausalHashId -> Transaction () +setProjectBranchHead description projectId branchId causalHashId = do + -- Ensure we never point at a causal we don't have the branch for. + _ <- expectBranchObjectIdByCausalHashId causalHashId + oldRootCausalHashId <- expectProjectBranchHead projectId branchId + execute + [sql| + UPDATE project_branch + SET causal_hash_id = :causalHashId + WHERE project_id = :projectId AND branch_id = :branchId + |] + time <- Sqlite.unsafeIO $ Time.getCurrentTime + appendProjectBranchReflog $ + ProjectReflog.Entry + { project = projectId, + branch = branchId, + time = time, + fromRootCausalHash = Just oldRootCausalHashId, + toRootCausalHash = causalHashId, + reason = description + } + +expectProjectBranchHead :: (HasCallStack) => ProjectId -> ProjectBranchId -> Transaction CausalHashId +expectProjectBranchHead projectId branchId = + queryOneCol + [sql| + SELECT causal_hash_id + FROM project_branch + WHERE project_id = :projectId AND branch_id = :branchId + |] + data LoadRemoteBranchFlag = IncludeSelfRemote | ExcludeSelfRemote @@ -4144,7 +4351,7 @@ loadMostRecentBranch projectId = -- | Searches for all names within the given name lookup which contain the provided list of segments -- in order. -- Search is case insensitive. -fuzzySearchTerms :: Bool -> BranchHashId -> Int -> PathSegments -> [Text] -> Transaction [(NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType))] +fuzzySearchTerms :: Bool -> BranchHashId -> Int -> PathSegments -> [Text] -> Transaction [(NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType))] fuzzySearchTerms includeDependencies bhId limit namespace querySegments = do -- Union in the dependencies if required. let dependenciesSql = @@ -4179,14 +4386,14 @@ fuzzySearchTerms includeDependencies bhId limit namespace querySegments = do where namespaceGlob = toNamespaceGlob namespace preparedQuery = prepareFuzzyQuery '\\' querySegments - unRow :: NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType)) -> NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType) + unRow :: NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType)) -> NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType) unRow = fmap \(a :. Only b) -> (a, b) -- | Searches for all names within the given name lookup which contain the provided list of segments -- in order. -- -- Search is case insensitive. -fuzzySearchTypes :: Bool -> BranchHashId -> Int -> PathSegments -> [Text] -> Transaction [(NamedRef Reference.TextReference)] +fuzzySearchTypes :: Bool -> BranchHashId -> Int -> PathSegments -> [Text] -> Transaction [(NamedRef S.TextReference)] fuzzySearchTypes includeDependencies bhId limit namespace querySegments = do -- Union in the dependencies if required. let dependenciesSql = @@ -4248,33 +4455,39 @@ data JsonParseFailure = JsonParseFailure deriving anyclass (SqliteExceptionReason) -- | Get the most recent namespace the user has visited. -expectMostRecentNamespace :: Transaction [NameSegment] -expectMostRecentNamespace = - queryOneColCheck +expectCurrentProjectPath :: (HasCallStack) => Transaction (ProjectId, ProjectBranchId, [NameSegment]) +expectCurrentProjectPath = + queryOneRowCheck [sql| - SELECT namespace - FROM most_recent_namespace + SELECT project_id, branch_id, path + FROM current_project_path |] check where - check :: Text -> Either JsonParseFailure [NameSegment] - check bytes = - case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of - Left failure -> Left JsonParseFailure {bytes, failure = Text.pack failure} - Right namespace -> Right (map NameSegment namespace) + check :: (ProjectId, ProjectBranchId, Text) -> Either JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment]) + check (projId, branchId, pathText) = + case Aeson.eitherDecodeStrict (Text.encodeUtf8 pathText) of + Left failure -> Left JsonParseFailure {bytes = pathText, failure = Text.pack failure} + Right namespace -> Right (projId, branchId, map NameSegment namespace) -- | Set the most recent namespace the user has visited. -setMostRecentNamespace :: [NameSegment] -> Transaction () -setMostRecentNamespace namespace = +setCurrentProjectPath :: + ProjectId -> + ProjectBranchId -> + [NameSegment] -> + Transaction () +setCurrentProjectPath projId branchId path = do + execute + [sql| DELETE FROM current_project_path |] execute [sql| - UPDATE most_recent_namespace - SET namespace = :json + INSERT INTO current_project_path(project_id, branch_id, path) + VALUES (:projId, :branchId, :jsonPath) |] where - json :: Text - json = - Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> namespace) + jsonPath :: Text + jsonPath = + Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> path) -- | Get the causal hash result from squashing the provided branch hash if we've squashed it -- at some point in the past. diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs index ca228f83d1..7c45dbc97d 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs @@ -14,12 +14,20 @@ import Unison.Sqlite (FromField, FromRow (fromRow), Only (..), RowParser, SQLDat type Reference = Reference' TextId ObjectId +type TermReference = Reference + +type TypeReference = Reference + -- | The name lookup table uses this because normalizing/denormalizing hashes to ids is slower -- than we'd like when writing/reading the entire name lookup table. type TextReference = Reference' Text Base32Hex type Id = Id' ObjectId +type TermReferenceId = Id + +type TypeReferenceId = Id + type LocalReferenceH = Reference' LocalTextId LocalHashId type LocalReference = Reference' LocalTextId LocalDefnId diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index 98554c38d1..55c3213f4a 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -462,7 +462,7 @@ putDeclFormat = \case putDeclComponent (DeclFormat.LocallyIndexedComponent v) = putFramedArray (putPair putLocalIds putDeclElement) v -putDeclElement :: MonadPut m => Decl.DeclR DeclFormat.TypeRef Symbol -> m () +putDeclElement :: (MonadPut m) => Decl.DeclR DeclFormat.TypeRef Symbol -> m () putDeclElement Decl.DataDeclaration {..} = do putDeclType declType putModifier modifier @@ -499,7 +499,7 @@ getDeclElement = 1 -> pure Decl.Effect other -> unknownTag "DeclType" other -getModifier :: MonadGet m => m Modifier +getModifier :: (MonadGet m) => m Modifier getModifier = getWord8 >>= \case 0 -> pure Decl.Structural @@ -720,7 +720,7 @@ getLocalBranch = x -> unknownTag "getMetadataSetFormat" x getBranchDiff' :: - MonadGet m => + (MonadGet m) => m branchRef -> m (BranchFormat.BranchLocalIds' text defRef patchRef childRef) -> m (BranchFormat.BranchFormat' text defRef patchRef childRef branchRef) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs deleted file mode 100644 index beb2591be2..0000000000 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ /dev/null @@ -1,414 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module U.Codebase.Sqlite.Sync22 where - -import Control.Monad.Except (MonadError (throwError)) -import Control.Monad.Validate (ValidateT, runValidateT) -import Control.Monad.Validate qualified as Validate -import Data.Bitraversable (bitraverse) -import Data.Bytes.Get (runGetS) -import Data.Bytes.Put (runPutS) -import Data.List.Extra (nubOrd) -import Data.Set qualified as Set -import Data.Vector qualified as Vector -import U.Codebase.Reference qualified as Reference -import U.Codebase.Sqlite.Branch.Format qualified as BL -import U.Codebase.Sqlite.DbId -import U.Codebase.Sqlite.Decl.Format qualified as DeclFormat -import U.Codebase.Sqlite.HashHandle (HashHandle) -import U.Codebase.Sqlite.LocalIds qualified as L -import U.Codebase.Sqlite.ObjectType qualified as OT -import U.Codebase.Sqlite.Patch.Format qualified as PL -import U.Codebase.Sqlite.Queries qualified as Q -import U.Codebase.Sqlite.Reference qualified as Sqlite -import U.Codebase.Sqlite.Reference qualified as Sqlite.Reference -import U.Codebase.Sqlite.Referent qualified as Sqlite.Referent -import U.Codebase.Sqlite.Serialization qualified as S -import U.Codebase.Sqlite.Term.Format qualified as TL -import U.Codebase.Sqlite.Term.Format qualified as TermFormat -import U.Codebase.Sync (Sync (Sync), TrySyncResult) -import U.Codebase.Sync qualified as Sync -import U.Codebase.WatchKind qualified as WK -import Unison.Prelude -import Unison.Sqlite (Transaction) -import Unison.Util.Cache (Cache) -import Unison.Util.Cache qualified as Cache - -data Entity - = O ObjectId - | C CausalHashId - | W WK.WatchKind Sqlite.Reference.IdH - deriving (Eq, Ord, Show) - -data DecodeError - = ErrTermComponent - | ErrDeclComponent - | ErrBranchFormat - | ErrPatchFormat - | ErrWatchResult - deriving (Show) - -type ErrString = String - -data Error - = DecodeError DecodeError ByteString ErrString - | -- | hashes corresponding to a single object in source codebase - -- correspond to multiple objects in destination codebase - HashObjectCorrespondence ObjectId [HashId] [HashId] [ObjectId] - | SourceDbNotExist - deriving (Show) - -data Env m = Env - { runSrc :: forall a. Transaction a -> m a, - runDest :: forall a. Transaction a -> m a, - -- | there are three caches of this size - idCacheSize :: Word - } - -hoistEnv :: (forall x. m x -> n x) -> Env m -> Env n -hoistEnv f Env {runSrc, runDest, idCacheSize} = - Env - { runSrc = f . runSrc, - runDest = f . runDest, - idCacheSize - } - -debug :: Bool -debug = False - --- data Mappings -sync22 :: - ( MonadIO m, - MonadError Error m - ) => - HashHandle -> - Env m -> - IO (Sync m Entity) -sync22 hh Env {runSrc, runDest, idCacheSize = size} = do - tCache <- Cache.semispaceCache size - hCache <- Cache.semispaceCache size - oCache <- Cache.semispaceCache size - cCache <- Cache.semispaceCache size - pure $ Sync (trySync hh runSrc runDest tCache hCache oCache cCache) - -trySync :: - forall m. - (MonadIO m, MonadError Error m) => - HashHandle -> - (forall a. Transaction a -> m a) -> - (forall a. Transaction a -> m a) -> - Cache TextId TextId -> - Cache HashId HashId -> - Cache ObjectId ObjectId -> - Cache CausalHashId CausalHashId -> - Entity -> - m (TrySyncResult Entity) -trySync hh runSrc runDest tCache hCache oCache cCache = \case - -- for causals, we need to get the value_hash_id of the thingo - -- - maybe enqueue their parents - -- - enqueue the self_ and value_ hashes - -- - enqueue the namespace object, if present - C chId -> - isSyncedCausal chId >>= \case - Just {} -> pure Sync.PreviouslyDone - Nothing -> do - result <- runValidateT @(Set Entity) @m @() do - bhId <- lift . runSrc $ Q.expectCausalValueHashId chId - mayBoId <- lift . runSrc . Q.loadObjectIdForAnyHashId $ unBranchHashId bhId - traverse_ syncLocalObjectId mayBoId - - parents' :: [CausalHashId] <- findParents' chId - bhId' <- lift $ syncBranchHashId bhId - chId' <- lift $ syncCausalHashId chId - lift (runDest (Q.saveCausal hh chId' bhId' parents')) - - case result of - Left deps -> pure . Sync.Missing $ toList deps - Right () -> pure Sync.Done - - -- objects are the hairiest. obviously, if they - -- exist, we're done; otherwise we do some fancy stuff - O oId -> - isSyncedObject oId >>= \case - Just {} -> pure Sync.PreviouslyDone - Nothing -> do - (hId, objType, bytes) <- runSrc $ Q.expectObjectWithHashIdAndType oId - hId' <- syncHashLiteral hId - result <- runValidateT @(Set Entity) @m @ObjectId case objType of - OT.TermComponent -> do - -- split up the localIds (parsed), term, and type blobs - case flip runGetS bytes S.decomposeTermFormat of - Left s -> throwError $ DecodeError ErrTermComponent bytes s - Right - ( TermFormat.SyncTerm - ( TermFormat.SyncLocallyIndexedComponent - (Vector.unzip -> (localIds, bytes)) - ) - ) -> do - -- iterate through the local ids looking for missing deps; - -- then either enqueue the missing deps, or proceed to move the object - when debug $ traceM $ "LocalIds for Source " ++ show oId ++ ": " ++ show localIds - localIds' <- traverse syncLocalIds localIds - when debug $ traceM $ "LocalIds for Dest: " ++ show localIds' - -- reassemble and save the reindexed term - let bytes' = - runPutS - . S.recomposeTermFormat - . TermFormat.SyncTerm - . TermFormat.SyncLocallyIndexedComponent - $ Vector.zip localIds' bytes - lift do - oId' <- runDest $ Q.saveObject hh hId' objType bytes' - -- copy reference-specific stuff - for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do - let ref = Reference.Id oId idx - refH = Reference.Id hId idx - ref' = Reference.Id oId' idx - -- sync watch results - for_ [WK.TestWatch] \wk -> - syncWatch wk refH - syncDependenciesIndex ref ref' - syncTypeIndex oId oId' - syncTypeMentionsIndex oId oId' - pure oId' - OT.DeclComponent -> do - -- split up the localIds (parsed), decl blobs - case flip runGetS bytes S.decomposeDeclFormat of - Left s -> throwError $ DecodeError ErrDeclComponent bytes s - Right - ( DeclFormat.SyncDecl - ( DeclFormat.SyncLocallyIndexedComponent - (Vector.unzip -> (localIds, declBytes)) - ) - ) -> do - -- iterate through the local ids looking for missing deps; - -- then either enqueue the missing deps, or proceed to move the object - localIds' <- traverse syncLocalIds localIds - -- reassemble and save the reindexed term - let bytes' = - runPutS - . S.recomposeDeclFormat - . DeclFormat.SyncDecl - . DeclFormat.SyncLocallyIndexedComponent - $ Vector.zip localIds' declBytes - lift do - oId' <- runDest $ Q.saveObject hh hId' objType bytes' - -- copy per-element-of-the-component stuff - for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do - let ref = Reference.Id oId idx - ref' = Reference.Id oId' idx - syncDependenciesIndex ref ref' - syncTypeIndex oId oId' - syncTypeMentionsIndex oId oId' - pure oId' - OT.Namespace -> case flip runGetS bytes S.decomposeBranchFormat of - Right (BL.SyncFull ids body) -> do - ids' <- syncBranchLocalIds ids - let bytes' = runPutS $ S.recomposeBranchFormat (BL.SyncFull ids' body) - oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes' - pure oId' - Right (BL.SyncDiff boId ids body) -> do - boId' <- syncBranchObjectId boId - ids' <- syncBranchLocalIds ids - let bytes' = runPutS $ S.recomposeBranchFormat (BL.SyncDiff boId' ids' body) - oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes' - pure oId' - Left s -> throwError $ DecodeError ErrBranchFormat bytes s - OT.Patch -> case flip runGetS bytes S.decomposePatchFormat of - Right (PL.SyncFull ids body) -> do - ids' <- syncPatchLocalIds ids - let bytes' = runPutS $ S.recomposePatchFormat (PL.SyncFull ids' body) - oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes' - pure oId' - Right (PL.SyncDiff poId ids body) -> do - poId' <- syncPatchObjectId poId - ids' <- syncPatchLocalIds ids - let bytes' = runPutS $ S.recomposePatchFormat (PL.SyncDiff poId' ids' body) - oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes' - pure oId' - Left s -> throwError $ DecodeError ErrPatchFormat bytes s - case result of - Left deps -> pure . Sync.Missing $ toList deps - Right oId' -> do - syncSecondaryHashes oId oId' - when debug $ traceM $ "Source " ++ show (hId, oId) ++ " becomes Dest " ++ show (hId', oId') - Cache.insert oCache oId oId' - pure Sync.Done - W k r -> syncWatch k r - where - syncLocalObjectId :: ObjectId -> ValidateT (Set Entity) m ObjectId - syncLocalObjectId oId = - lift (isSyncedObject oId) >>= \case - Just oId' -> pure oId' - Nothing -> Validate.refute . Set.singleton $ O oId - - syncPatchObjectId :: PatchObjectId -> ValidateT (Set Entity) m PatchObjectId - syncPatchObjectId = fmap PatchObjectId . syncLocalObjectId . unPatchObjectId - - syncBranchObjectId :: BranchObjectId -> ValidateT (Set Entity) m BranchObjectId - syncBranchObjectId = fmap BranchObjectId . syncLocalObjectId . unBranchObjectId - - syncCausal :: CausalHashId -> ValidateT (Set Entity) m CausalHashId - syncCausal chId = - lift (isSyncedCausal chId) >>= \case - Just chId' -> pure chId' - Nothing -> Validate.refute . Set.singleton $ C chId - - syncDependenciesIndex :: Sqlite.Reference.Id -> Sqlite.Reference.Id -> m () - syncDependenciesIndex ref ref' = do - deps <- runSrc (Q.getDependenciesForDependent ref) - deps' <- for deps expectSyncedObjectReference - runDest (Q.addToDependentsIndex deps' ref') - - syncLocalIds :: L.LocalIds -> ValidateT (Set Entity) m L.LocalIds - syncLocalIds (L.LocalIds tIds oIds) = do - oIds' <- traverse syncLocalObjectId oIds - tIds' <- lift $ traverse syncTextLiteral tIds - pure $ L.LocalIds tIds' oIds' - - syncPatchLocalIds :: PL.PatchLocalIds -> ValidateT (Set Entity) m PL.PatchLocalIds - syncPatchLocalIds (PL.LocalIds tIds hIds oIds) = do - oIds' <- traverse syncLocalObjectId oIds - tIds' <- lift $ traverse syncTextLiteral tIds - hIds' <- lift $ traverse syncHashLiteral hIds - pure $ PL.LocalIds tIds' hIds' oIds' - - syncBranchLocalIds :: BL.BranchLocalIds -> ValidateT (Set Entity) m BL.BranchLocalIds - syncBranchLocalIds (BL.LocalIds tIds oIds poIds chboIds) = do - oIds' <- traverse syncLocalObjectId oIds - poIds' <- traverse (fmap PatchObjectId . syncLocalObjectId . unPatchObjectId) poIds - chboIds' <- traverse (bitraverse syncBranchObjectId syncCausal) chboIds - tIds' <- lift $ traverse syncTextLiteral tIds - pure $ BL.LocalIds tIds' oIds' poIds' chboIds' - - syncTypeIndex :: ObjectId -> ObjectId -> m () - syncTypeIndex oId oId' = do - rows <- runSrc (Q.getTypeReferencesForComponent oId) - -- defensively nubOrd to guard against syncing from codebases with duplicate rows in their type (mentions) indexes - -- alternatively, we could put a unique constraint on the whole 6-tuple of the index tables, and optimistically - -- insert with an `on conflict do nothing`. - for_ (nubOrd rows) \row -> do - row' <- syncTypeIndexRow oId' row - runDest (uncurry Q.addToTypeIndex row') - - syncTypeMentionsIndex :: ObjectId -> ObjectId -> m () - syncTypeMentionsIndex oId oId' = do - rows <- runSrc (Q.getTypeMentionsReferencesForComponent oId) - -- see "defensively nubOrd..." comment above in `syncTypeIndex` - for_ (nubOrd rows) \row -> do - row' <- syncTypeIndexRow oId' row - runDest (uncurry Q.addToTypeMentionsIndex row') - - syncTypeIndexRow :: - ObjectId -> - (Sqlite.Reference.ReferenceH, Sqlite.Referent.Id) -> - m (Sqlite.Reference.ReferenceH, Sqlite.Referent.Id) - syncTypeIndexRow oId' = bitraverse syncHashReference (pure . rewriteTypeIndexReferent oId') - - rewriteTypeIndexReferent :: ObjectId -> Sqlite.Referent.Id -> Sqlite.Referent.Id - rewriteTypeIndexReferent oId' = bimap (const oId') (const oId') - - syncTextLiteral :: TextId -> m TextId - syncTextLiteral = Cache.apply tCache \tId -> do - t <- runSrc $ Q.expectText tId - tId' <- runDest $ Q.saveText t - when debug $ traceM $ "Source " ++ show tId ++ " is Dest " ++ show tId' ++ " (" ++ show t ++ ")" - pure tId' - - syncHashLiteral :: HashId -> m HashId - syncHashLiteral = Cache.apply hCache \hId -> do - b32hex <- runSrc $ Q.expectHash32 hId - hId' <- runDest $ Q.saveHash b32hex - when debug $ traceM $ "Source " ++ show hId ++ " is Dest " ++ show hId' ++ " (" ++ show b32hex ++ ")" - pure hId' - - isSyncedObjectReference :: Sqlite.Reference -> m (Maybe Sqlite.Reference) - isSyncedObjectReference = \case - Reference.ReferenceBuiltin t -> - Just . Reference.ReferenceBuiltin <$> syncTextLiteral t - Reference.ReferenceDerived id -> - fmap Reference.ReferenceDerived <$> isSyncedObjectReferenceId id - - isSyncedObjectReferenceId :: Sqlite.Reference.Id -> m (Maybe Sqlite.Reference.Id) - isSyncedObjectReferenceId (Reference.Id oId idx) = - isSyncedObject oId <&> fmap (\oId' -> Reference.Id oId' idx) - - -- Assert that a reference's component is already synced, and return the corresponding reference. - expectSyncedObjectReference :: Sqlite.Reference -> m Sqlite.Reference - expectSyncedObjectReference ref = - isSyncedObjectReference ref <&> \case - Nothing -> error (reportBug "E452280" ("unsynced object reference " ++ show ref)) - Just ref' -> ref' - - syncHashReference :: Sqlite.ReferenceH -> m Sqlite.ReferenceH - syncHashReference = bitraverse syncTextLiteral syncHashLiteral - - syncCausalHashId :: CausalHashId -> m CausalHashId - syncCausalHashId = fmap CausalHashId . syncHashLiteral . unCausalHashId - - syncBranchHashId :: BranchHashId -> m BranchHashId - syncBranchHashId = fmap BranchHashId . syncHashLiteral . unBranchHashId - - findParents' :: CausalHashId -> ValidateT (Set Entity) m [CausalHashId] - findParents' chId = do - srcParents <- lift . runSrc $ Q.loadCausalParents chId - traverse syncCausal srcParents - - -- Sync any watches of the given kinds to the dest if and only if watches of those kinds - -- exist in the src. - syncWatch :: WK.WatchKind -> Sqlite.Reference.IdH -> m (TrySyncResult Entity) - syncWatch wk r | debug && trace ("Sync22.syncWatch " ++ show wk ++ " " ++ show r) False = undefined - syncWatch wk r = do - runSrc (Q.loadWatch wk r (Right :: ByteString -> Either Void ByteString)) >>= \case - Nothing -> pure Sync.Done - Just blob -> do - r' <- traverse syncHashLiteral r - doneKinds <- runDest (Q.loadWatchKindsByReference r') - if (elem wk doneKinds) - then pure Sync.PreviouslyDone - else do - TL.SyncWatchResult li body <- - either (throwError . DecodeError ErrWatchResult blob) pure $ runGetS S.decomposeWatchFormat blob - li' <- bitraverse syncTextLiteral syncHashLiteral li - when debug $ traceM $ "LocalIds for Source watch result " ++ show r ++ ": " ++ show li - when debug $ traceM $ "LocalIds for Dest watch result " ++ show r' ++ ": " ++ show li' - let blob' = runPutS $ S.recomposeWatchFormat (TL.SyncWatchResult li' body) - runDest (Q.saveWatch wk r' blob') - pure Sync.Done - - syncSecondaryHashes oId oId' = - runSrc (Q.hashIdWithVersionForObject oId) >>= traverse_ (go oId') - where - go oId' (hId, hashVersion) = do - hId' <- syncHashLiteral hId - runDest $ Q.saveHashObject hId' oId' hashVersion - - isSyncedObject :: ObjectId -> m (Maybe ObjectId) - isSyncedObject = Cache.applyDefined oCache \oId -> do - hIds <- toList <$> runSrc (Q.expectHashIdsForObject oId) - hIds' <- traverse syncHashLiteral hIds - ( nubOrd . catMaybes - <$> traverse (runDest . Q.loadObjectIdForAnyHashId) hIds' - ) - >>= \case - [oId'] -> do - when debug $ traceM $ "Source " ++ show oId ++ " is Dest " ++ show oId' - pure $ Just oId' - [] -> pure $ Nothing - oIds' -> throwError (HashObjectCorrespondence oId hIds hIds' oIds') - - isSyncedCausal :: CausalHashId -> m (Maybe CausalHashId) - isSyncedCausal = Cache.applyDefined cCache \chId -> do - let hId = unCausalHashId chId - hId' <- syncHashLiteral hId - ifM - (runDest $ Q.isCausalHash hId') - (pure . Just $ CausalHashId hId') - (pure Nothing) diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index a04fce3a56..67ca76b208 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -11,7 +11,6 @@ extra-source-files: - sql/* dependencies: - - Only - aeson - base - bytes @@ -20,24 +19,22 @@ dependencies: - extra - generic-lens - lens - - monad-validate - mtl - network-uri - network-uri-orphans-sqlite - nonempty-containers - - safe - text + - time - transformers - unison-codebase - - unison-codebase-sync - unison-core + - unison-core1 - unison-core-orphans-sqlite - unison-hash - unison-hash-orphans-sqlite - unison-prelude - unison-sqlite - unison-util-base32hex - - unison-util-cache - unison-util-file-embed - unison-util-serialization - unison-util-term @@ -45,7 +42,6 @@ dependencies: - uuid - uuid-orphans-sqlite - vector - - witch default-extensions: - ApplicativeDo @@ -71,6 +67,7 @@ default-extensions: - MultiParamTypeClasses - NamedFieldPuns - OverloadedLabels + - OverloadedRecordDot - OverloadedStrings - PatternSynonyms - QuasiQuotes diff --git a/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql b/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql new file mode 100644 index 0000000000..8de5f05169 --- /dev/null +++ b/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql @@ -0,0 +1,15 @@ +-- The most recent namespace that a user cd'd to. +-- This table should never have more than one row. +CREATE TABLE current_project_path ( + project_id INTEGER NOT NULL, + branch_id INTEGER NOT NULL, + -- A json array like ["foo", "bar"]; the root namespace is represented by the empty array + path TEXT PRIMARY KEY NOT NULL, + + foreign key (project_id, branch_id) + references project_branch (project_id, branch_id) + -- Prevent deleting the project you're currently in. + on delete no action +) WITHOUT ROWID; + +DROP TABLE most_recent_namespace; diff --git a/codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql b/codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql new file mode 100644 index 0000000000..5142051033 --- /dev/null +++ b/codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql @@ -0,0 +1,32 @@ +-- A reflog which is tied to the project/branch +CREATE TABLE project_branch_reflog ( + project_id INTEGER NOT NULL, + project_branch_id INTEGER NOT NULL, + -- Reminder that SQLITE doesn't have any actual 'time' type, + -- This column contains TEXT values formatted as ISO8601 strings + -- ("YYYY-MM-DD HH:MM:SS.SSS") + time TEXT NOT NULL, + -- from_root_causal_id will be null if the branch was just created + from_root_causal_id INTEGER NULL REFERENCES causal(self_hash_id), + to_root_causal_id INTEGER NOT NULL REFERENCES causal(self_hash_id), + reason TEXT NOT NULL, + + foreign key (project_id, project_branch_id) + references project_branch (project_id, branch_id) + on delete cascade +); + +CREATE INDEX project_branch_reflog_by_time ON project_branch_reflog ( + project_branch_id, time DESC +); + + +CREATE INDEX project_reflog_by_time ON project_branch_reflog ( + project_id, time DESC +); + +CREATE INDEX global_reflog_by_time ON project_branch_reflog ( + time DESC +); + + diff --git a/codebase2/codebase-sqlite/sql/014-add-project-branch-causal-hash-id.sql b/codebase2/codebase-sqlite/sql/014-add-project-branch-causal-hash-id.sql new file mode 100644 index 0000000000..588c6228eb --- /dev/null +++ b/codebase2/codebase-sqlite/sql/014-add-project-branch-causal-hash-id.sql @@ -0,0 +1,2 @@ +-- Add a new column to the project_branch table to store the causal_hash_id +ALTER TABLE project_branch ADD COLUMN causal_hash_id INTEGER NOT NULL; diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index ac1f606921..2641df87cd 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -21,6 +21,9 @@ extra-source-files: sql/009-add-squash-cache-table.sql sql/010-ensure-squash-cache-table.sql sql/011-cd-to-project-root.sql + sql/012-add-current-project-path-table.sql + sql/013-add-project-branch-reflog-table.sql + sql/014-add-project-branch-causal-hash-id.sql sql/create.sql source-repository head @@ -54,6 +57,7 @@ library U.Codebase.Sqlite.Patch.TypeEdit U.Codebase.Sqlite.Project U.Codebase.Sqlite.ProjectBranch + U.Codebase.Sqlite.ProjectReflog U.Codebase.Sqlite.Queries U.Codebase.Sqlite.Reference U.Codebase.Sqlite.Referent @@ -61,7 +65,6 @@ library U.Codebase.Sqlite.RemoteProjectBranch U.Codebase.Sqlite.Serialization U.Codebase.Sqlite.Symbol - U.Codebase.Sqlite.Sync22 U.Codebase.Sqlite.TempEntity U.Codebase.Sqlite.TempEntityType U.Codebase.Sqlite.Term.Format @@ -91,6 +94,7 @@ library MultiParamTypeClasses NamedFieldPuns OverloadedLabels + OverloadedRecordDot OverloadedStrings PatternSynonyms QuasiQuotes @@ -104,8 +108,7 @@ library TypeOperators ViewPatterns build-depends: - Only - , aeson + aeson , base , bytes , bytestring @@ -113,24 +116,22 @@ library , extra , generic-lens , lens - , monad-validate , mtl , network-uri , network-uri-orphans-sqlite , nonempty-containers - , safe , text + , time , transformers , unison-codebase - , unison-codebase-sync , unison-core , unison-core-orphans-sqlite + , unison-core1 , unison-hash , unison-hash-orphans-sqlite , unison-prelude , unison-sqlite , unison-util-base32hex - , unison-util-cache , unison-util-file-embed , unison-util-serialization , unison-util-term @@ -138,5 +139,4 @@ library , uuid , uuid-orphans-sqlite , vector - , witch default-language: Haskell2010 diff --git a/codebase2/codebase/U/Codebase/Causal.hs b/codebase2/codebase/U/Codebase/Causal.hs index aad0d36fa0..74e4c1fcf0 100644 --- a/codebase2/codebase/U/Codebase/Causal.hs +++ b/codebase2/codebase/U/Codebase/Causal.hs @@ -19,11 +19,11 @@ data Causal m hc he pe e = Causal } deriving stock (Functor, Generic) -instance Eq hc => Eq (Causal m hc he pe e) where +instance (Eq hc) => Eq (Causal m hc he pe e) where (==) = (==) `on` causalHash -- | @emap f g@ maps over the values and parents' values with @f@ and @g@. -emap :: Functor m => (e -> e') -> (pe -> pe') -> Causal m hc he pe e -> Causal m hc he pe' e' +emap :: (Functor m) => (e -> e') -> (pe -> pe') -> Causal m hc he pe e -> Causal m hc he pe' e' emap f g causal@Causal {parents, value} = causal { parents = Map.map (fmap (emap g g)) parents, diff --git a/codebase2/codebase/U/Codebase/Decl.hs b/codebase2/codebase/U/Codebase/Decl.hs index 26172ed1db..cf6ae66902 100644 --- a/codebase2/codebase/U/Codebase/Decl.hs +++ b/codebase2/codebase/U/Codebase/Decl.hs @@ -12,6 +12,7 @@ import U.Core.ABT qualified as ABT import U.Core.ABT.Var qualified as ABT import Unison.Hash (Hash) import Unison.Prelude +import Unison.Util.Recursion type ConstructorId = Word64 @@ -41,11 +42,11 @@ data DeclR r v = DataDeclaration } deriving (Show) -allVars :: Ord v => DeclR r v -> Set v +allVars :: (Ord v) => DeclR r v -> Set v allVars (DataDeclaration _ _ bound constructorTypes) = (Set.fromList $ foldMap ABT.allVars constructorTypes) <> Set.fromList bound -vmap :: Ord v' => (v -> v') -> DeclR r v -> DeclR r v' +vmap :: (Ord v') => (v -> v') -> DeclR r v -> DeclR r v' vmap f (DataDeclaration {declType, modifier, bound, constructorTypes}) = DataDeclaration { declType, @@ -82,7 +83,7 @@ data F a -- to the relevant piece of the component in the component map. unhashComponent :: forall v extra. - ABT.Var v => + (ABT.Var v) => Hash -> -- | A function to convert a reference to a variable. The actual var names aren't important. (Reference.Id -> v) -> @@ -107,7 +108,7 @@ unhashComponent componentHash refToVar m = { declType, modifier, bound, - constructorTypes = ABT.cata alg <$> constructorTypes + constructorTypes = cata alg <$> constructorTypes } where rewriteTypeReference :: Reference.Id' (Maybe Hash) -> Either v Reference.Reference @@ -126,8 +127,8 @@ unhashComponent componentHash refToVar m = case Map.lookup (fromMaybe componentHash <$> rid) withGeneratedVars of Nothing -> error "unhashComponent: self-reference not found in component map" Just (v, _, _) -> Left v - alg :: () -> ABT.ABT (Type.F' TypeRef) v (HashableType v) -> HashableType v - alg () = \case + alg :: ABT.Term' (Type.F' TypeRef) v () (HashableType v) -> HashableType v + alg (ABT.Term' _ () abt) = case abt of ABT.Var v -> ABT.var () v ABT.Cycle body -> ABT.cycle () body ABT.Abs v body -> ABT.abs () v body diff --git a/codebase2/codebase/U/Codebase/Referent.hs b/codebase2/codebase/U/Codebase/Referent.hs index 7eeeccba85..93aec093a8 100644 --- a/codebase2/codebase/U/Codebase/Referent.hs +++ b/codebase2/codebase/U/Codebase/Referent.hs @@ -63,7 +63,7 @@ type Id = Id' Hash Hash data Id' hTm hTp = RefId (Reference.Id' hTm) | ConId (Reference.Id' hTp) ConstructorId - deriving (Eq, Ord, Show) + deriving (Eq, Functor, Ord, Show) instance Bifunctor Referent' where bimap f g = \case diff --git a/codebase2/codebase/U/Codebase/Reflog.hs b/codebase2/codebase/U/Codebase/Reflog.hs index 971bc48395..27cc5ea59d 100644 --- a/codebase2/codebase/U/Codebase/Reflog.hs +++ b/codebase2/codebase/U/Codebase/Reflog.hs @@ -13,6 +13,7 @@ data Entry causal text = Entry toRootCausalHash :: causal, reason :: text } + deriving (Functor) instance Bifunctor Entry where bimap = bimapDefault diff --git a/codebase2/codebase/U/Codebase/Term.hs b/codebase2/codebase/U/Codebase/Term.hs index 3af9a5faff..07b938ae25 100644 --- a/codebase2/codebase/U/Codebase/Term.hs +++ b/codebase2/codebase/U/Codebase/Term.hs @@ -16,6 +16,7 @@ import U.Core.ABT qualified as ABT import U.Core.ABT.Var qualified as ABT import Unison.Hash (Hash) import Unison.Prelude +import Unison.Util.Recursion type ConstructorId = Word64 @@ -207,7 +208,7 @@ extraMapM ftext ftermRef ftypeRef ftermLink ftypeLink fvt = go' rmapPattern :: (t -> t') -> (r -> r') -> Pattern t r -> Pattern t' r' rmapPattern ft fr p = runIdentity . rmapPatternM (pure . ft) (pure . fr) $ p -rmapPatternM :: Applicative m => (t -> m t') -> (r -> m r') -> Pattern t r -> m (Pattern t' r') +rmapPatternM :: (Applicative m) => (t -> m t') -> (r -> m r') -> Pattern t r -> m (Pattern t' r') rmapPatternM ft fr = go where go = \case @@ -260,7 +261,7 @@ dependencies = -- to the relevant piece of the component in the component map. unhashComponent :: forall v extra. - ABT.Var v => + (ABT.Var v) => -- | The hash of the component, this is used to fill in self-references. Hash -> -- | A function to convert a reference to a variable. The actual var names aren't important. @@ -281,7 +282,7 @@ unhashComponent componentHash refToVar m = assignVar :: Reference.Id -> (trm, extra) -> StateT (Set v) Identity (v, trm, extra) assignVar r (trm, extra) = (,trm,extra) <$> ABT.freshenS (refToVar r) fillSelfReferences :: Term v -> HashableTerm v - fillSelfReferences = (ABT.cata alg) + fillSelfReferences = cata alg where rewriteTermReference :: Reference.Id' (Maybe Hash) -> Either v Reference.Reference rewriteTermReference rid@(Reference.Id mayH pos) = @@ -299,8 +300,8 @@ unhashComponent componentHash refToVar m = case Map.lookup (fromMaybe componentHash <$> rid) withGeneratedVars of Nothing -> error "unhashComponent: self-reference not found in component map" Just (v, _, _) -> Left v - alg :: () -> ABT.ABT (F v) v (HashableTerm v) -> HashableTerm v - alg () = \case + alg :: ABT.Term' (F v) v () (HashableTerm v) -> HashableTerm v + alg (ABT.Term' _ () abt) = case abt of ABT.Var v -> ABT.var () v ABT.Cycle body -> ABT.cycle () body ABT.Abs v body -> ABT.abs () v body diff --git a/codebase2/codebase/package.yaml b/codebase2/codebase/package.yaml index 1608bed83e..c9a1a2ab55 100644 --- a/codebase2/codebase/package.yaml +++ b/codebase2/codebase/package.yaml @@ -7,12 +7,11 @@ dependencies: - generic-lens - lens - mtl - - text - time - unison-core - unison-hash - unison-prelude - - unison-util-base32hex + - unison-util-recursion library: source-dirs: . diff --git a/codebase2/codebase/unison-codebase.cabal b/codebase2/codebase/unison-codebase.cabal index 4fcd1abb4d..5a7335649f 100644 --- a/codebase2/codebase/unison-codebase.cabal +++ b/codebase2/codebase/unison-codebase.cabal @@ -65,10 +65,9 @@ library , generic-lens , lens , mtl - , text , time , unison-core , unison-hash , unison-prelude - , unison-util-base32hex + , unison-util-recursion default-language: GHC2021 diff --git a/codebase2/core/U/Codebase/Reference.hs b/codebase2/core/U/Codebase/Reference.hs index 1146ca8aa1..e40ce2ac37 100644 --- a/codebase2/core/U/Codebase/Reference.hs +++ b/codebase2/core/U/Codebase/Reference.hs @@ -74,7 +74,7 @@ data ReferenceType = RtTerm | RtType deriving (Eq, Ord, Show) data Reference' t h = ReferenceBuiltin t | ReferenceDerived (Id' h) - deriving stock (Eq, Generic, Ord, Show) + deriving stock (Eq, Generic, Functor, Ord, Show) -- | A type declaration reference. type TermReference' t h = Reference' t h diff --git a/codebase2/core/U/Core/ABT.hs b/codebase2/core/U/Core/ABT.hs index 690202d366..2e22791fde 100644 --- a/codebase2/core/U/Core/ABT.hs +++ b/codebase2/core/U/Core/ABT.hs @@ -10,6 +10,7 @@ import Debug.RecoverRTTI qualified as RTTI import U.Core.ABT.Var (Var (freshIn)) import Unison.Debug qualified as Debug import Unison.Prelude +import Unison.Util.Recursion import Prelude hiding (abs, cycle) data ABT f v r @@ -24,6 +25,13 @@ data ABT f v r data Term f v a = Term {freeVars :: Set v, annotation :: a, out :: ABT f v (Term f v a)} deriving (Functor, Foldable, Generic, Traversable) +data Term' f v a x = Term' {freeVars' :: Set v, annotation' :: a, out' :: ABT f v x} + deriving (Functor) + +instance (Functor f) => Recursive (Term f v a) (Term' f v a) where + embed (Term' vs a abt) = Term vs a abt + project (Term vs a abt) = Term' vs a abt + instance (Foldable f, Functor f, forall a. (Eq a) => Eq (f a), Var v) => Eq (Term f v a) where -- alpha equivalence, works by renaming any aligned Abs ctors to use a common fresh variable t1 == t2 = go (out t1) (out t2) @@ -97,24 +105,6 @@ vmapM f (Term _ a out) = case out of Cycle r -> cycle a <$> vmapM f r Abs v body -> abs a <$> f v <*> vmapM f body -cata :: - (Functor f) => - (a -> ABT f v x -> x) -> - Term f v a -> - x -cata abtAlg = - let go (Term _fvs a out) = abtAlg a (fmap go out) - in go - -para :: - (Functor f) => - (a -> ABT f v (Term f v a, x) -> x) -> - Term f v a -> - x -para abtAlg = - let go (Term _fvs a out) = abtAlg a (fmap (\x -> (x, go x)) out) - in go - transform :: (Ord v, Foldable g, Functor g) => (forall a. f a -> g a) -> diff --git a/codebase2/core/Unison/Core/Project.hs b/codebase2/core/Unison/Core/Project.hs index 632f9702ec..8f5e05eca6 100644 --- a/codebase2/core/Unison/Core/Project.hs +++ b/codebase2/core/Unison/Core/Project.hs @@ -29,7 +29,7 @@ data ProjectAndBranch a b = ProjectAndBranch { project :: a, branch :: b } - deriving stock (Eq, Generic, Show) + deriving stock (Eq, Generic, Show, Functor) instance Bifunctor ProjectAndBranch where bimap f g (ProjectAndBranch a b) = ProjectAndBranch (f a) (g b) diff --git a/codebase2/core/Unison/NameSegment.hs b/codebase2/core/Unison/NameSegment.hs index 32771f75dc..924e2b8951 100644 --- a/codebase2/core/Unison/NameSegment.hs +++ b/codebase2/core/Unison/NameSegment.hs @@ -1,5 +1,6 @@ module Unison.NameSegment ( NameSegment, + toUnescapedText, -- * Sentinel name segments defaultPatchSegment, @@ -23,7 +24,7 @@ module Unison.NameSegment ) where -import Unison.NameSegment.Internal (NameSegment (NameSegment)) +import Unison.NameSegment.Internal (NameSegment (NameSegment, toUnescapedText)) ------------------------------------------------------------------------------------------------------------------------ -- special segment names diff --git a/codebase2/core/Unison/NameSegment/Internal.hs b/codebase2/core/Unison/NameSegment/Internal.hs index 9ecc1ff43b..a7c108c4a5 100644 --- a/codebase2/core/Unison/NameSegment/Internal.hs +++ b/codebase2/core/Unison/NameSegment/Internal.hs @@ -27,12 +27,13 @@ newtype NameSegment = NameSegment deriving newtype (Alphabetical) instance - TypeError - ( 'TypeError.Text "You cannot implicitly convert a ‘String’ to a ‘NameSegment’. If you need a" - ':$$: 'TypeError.Text "special-cased segment it should exist as a constant in" - ':$$: 'TypeError.Text "“Unison.NameSegment”, otherwise it should be parsed via" - ':$$: 'TypeError.Text "“Unison.Syntax.NameSegment”." - ) => + ( TypeError + ( 'TypeError.Text "You cannot implicitly convert a ‘String’ to a ‘NameSegment’. If you need a" + ':$$: 'TypeError.Text "special-cased segment it should exist as a constant in" + ':$$: 'TypeError.Text "“Unison.NameSegment”, otherwise it should be parsed via" + ':$$: 'TypeError.Text "“Unison.Syntax.NameSegment”." + ) + ) => IsString NameSegment where fromString = undefined diff --git a/codebase2/core/Unison/Util/Alphabetical.hs b/codebase2/core/Unison/Util/Alphabetical.hs index b87bfea3f7..1c84ead241 100644 --- a/codebase2/core/Unison/Util/Alphabetical.hs +++ b/codebase2/core/Unison/Util/Alphabetical.hs @@ -18,10 +18,10 @@ import Data.Text (Text) class (Eq n) => Alphabetical n where compareAlphabetical :: n -> n -> Ordering -sortAlphabetically :: Alphabetical a => [a] -> [a] +sortAlphabetically :: (Alphabetical a) => [a] -> [a] sortAlphabetically as = (\(OrderAlphabetically a) -> a) <$> List.sort (map OrderAlphabetically as) -sortAlphabeticallyOn :: Alphabetical a => (b -> a) -> [b] -> [b] +sortAlphabeticallyOn :: (Alphabetical a) => (b -> a) -> [b] -> [b] sortAlphabeticallyOn f = List.sortOn (OrderAlphabetically . f) instance Alphabetical Text where diff --git a/codebase2/core/package.yaml b/codebase2/core/package.yaml index 05e2810a52..a090d9af99 100644 --- a/codebase2/core/package.yaml +++ b/codebase2/core/package.yaml @@ -17,8 +17,7 @@ dependencies: - text - unison-hash - unison-prelude - - unison-util-base32hex - - vector + - unison-util-recursion default-extensions: - ApplicativeDo diff --git a/codebase2/core/unison-core.cabal b/codebase2/core/unison-core.cabal index 9cea44a2ab..2045517a08 100644 --- a/codebase2/core/unison-core.cabal +++ b/codebase2/core/unison-core.cabal @@ -64,6 +64,5 @@ library , text , unison-hash , unison-prelude - , unison-util-base32hex - , vector + , unison-util-recursion default-language: Haskell2010 diff --git a/codebase2/util-serialization/U/Util/Serialization.hs b/codebase2/util-serialization/U/Util/Serialization.hs index ecc90fe439..2d4f1bd7ae 100644 --- a/codebase2/util-serialization/U/Util/Serialization.hs +++ b/codebase2/util-serialization/U/Util/Serialization.hs @@ -8,7 +8,7 @@ module U.Util.Serialization where -import Control.Applicative (Applicative (liftA2), liftA3) +import Control.Applicative (liftA3) import Control.Monad (foldM, replicateM, replicateM_, when) import Data.Bits (Bits, clearBit, setBit, shiftL, shiftR, testBit, (.|.)) import Data.ByteString (ByteString, readFile, writeFile) @@ -154,7 +154,7 @@ getVector getA = do length <- getVarInt Vector.replicateM length getA -skipVector :: MonadGet m => m a -> m () +skipVector :: (MonadGet m) => m a -> m () skipVector getA = do length <- getVarInt replicateM_ length getA diff --git a/codebase2/util-term/U/Util/Type.hs b/codebase2/util-term/U/Util/Type.hs index 7acf6a4c14..a8eccccf05 100644 --- a/codebase2/util-term/U/Util/Type.hs +++ b/codebase2/util-term/U/Util/Type.hs @@ -61,7 +61,7 @@ flattenEffects es = [es] generalize :: (Ord v) => [v] -> TypeR r v -> TypeR r v generalize vs t = foldr f t vs where - f v t = if Set.member v (ABT.freeVars t) then forall v t else t + f v t = if Set.member v (ABT.freeVars t) then forAll v t else t -- * Patterns @@ -80,8 +80,8 @@ pattern Effect1' e t <- ABT.Tm' (Effect e t) pattern Ref' :: r -> TypeR r v pattern Ref' r <- ABT.Tm' (Ref r) -forall :: (Ord v) => v -> TypeR r v -> TypeR r v -forall v body = ABT.tm () (Forall (ABT.abs () v body)) +forAll :: (Ord v) => v -> TypeR r v -> TypeR r v +forAll v body = ABT.tm () (Forall (ABT.abs () v body)) unforall' :: TypeR r v -> ([v], TypeR r v) unforall' (ForallsNamed' vs t) = (vs, t) diff --git a/contrib/cabal.project b/contrib/cabal.project index abab30e92e..759ea5add2 100644 --- a/contrib/cabal.project +++ b/contrib/cabal.project @@ -21,35 +21,34 @@ packages: lib/unison-util-base32hex lib/unison-util-bytes lib/unison-util-cache + lib/unison-util-file-embed + lib/unison-util-recursion lib/unison-util-relation lib/unison-util-rope - lib/unison-util-file-embed - lib/unison-util-nametree parser-typechecker unison-core unison-cli + unison-cli-main unison-hashing-v2 + unison-merge unison-share-api unison-share-projects-api unison-syntax yaks/easytest -source-repository-package - type: git - location: https://github.com/unisonweb/configurator.git - tag: e47e9e9fe1f576f8c835183b9def52d73c01327a - source-repository-package type: git location: https://github.com/unisonweb/haskeline.git tag: 9275eea7982dabbf47be2ba078ced669ae7ef3d5 constraints: - fsnotify < 0.4, - crypton-x509-store <= 1.6.8, - servant <= 0.19.1, - optparse-applicative <= 0.17.1.0 + lsp == 2.3.0.0, + fsnotify == 0.4.1.0, + crypton-x509-store == 1.6.9, + servant == 0.20.1, + optparse-applicative == 0.18.1.0, + tls == 1.8.0 -- For now there is no way to apply ghc-options for all local packages -- See https://cabal.readthedocs.io/en/latest/cabal-project.html#package-configuration-options @@ -128,6 +127,9 @@ package unison-core package unison-hashing-v2 ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info +package unison-merge + ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info + package unison-share-api ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info diff --git a/dev-ui-install.sh b/dev-ui-install.sh index a9f3d5d64d..0ade79bf2a 100755 --- a/dev-ui-install.sh +++ b/dev-ui-install.sh @@ -1,3 +1,6 @@ +#!/usr/bin/env sh +set -eu + echo "This script downloads the latest Unison Local UI release" echo "and puts it in the correct spot next to the unison" echo "executable built by stack." @@ -7,4 +10,4 @@ stack build curl -L https://github.com/unisonweb/unison-local-ui/releases/download/latest/unisonLocal.zip --output unisonLocal.zip parent_dir="$(dirname -- $(stack exec which unison))" mkdir -p "$parent_dir/ui" -unzip -o unisonLocal.zip -d "$parent_dir/ui" +unzip -q -o unisonLocal.zip -d "$parent_dir/ui" diff --git a/development.markdown b/development.markdown index 962a507c63..d63bf7c245 100644 --- a/development.markdown +++ b/development.markdown @@ -22,7 +22,7 @@ We use 0.5.0.1 of Ormolu and CI will add an extra commit, if needed, to autoform Also note that you can always wrap a comment around some code you don't want Ormolu to touch, using: -``` +```haskell {- ORMOLU_DISABLE -} dontFormatMe = do blah blah @@ -42,7 +42,7 @@ Some tests are executables instead: * `stack exec transcripts` runs the transcripts-related integration tests, found in `unison-src/transcripts`. You can add more tests to this directory. * `stack exec transcripts -- prefix-of-filename` runs only transcript tests with a matching filename prefix. -* `stack exec integration-tests` runs the additional integration tests for cli. These tests are not triggered by `tests` or `transcripts`. +* `stack exec cli-integration-tests` runs the additional integration tests for cli. These tests are not triggered by `tests` or `transcripts`. * `stack exec unison -- transcript unison-src/transcripts-round-trip/main.md` runs the pretty-printing round trip tests * `stack exec unison -- transcript unison-src/transcripts-manual/benchmarks.md` runs the benchmark suite. Output goes in unison-src/transcripts-manual/benchmarks/output.txt. @@ -96,11 +96,13 @@ This codebase uses symlinks as a workaround for some inconveniences in the `here First you'll need to enable "Developer Mode" in your Windows settings. - See https://consumer.huawei.com/en/support/content/en-us15594140/ +> See https://consumer.huawei.com/en/support/content/en-us15594140/ Then you'll need to enable symlink support in your `git` configuration, e.g. - `git config core.symlinks true` +```shell +git config core.symlinks true +``` And then ask `git` to fix up your symlinks with `git checkout .` @@ -113,10 +115,41 @@ Stack doesn't work deterministically in Windows due to mismatched expectations a ## Building with Nix +__NB__: It is important that the Unison Nix cache is trusted when building, otherwise you will likely end up building hundreds of packages, including GHC itself. + +The recommended way to do this is to add the public key and URL for the cache to your system’s Nix configuration. /etc/nix/nix.conf should have lines similar to +```conf +trusted-public-keys = unison.cachix.org-1:i1DUFkisRPVOyLp/vblDsbsObmyCviq/zs6eRuzth3k= +trusted-substituters = https://unison.cachix.org +``` +these lines could be prefixed with `extra-` and they may have additional entries besides the ones for our cache. + +This command should work if you don’t want to edit the file manually: +```shell +sudo sh -c 'echo "extra-trusted-public-keys = unison.cachix.org-1:i1DUFkisRPVOyLp/vblDsbsObmyCviq/zs6eRuzth3k= +extra-trusted-substituters = https://unison.cachix.org" >>/etc/nix/nix.conf' +``` +After updating /etc/nix/nix.conf, you need to restart the Nix daemon. To do this on +- Ubuntu: `sudo systemctl restart nix-daemon` +- MacOS: + ```shell + sudo launchctl unload /Library/LaunchDaemons/org.nixos.nix-daemon.plist + sudo launchctl load /Library/LaunchDaemons/org.nixos.nix-daemon.plist + ``` + +If you use NixOS, you may instead add this via your configuration.nix with +```nix +nix.settings.trusted-public-keys = ["unison.cachix.org-1:i1DUFkisRPVOyLp/vblDsbsObmyCviq/zs6eRuzth3k="]; +nix.settings.trusted-substituters = ["https://unison.cachix.org"]; +``` +and run `sudo nixos-rebuild switch` afterward. + +It is _not_ recommended to add your user to `trusted-users`. This _can_ make enabling flake configurations simpler (like the Unison Nix cache here), but [it is equivalent to giving that user root access (without need for sudo)](https://nix.dev/manual/nix/2.23/command-ref/conf-file.html#conf-trusted-users). + ## Building package components with nix ### Build the unison executable -``` +```shell nix build ``` @@ -125,7 +158,7 @@ This is specified with the normal `::` triple. Some examples: -``` +```shell nix build '.#component-unison-cli:lib:unison-cli' nix build '.#component-unison-syntax:test:syntax-tests' nix build '.#component-unison-cli:exe:transcripts' @@ -143,7 +176,7 @@ include: - ormolu - haskell-language-server -``` +```shell nix develop ``` @@ -153,7 +186,7 @@ versions of the compiler and other development tools. Additionally, all non-local haskell dependencies (including profiling dependencies) are provided in the nix shell. -``` +```shell nix develop '.#cabal-local' ``` @@ -163,17 +196,17 @@ versions of the compiler and other development tools. Additionally, all haskell dependencies of this package are provided by the nix shell (including profiling dependencies). -``` +```shell nix develop '.#cabal-' ``` for example: -``` +```shell nix develop '.#cabal-unison-cli' ``` or -``` +```shell nix develop '.#cabal-unison-parser-typechecker' ``` @@ -182,8 +215,12 @@ want to profile `unison-cli-main:exe:unison` then you could get into one of thes shells, cd into its directory, then run the program with profiling. -``` +```shell nix develop '.#cabal-unison-parser-typechecker' cd unison-cli cabal run --enable-profiling unison-cli-main:exe:unison -- +RTS -p ``` + +## Native compilation + +See the [readme](scheme-libs/racket/unison/Readme.md). diff --git a/docs/repoformats/v2.markdown b/docs/repoformats/v2.markdown index e5e99f2fb3..5c9c5b74b2 100644 --- a/docs/repoformats/v2.markdown +++ b/docs/repoformats/v2.markdown @@ -126,7 +126,7 @@ In order to avoid fully rewriting the ABT to update `TextId` and `ObjectId` repl An example: -```unison +``` unison type Tree = Branch Tree Tree | INode (Optional ##Int) | BNode Boolean ``` This gives us a decl with two constructor types: diff --git a/editor-support/vim/syntax/unison.vim b/editor-support/vim/syntax/unison.vim index ec193723a7..3bd3b2ef68 100644 --- a/editor-support/vim/syntax/unison.vim +++ b/editor-support/vim/syntax/unison.vim @@ -48,7 +48,7 @@ syn match uSpecialCharError contained "\\&\|'''\+" syn region uString start=+"+ skip=+\\\\\|\\"+ end=+"+ contains=uSpecialChar syn match uCharacter "[^a-zA-Z0-9_']'\([^\\]\|\\[^']\+\|\\'\)'"lc=1 contains=uSpecialChar,uSpecialCharError syn match uCharacter "^'\([^\\]\|\\[^']\+\|\\'\)'" contains=uSpecialChar,uSpecialCharError -syn match uNumber "\<[0-9]\+\>\|\<0[xX][0-9a-fA-F]\+\>\|\<0[oO][0-7]\+\>" +syn match uNumber "\<[0-9]\+\>\|\<0[xX][0-9a-fA-F]\+\>\|\<0[oO][0-7]\+\>\|\<0[bB][01]\+\>" syn match uFloat "\<[0-9]\+\.[0-9]\+\([eE][-+]\=[0-9]\+\)\=\>" " Keyword definitions. These must be patterns instead of keywords @@ -83,7 +83,7 @@ syn region uDocDirective contained matchgroup=unisonDocDirective start="\(@ syn match uDebug "\<\(todo\|bug\|Debug.trace\)\>" -" things like +" things like " > my_func 1 3 " test> Function.tap.tests.t1 = check let " use Nat == + @@ -101,7 +101,7 @@ if version >= 508 || !exists("did_u_syntax_inits") else command -nargs=+ HiLink hi def link endif - + HiLink uWatch Debug HiLink uDocMono Delimiter HiLink unisonDocDirective Import diff --git a/flake.lock b/flake.lock index d4ece12a51..4c07d21e1a 100644 --- a/flake.lock +++ b/flake.lock @@ -135,51 +135,14 @@ "type": "github" } }, - "ghc98X": { - "flake": false, - "locked": { - "lastModified": 1696643148, - "narHash": "sha256-E02DfgISH7EvvNAu0BHiPvl1E5FGMDi0pWdNZtIBC9I=", - "ref": "ghc-9.8", - "rev": "443e870d977b1ab6fc05f47a9a17bc49296adbd6", - "revCount": 61642, - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - }, - "original": { - "ref": "ghc-9.8", - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - } - }, - "ghc99": { - "flake": false, - "locked": { - "lastModified": 1697054644, - "narHash": "sha256-kKarOuXUaAH3QWv7ASx+gGFMHaHKe0pK5Zu37ky2AL4=", - "ref": "refs/heads/master", - "rev": "f383a242c76f90bcca8a4d7ee001dcb49c172a9a", - "revCount": 62040, - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - }, - "original": { - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - } - }, "hackage": { "flake": false, "locked": { - "lastModified": 1699402991, - "narHash": "sha256-2nQBlA3ygBiIqVPh2J1JwP51rEO0xMjyoOaoJk5PboY=", + "lastModified": 1719535035, + "narHash": "sha256-kCCfZytGgkRYlsiNe/dwLAnpNOvfywpjVl61hO/8l2M=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "9e963602a5b3259dac9cf5e994f0a338fb352b7e", + "rev": "66f23365685f71610460f3c2c0dfa91f96c532ac", "type": "github" }, "original": { @@ -197,14 +160,16 @@ "cardano-shell": "cardano-shell", "flake-compat": "flake-compat", "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", - "ghc98X": "ghc98X", - "ghc99": "ghc99", "hackage": "hackage", "hls-1.10": "hls-1.10", "hls-2.0": "hls-2.0", "hls-2.2": "hls-2.2", "hls-2.3": "hls-2.3", "hls-2.4": "hls-2.4", + "hls-2.5": "hls-2.5", + "hls-2.6": "hls-2.6", + "hls-2.7": "hls-2.7", + "hls-2.8": "hls-2.8", "hpc-coveralls": "hpc-coveralls", "hydra": "hydra", "iserv-proxy": "iserv-proxy", @@ -218,16 +183,17 @@ "nixpkgs-2205": "nixpkgs-2205", "nixpkgs-2211": "nixpkgs-2211", "nixpkgs-2305": "nixpkgs-2305", + "nixpkgs-2311": "nixpkgs-2311", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", "stackage": "stackage" }, "locked": { - "lastModified": 1699404571, - "narHash": "sha256-EwI7vKBxCHvIKPWbvGlOF9IZlSFqPODgT/BQy8Z2s/w=", + "lastModified": 1719535822, + "narHash": "sha256-IteIKK4+GEZI2nHqCz0zRVgQ3aqs/WXKTOt2sbHJmGk=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "cec253ca482301509e9e90cb5c15299dd3550cce", + "rev": "72bc84d0a4e8d0536505628040d96fd0a9e16c70", "type": "github" }, "original": { @@ -307,16 +273,84 @@ "hls-2.4": { "flake": false, "locked": { - "lastModified": 1696939266, - "narHash": "sha256-VOMf5+kyOeOmfXTHlv4LNFJuDGa7G3pDnOxtzYR40IU=", + "lastModified": 1699862708, + "narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.4.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.5": { + "flake": false, + "locked": { + "lastModified": 1701080174, + "narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "27f8c3d3892e38edaef5bea3870161815c4d014c", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.5.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.6": { + "flake": false, + "locked": { + "lastModified": 1705325287, + "narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.6.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.7": { + "flake": false, + "locked": { + "lastModified": 1708965829, + "narHash": "sha256-LfJ+TBcBFq/XKoiNI7pc4VoHg4WmuzsFxYJ3Fu+Jf+M=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "50322b0a4aefb27adc5ec42f5055aaa8f8e38001", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.7.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.8": { + "flake": false, + "locked": { + "lastModified": 1715153580, + "narHash": "sha256-Vi/iUt2pWyUJlo9VrYgTcbRviWE0cFO6rmGi9rmALw0=", "owner": "haskell", "repo": "haskell-language-server", - "rev": "362fdd1293efb4b82410b676ab1273479f6d17ee", + "rev": "dd1be1beb16700de59e0d6801957290bcf956a0a", "type": "github" }, "original": { "owner": "haskell", - "ref": "2.4.0.0", + "ref": "2.8.0.0", "repo": "haskell-language-server", "type": "github" } @@ -363,18 +397,18 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1691634696, - "narHash": "sha256-MZH2NznKC/gbgBu8NgIibtSUZeJ00HTLJ0PlWKCBHb0=", - "ref": "hkm/remote-iserv", - "rev": "43a979272d9addc29fbffc2e8542c5d96e993d73", - "revCount": 14, - "type": "git", - "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" + "lastModified": 1717479972, + "narHash": "sha256-7vE3RQycHI1YT9LHJ1/fUaeln2vIpYm6Mmn8FTpYeVo=", + "owner": "stable-haskell", + "repo": "iserv-proxy", + "rev": "2ed34002247213fc435d0062350b91bab920626e", + "type": "github" }, "original": { - "ref": "hkm/remote-iserv", - "type": "git", - "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" + "owner": "stable-haskell", + "ref": "iserv-syms", + "repo": "iserv-proxy", + "type": "github" } }, "lowdown-src": { @@ -512,11 +546,11 @@ }, "nixpkgs-2305": { "locked": { - "lastModified": 1695416179, - "narHash": "sha256-610o1+pwbSu+QuF3GE0NU5xQdTHM3t9wyYhB9l94Cd8=", + "lastModified": 1701362232, + "narHash": "sha256-GVdzxL0lhEadqs3hfRLuj+L1OJFGiL/L7gCcelgBlsw=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "715d72e967ec1dd5ecc71290ee072bcaf5181ed6", + "rev": "d2332963662edffacfddfad59ff4f709dde80ffe", "type": "github" }, "original": { @@ -526,6 +560,22 @@ "type": "github" } }, + "nixpkgs-2311": { + "locked": { + "lastModified": 1701386440, + "narHash": "sha256-xI0uQ9E7JbmEy/v8kR9ZQan6389rHug+zOtZeZFiDJk=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "293822e55ec1872f715a66d0eda9e592dc14419f", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, "nixpkgs-regression": { "locked": { "lastModified": 1643052045, @@ -542,35 +592,35 @@ "type": "github" } }, - "nixpkgs-unstable": { + "nixpkgs-release": { "locked": { - "lastModified": 1695318763, - "narHash": "sha256-FHVPDRP2AfvsxAdc+AsgFJevMz5VBmnZglFUMlxBkcY=", + "lastModified": 1719520878, + "narHash": "sha256-5BXzNOl2RVHcfS/oxaZDKOi7gVuTyWPibQG0DHd5sSc=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "e12483116b3b51a185a33a272bf351e357ba9a99", + "rev": "a44bedbb48c367f0476e6a3a27bf28f6330faf23", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-unstable", + "ref": "release-24.05", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs-unstable_2": { + "nixpkgs-unstable": { "locked": { - "lastModified": 1699781429, - "narHash": "sha256-UYefjidASiLORAjIvVsUHG6WBtRhM67kTjEY4XfZOFs=", + "lastModified": 1694822471, + "narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "e44462d6021bfe23dfb24b775cc7c390844f773d", + "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixos-unstable", "repo": "nixpkgs", + "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", "type": "github" } }, @@ -595,21 +645,21 @@ "inputs": { "flake-utils": "flake-utils", "haskellNix": "haskellNix", - "nixpkgs": [ + "nixpkgs-haskellNix": [ "haskellNix", "nixpkgs-unstable" ], - "nixpkgs-unstable": "nixpkgs-unstable_2" + "nixpkgs-release": "nixpkgs-release" } }, "stackage": { "flake": false, "locked": { - "lastModified": 1699402155, - "narHash": "sha256-fOywUFLuAuZAkIrv1JdjGzfY53uEiMRlu8UpdJtCjh0=", + "lastModified": 1719102283, + "narHash": "sha256-pon+cXgMWPlCiBx9GlRcjsjTHbCc8fDVgOGb3Z7qhRM=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "7c7bfe8cca23c96b850e16f3c0b159aca1850314", + "rev": "7df45e0bd9852810d8070f9c5257f8e7a4677b91", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 8c8725da3b..a266bd2e29 100644 --- a/flake.nix +++ b/flake.nix @@ -8,17 +8,17 @@ inputs = { haskellNix.url = "github:input-output-hk/haskell.nix"; - nixpkgs.follows = "haskellNix/nixpkgs-unstable"; - nixpkgs-unstable.url = "github:NixOS/nixpkgs/nixos-unstable"; + nixpkgs-haskellNix.follows = "haskellNix/nixpkgs-unstable"; + nixpkgs-release.url = "github:NixOS/nixpkgs/release-24.05"; flake-utils.url = "github:numtide/flake-utils"; }; outputs = { self, - nixpkgs, - flake-utils, haskellNix, - nixpkgs-unstable, + nixpkgs-haskellNix, + nixpkgs-release, + flake-utils, }: flake-utils.lib.eachSystem [ "x86_64-linux" @@ -26,100 +26,60 @@ "aarch64-darwin" ] (system: let - versions = { - ghc = "928"; - ormolu = "0.5.2.0"; - hls = "2.4.0.0"; - stack = "2.13.1"; + ## It’s much easier to read from a JSON file than to have JSON import from some other file, so we extract some + ## configuration from the VS Code settings to avoid duplication. + vscodeSettings = nixpkgs-release.lib.importJSON ./.vscode/settings.json; + versions = + vscodeSettings."haskell.toolchain" + ## There are some things we want to pin that the VS Code Haskell extension doesn’t let us control. + // { hpack = "0.35.2"; + ormolu = "0.7.2.0"; }; - overlays = [ - haskellNix.overlay - (import ./nix/haskell-nix-overlay.nix) - (import ./nix/unison-overlay.nix) - ]; - pkgs = import nixpkgs { - inherit system overlays; - inherit (haskellNix) config; - }; - haskell-nix-flake = import ./nix/haskell-nix-flake.nix { - inherit pkgs versions; - inherit (nixpkgs-packages) stack hpack; - }; - unstable = import nixpkgs-unstable { + pkgs = import nixpkgs-haskellNix { inherit system; + inherit (haskellNix) config; overlays = [ - (import ./nix/unison-overlay.nix) - (import ./nix/nixpkgs-overlay.nix {inherit versions;}) + haskellNix.overlay + (import ./nix/dependencies.nix {inherit nixpkgs-release;}) ]; }; - nixpkgs-packages = let - hpkgs = unstable.haskell.packages.ghcunison; - exe = unstable.haskell.lib.justStaticExecutables; - in { - ghc = unstable.haskell.compiler."ghc${versions.ghc}"; - ormolu = exe hpkgs.ormolu; - hls = unstable.unison-hls; - stack = unstable.unison-stack; - unwrapped-stack = unstable.stack; - hpack = unstable.hpack; + unison-project = import ./nix/unison-project.nix { + inherit (nixpkgs-haskellNix) lib; + inherit (pkgs) haskell-nix; }; - nixpkgs-devShells = { - only-tools-nixpkgs = unstable.mkShell { - name = "only-tools-nixpkgs"; - buildInputs = let - build-tools = with nixpkgs-packages; [ - ghc - ormolu - hls - stack - hpack - ]; - native-packages = - pkgs.lib.optionals pkgs.stdenv.isDarwin - (with unstable.darwin.apple_sdk.frameworks; [Cocoa]); - c-deps = with unstable; [pkg-config zlib glibcLocales]; - in - build-tools ++ c-deps ++ native-packages; - shellHook = '' - export LD_LIBRARY_PATH=${pkgs.zlib}/lib:$LD_LIBRARY_PATH - ''; - }; + haskell-nix-flake = import ./nix/haskell-nix-flake.nix { + inherit pkgs unison-project versions; + inherit (nixpkgs-haskellNix) lib; }; - renameAttrs = fn: - nixpkgs.lib.mapAttrs' (name: value: { + nixpkgs-haskellNix.lib.mapAttrs' (name: value: { inherit value; name = fn name; }); in - assert nixpkgs-packages.ormolu.version == versions.ormolu; - assert nixpkgs-packages.hls.version == versions.hls; - assert nixpkgs-packages.unwrapped-stack.version == versions.stack; - assert nixpkgs-packages.hpack.version == versions.hpack; { + assert pkgs.stack.version == versions.stack; + assert pkgs.hpack.version == versions.hpack; { packages = - nixpkgs-packages - // renameAttrs (name: "component-${name}") haskell-nix-flake.packages + renameAttrs (name: "component-${name}") haskell-nix-flake.packages // renameAttrs (name: "docker-${name}") (import ./nix/docker.nix { inherit pkgs; haskell-nix = haskell-nix-flake.packages; }) // { default = haskell-nix-flake.defaultPackage; - build-tools = pkgs.symlinkJoin { - name = "build-tools"; - paths = self.devShells."${system}".only-tools-nixpkgs.buildInputs; - }; all = pkgs.symlinkJoin { name = "all"; paths = let - all-other-packages = builtins.attrValues (builtins.removeAttrs self.packages."${system}" ["all" "build-tools"]); + all-other-packages = + builtins.attrValues (builtins.removeAttrs self.packages."${system}" [ + "all" + "docker-ucm" # this package doesn’t produce a directory + ]); devshell-inputs = builtins.concatMap (devShell: devShell.buildInputs ++ devShell.nativeBuildInputs) - [ - self.devShells."${system}".only-tools-nixpkgs - ]; + (builtins.attrValues self.devShells."${system}"); in all-other-packages ++ devshell-inputs; }; @@ -130,9 +90,8 @@ // {default = self.apps."${system}"."component-unison-cli-main:exe:unison";}; devShells = - nixpkgs-devShells - // renameAttrs (name: "cabal-${name}") haskell-nix-flake.devShells - // {default = self.devShells."${system}".only-tools-nixpkgs;}; + renameAttrs (name: "cabal-${name}") haskell-nix-flake.devShells + // {default = self.devShells."${system}".cabal-local;}; checks = renameAttrs (name: "component-${name}") haskell-nix-flake.checks; diff --git a/hie.yaml b/hie.yaml index ce2a6418a5..811a7099ff 100644 --- a/hie.yaml +++ b/hie.yaml @@ -98,6 +98,11 @@ cradle: - path: "parser-typechecker/tests" component: "unison-parser-typechecker:test:parser-typechecker-tests" + - path: "unison-runtime/src" + component: "unison-runtime:lib" + + - path: "unison-runtime/tests" + component: "unison-runtime:test:runtime-tests" - path: "unison-cli/src" component: "unison-cli:lib" diff --git a/lib/unison-hash/package.yaml b/lib/unison-hash/package.yaml index 977e823288..8b6edc958c 100644 --- a/lib/unison-hash/package.yaml +++ b/lib/unison-hash/package.yaml @@ -2,15 +2,13 @@ name: unison-hash github: unisonweb/unison copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors -ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures +ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures dependencies: - base - bytestring - - text - unison-prelude - unison-util-base32hex - - witch library: source-dirs: src diff --git a/lib/unison-hash/unison-hash.cabal b/lib/unison-hash/unison-hash.cabal index afdc6cc89d..cad79645b3 100644 --- a/lib/unison-hash/unison-hash.cabal +++ b/lib/unison-hash/unison-hash.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -49,12 +49,10 @@ library TypeApplications TypeFamilies ViewPatterns - ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures build-depends: base , bytestring - , text , unison-prelude , unison-util-base32hex - , witch default-language: Haskell2010 diff --git a/lib/unison-hashing/package.yaml b/lib/unison-hashing/package.yaml index 7ea56e16d3..6e8e67bb68 100644 --- a/lib/unison-hashing/package.yaml +++ b/lib/unison-hashing/package.yaml @@ -2,7 +2,7 @@ name: unison-hashing github: unisonweb/unison copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors -ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures +ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures dependencies: - base diff --git a/lib/unison-hashing/unison-hashing.cabal b/lib/unison-hashing/unison-hashing.cabal index 21350f79ca..83cd62bcba 100644 --- a/lib/unison-hashing/unison-hashing.cabal +++ b/lib/unison-hashing/unison-hashing.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -48,7 +48,7 @@ library TypeApplications TypeFamilies ViewPatterns - ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures build-depends: base , unison-hash diff --git a/lib/unison-prelude/src/Unison/Debug.hs b/lib/unison-prelude/src/Unison/Debug.hs index 47fdb2ee75..994b29c96f 100644 --- a/lib/unison-prelude/src/Unison/Debug.hs +++ b/lib/unison-prelude/src/Unison/Debug.hs @@ -13,13 +13,12 @@ module Unison.Debug ) where -import Control.Applicative (empty) -import Control.Monad (when) -import Data.Set (Set) import Data.Set qualified as Set import Data.Text qualified as Text -import Debug.Pretty.Simple (pTrace, pTraceM, pTraceShowId, pTraceShowM) +import Debug.Pretty.Simple (pTrace, pTraceM) import System.IO.Unsafe (unsafePerformIO) +import Text.Pretty.Simple (pShow) +import Unison.Prelude import UnliftIO.Environment (lookupEnv) data DebugFlag @@ -37,6 +36,8 @@ data DebugFlag | -- | Useful for adding temporary debugging statements during development. -- Remove uses of Debug.Temp before merging to keep things clean for the next person :) Temp + | -- | Debugging the interpreter + Interpreter | -- | Shows Annotations when printing terms Annotations | -- | Debug endpoints of the local UI (or Share) server @@ -66,6 +67,7 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of "LSP" -> pure LSP "TIMING" -> pure Timing "TEMP" -> pure Temp + "INTERPRETER" -> pure Interpreter "ANNOTATIONS" -> pure Annotations "SERVER" -> pure Server "PATTERN_COVERAGE" -> pure PatternCoverage @@ -115,6 +117,10 @@ debugTemp :: Bool debugTemp = Temp `Set.member` debugFlags {-# NOINLINE debugTemp #-} +debugInterpreter :: Bool +debugInterpreter = Interpreter `Set.member` debugFlags +{-# NOINLINE debugInterpreter #-} + debugAnnotations :: Bool debugAnnotations = Annotations `Set.member` debugFlags {-# NOINLINE debugAnnotations #-} @@ -148,7 +154,7 @@ debugPatternCoverageConstraintSolver = PatternCoverageConstraintSolver `Set.memb debug :: (Show a) => DebugFlag -> String -> a -> a debug flag msg a = if shouldDebug flag - then pTraceShowId (pTrace (msg <> ":\n") a) + then (trace (msg <> ":\n" <> into @String (pShow a)) a) else a -- | Use for selective debug logging in monadic contexts. @@ -159,8 +165,7 @@ debug flag msg a = debugM :: (Show a, Monad m) => DebugFlag -> String -> a -> m () debugM flag msg a = whenDebug flag do - pTraceM (msg <> ":\n") - pTraceShowM a + traceM (msg <> ":\n" <> into @String (pShow a)) debugLog :: DebugFlag -> String -> a -> a debugLog flag msg = @@ -189,6 +194,7 @@ shouldDebug = \case LSP -> debugLSP Timing -> debugTiming Temp -> debugTemp + Interpreter -> debugInterpreter Annotations -> debugAnnotations Server -> debugServer PatternCoverage -> debugPatternCoverage diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index 0ddd4aee64..374f4a1812 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -102,7 +102,7 @@ import Witch as X (From (from), TryFrom (tryFrom), TryFromException (TryFromExce import Witherable as X (filterA, forMaybe, mapMaybe, wither, witherMap) -- | Can be removed when we upgrade transformers to a more recent version. -hoistMaybe :: Applicative m => Maybe a -> MaybeT m a +hoistMaybe :: (Applicative m) => Maybe a -> MaybeT m a hoistMaybe = MaybeT . pure -- | Like 'fold' but for Alternative. diff --git a/lib/unison-prelude/src/Unison/Util/Map.hs b/lib/unison-prelude/src/Unison/Util/Map.hs index be67d730b3..49cf1e7c36 100644 --- a/lib/unison-prelude/src/Unison/Util/Map.hs +++ b/lib/unison-prelude/src/Unison/Util/Map.hs @@ -41,7 +41,7 @@ import Data.Vector qualified as Vector import Unison.Prelude hiding (bimap, foldM, for_) -- | A common case of @Map.merge@. Like @alignWith@, but includes the key. -alignWithKey :: Ord k => (k -> These a b -> c) -> Map k a -> Map k b -> Map k c +alignWithKey :: (Ord k) => (k -> These a b -> c) -> Map k a -> Map k b -> Map k c alignWithKey f = Map.merge (Map.mapMissing \k x -> f k (This x)) @@ -60,7 +60,7 @@ bitraversed keyT valT f m = -- | Traverse a map as a list of key-value pairs. -- Note: This can have unexpected results if the result contains duplicate keys. -asList_ :: Ord k' => Traversal (Map k v) (Map k' v') [(k, v)] [(k', v')] +asList_ :: (Ord k') => Traversal (Map k v) (Map k' v') [(k, v)] [(k', v')] asList_ f s = s & Map.toList @@ -73,13 +73,13 @@ swap = Map.foldlWithKey' (\z a b -> Map.insert b a z) mempty -- | Like 'Map.insert', but returns the old value as well. -insertLookup :: Ord k => k -> v -> Map k v -> (Maybe v, Map k v) +insertLookup :: (Ord k) => k -> v -> Map k v -> (Maybe v, Map k v) insertLookup k v = upsertLookup (const v) k -- | Invert a map's keys and values. This probably only makes sense with injective maps, but otherwise, later key/value -- pairs (ordered by the original map's keys) overwrite earlier ones. -invert :: Ord v => Map k v -> Map v k +invert :: (Ord v) => Map k v -> Map v k invert = Map.foldlWithKey' (\m k v -> Map.insert v k m) Map.empty @@ -94,7 +94,7 @@ upsertF f = Map.alterF (fmap Just . f) -- | Like 'upsert', but returns the old value as well. -upsertLookup :: Ord k => (Maybe v -> v) -> k -> Map k v -> (Maybe v, Map k v) +upsertLookup :: (Ord k) => (Maybe v -> v) -> k -> Map k v -> (Maybe v, Map k v) upsertLookup f = upsertF (\v -> (v, f v)) @@ -113,12 +113,12 @@ deleteLookupJust = Map.alterF (maybe (error (reportBug "E525283" "deleteLookupJust: element not found")) (,Nothing)) -- | Like 'Map.elems', but return the values as a set. -elemsSet :: Ord v => Map k v -> Set v +elemsSet :: (Ord v) => Map k v -> Set v elemsSet = Set.fromList . Map.elems -- | Like 'Map.foldlWithKey'', but with a monadic accumulator. -foldM :: Monad m => (acc -> k -> v -> m acc) -> acc -> Map k v -> m acc +foldM :: (Monad m) => (acc -> k -> v -> m acc) -> acc -> Map k v -> m acc foldM f acc0 = go acc0 where @@ -141,7 +141,7 @@ foldMapM f = pure $! Map.insert k v acc -- | Run a monadic action for each key/value pair in a map. -for_ :: Monad m => Map k v -> (k -> v -> m ()) -> m () +for_ :: (Monad m) => Map k v -> (k -> v -> m ()) -> m () for_ m f = go m where diff --git a/lib/unison-prelude/src/Unison/Util/Set.hs b/lib/unison-prelude/src/Unison/Util/Set.hs index 50d2cff56a..4e3c6ef9b9 100644 --- a/lib/unison-prelude/src/Unison/Util/Set.hs +++ b/lib/unison-prelude/src/Unison/Util/Set.hs @@ -1,6 +1,7 @@ module Unison.Util.Set ( asSingleton, difference1, + intersects, mapMaybe, symmetricDifference, Unison.Util.Set.traverse, @@ -29,6 +30,11 @@ difference1 xs ys = where zs = Set.difference xs ys +-- | Get whether two sets intersect. +intersects :: (Ord a) => Set a -> Set a -> Bool +intersects xs ys = + not (Set.disjoint xs ys) + symmetricDifference :: (Ord a) => Set a -> Set a -> Set a symmetricDifference a b = (a `Set.difference` b) `Set.union` (b `Set.difference` a) diff --git a/lib/unison-prelude/src/Unison/Util/Tuple.hs b/lib/unison-prelude/src/Unison/Util/Tuple.hs index 613af47a36..c317e41ffc 100644 --- a/lib/unison-prelude/src/Unison/Util/Tuple.hs +++ b/lib/unison-prelude/src/Unison/Util/Tuple.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Tuple utils. diff --git a/lib/unison-pretty-printer/package.yaml b/lib/unison-pretty-printer/package.yaml index 0a190a10b2..7fcd9f7855 100644 --- a/lib/unison-pretty-printer/package.yaml +++ b/lib/unison-pretty-printer/package.yaml @@ -25,16 +25,7 @@ default-extensions: - TypeApplications - ViewPatterns -ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures - -flags: - optimized: - manual: true - default: true - -when: - - condition: flag(optimized) - ghc-options: -funbox-strict-fields -O2 +ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures library: when: @@ -51,7 +42,6 @@ library: - ListLike - ansi-terminal - text - - mtl - unliftio - pretty-simple - process @@ -67,7 +57,6 @@ executables: main: Main.hs dependencies: - base - - safe - text - unison-pretty-printer diff --git a/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs b/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs index 47bb6d9ca7..7061ece97f 100644 --- a/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs +++ b/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs @@ -21,13 +21,13 @@ import Unison.Util.Monoid (intercalateMap) import Unison.Util.Range (Range (..), inRange) data Segment a = Segment {segment :: String, annotation :: Maybe a} - deriving (Eq, Show, Functor, Foldable, Generic) + deriving (Eq, Show, Ord, Functor, Foldable, Generic) toPair :: Segment a -> (String, Maybe a) toPair (Segment s a) = (s, a) newtype AnnotatedText a = AnnotatedText (Seq (Segment a)) - deriving (Eq, Functor, Foldable, Show, Generic) + deriving (Eq, Functor, Foldable, Show, Ord, Generic) instance Semigroup (AnnotatedText a) where AnnotatedText (as :|> Segment "" _) <> bs = AnnotatedText as <> bs @@ -204,7 +204,6 @@ snipWithContext margin source = -- if all annotations so far can be joined without .. separations if null rest then -- if this one can be joined to the new region without .. separation - if withinMargin r0 r1 then -- add it to the first set and grow the compare region (Just $ r0 <> r1, Map.insert r1 a1 taken, mempty) diff --git a/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs b/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs index c19c030142..6f04fc1976 100644 --- a/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs +++ b/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs @@ -78,7 +78,7 @@ module Unison.Util.Pretty lineSkip, nonEmpty, numbered, - numberedColumn2, + numberedColumn2ListFrom, numberedColumn2Header, numberedColumnNHeader, numberedList, @@ -544,12 +544,12 @@ numberedHeader num ps = column2 (fmap num (Nothing : fmap Just [1 ..]) `zip` toL -- 1. one thing : this is a thing -- 2. another thing : this is another thing -- 3. and another : yet one more thing -numberedColumn2 :: - (Foldable f, LL.ListLike s Char, IsString s) => - (Int -> Pretty s) -> - f (Pretty s, Pretty s) -> - Pretty s -numberedColumn2 num ps = numbered num (align $ toList ps) +numberedColumn2ListFrom :: + (Foldable f) => + Int -> + f (Pretty ColorText, Pretty ColorText) -> + Pretty ColorText +numberedColumn2ListFrom num ps = numberedListFrom num (align $ toList ps) numberedColumn2Header :: (Foldable f, LL.ListLike s Char, IsString s) => diff --git a/lib/unison-pretty-printer/src/Unison/Util/SyntaxText.hs b/lib/unison-pretty-printer/src/Unison/Util/SyntaxText.hs index 294a27b5bb..ffcac47acf 100644 --- a/lib/unison-pretty-printer/src/Unison/Util/SyntaxText.hs +++ b/lib/unison-pretty-printer/src/Unison/Util/SyntaxText.hs @@ -4,7 +4,7 @@ import Unison.HashQualified (HashQualified) import Unison.Name (Name) import Unison.Pattern (SeqOp) import Unison.Prelude -import Unison.Referent' (Referent') +import Unison.ReferentPrime (Referent') import Unison.Util.AnnotatedText (AnnotatedText (..), annotate, segment) type SyntaxText' r = AnnotatedText (Element r) diff --git a/lib/unison-pretty-printer/unison-pretty-printer.cabal b/lib/unison-pretty-printer/unison-pretty-printer.cabal index edec571f55..6f6792f0e9 100644 --- a/lib/unison-pretty-printer/unison-pretty-printer.cabal +++ b/lib/unison-pretty-printer/unison-pretty-printer.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -17,10 +17,6 @@ source-repository head type: git location: https://github.com/unisonweb/unison -flag optimized - manual: True - default: True - library exposed-modules: Unison.PrettyTerminal @@ -54,14 +50,13 @@ library TupleSections TypeApplications ViewPatterns - ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures build-depends: ListLike , ansi-terminal , base , containers , extra - , mtl , pretty-simple , process , terminal-size @@ -71,8 +66,6 @@ library , unison-syntax , unliftio default-language: Haskell2010 - if flag(optimized) - ghc-options: -funbox-strict-fields -O2 executable prettyprintdemo main-is: Main.hs @@ -100,15 +93,12 @@ executable prettyprintdemo TupleSections TypeApplications ViewPatterns - ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures build-depends: base - , safe , text , unison-pretty-printer default-language: Haskell2010 - if flag(optimized) - ghc-options: -funbox-strict-fields -O2 test-suite pretty-printer-tests type: exitcode-stdio-1.0 @@ -141,7 +131,7 @@ test-suite pretty-printer-tests TupleSections TypeApplications ViewPatterns - ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 build-depends: base , code-page @@ -151,5 +141,3 @@ test-suite pretty-printer-tests , unison-pretty-printer , unison-syntax default-language: Haskell2010 - if flag(optimized) - ghc-options: -funbox-strict-fields -O2 diff --git a/lib/unison-sqlite/package.yaml b/lib/unison-sqlite/package.yaml index 7d58258134..84d0201eab 100644 --- a/lib/unison-sqlite/package.yaml +++ b/lib/unison-sqlite/package.yaml @@ -7,6 +7,22 @@ library: - condition: false other-modules: Paths_unison_sqlite + dependencies: + - base + - direct-sqlite + - megaparsec + - pretty-simple + - random + - recover-rtti + - sqlite-simple + - template-haskell + - text + - text-builder + - transformers + - unison-prelude + - unison-util-cache + - unliftio + source-dirs: src exposed-modules: - Unison.Sqlite @@ -20,34 +36,13 @@ tests: - condition: false other-modules: Paths_unison_sqlite dependencies: + - base - code-page - easytest - unison-sqlite main: Main.hs source-dirs: test -dependencies: - - base - - direct-sqlite - - exceptions - - generic-lens - - lens - - megaparsec - - mtl - - neat-interpolation - - pretty-simple - - random - - recover-rtti - - sqlite-simple - - template-haskell - - text - - text-builder - - transformers - - unison-prelude - - unison-util-cache - - unliftio - - unliftio-core - ghc-options: -Wall diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index f46917ddc8..48167980db 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -151,7 +151,7 @@ logQuery (Sql sql params) result = -- Without results -execute :: Connection -> Sql -> IO () +execute :: (HasCallStack) => Connection -> Sql -> IO () execute conn@(Connection _ _ conn0) sql@(Sql s params) = do logQuery sql Nothing doExecute `catch` \(exception :: Sqlite.SQLError) -> @@ -171,8 +171,8 @@ execute conn@(Connection _ _ conn0) sql@(Sql s params) = do -- | Execute one or more semicolon-delimited statements. -- -- This function does not support parameters, and is mostly useful for executing DDL and migrations. -executeStatements :: Connection -> Text -> IO () -executeStatements conn@(Connection _ _ (Sqlite.Connection database)) sql = do +executeStatements :: (HasCallStack) => Connection -> Text -> IO () +executeStatements conn@(Connection _ _ (Sqlite.Connection database _tempNameCounter)) sql = do logQuery (Sql sql []) Nothing Direct.Sqlite.exec database sql `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException @@ -184,7 +184,7 @@ executeStatements conn@(Connection _ _ (Sqlite.Connection database)) sql = do -- With results, without checks -queryStreamRow :: Sqlite.FromRow a => Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r +queryStreamRow :: (HasCallStack, Sqlite.FromRow a) => Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback = run `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException @@ -201,7 +201,7 @@ queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback = queryStreamCol :: forall a r. - (Sqlite.FromField a) => + (HasCallStack, Sqlite.FromField a) => Connection -> Sql -> (IO (Maybe a) -> IO r) -> @@ -212,7 +212,7 @@ queryStreamCol = @(Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r) queryStreamRow -queryListRow :: forall a. (Sqlite.FromRow a) => Connection -> Sql -> IO [a] +queryListRow :: forall a. (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO [a] queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do result <- doQuery @@ -237,35 +237,35 @@ queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do Just row -> loop (row : rows) loop [] -queryListCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO [a] +queryListCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO [a] queryListCol = coerce @(Connection -> Sql -> IO [Sqlite.Only a]) @(Connection -> Sql -> IO [a]) queryListRow -queryMaybeRow :: (Sqlite.FromRow a) => Connection -> Sql -> IO (Maybe a) +queryMaybeRow :: (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO (Maybe a) queryMaybeRow conn s = queryListRowCheck conn s \case [] -> Right Nothing [x] -> Right (Just x) xs -> Left (ExpectedAtMostOneRowException (anythingToString xs)) -queryMaybeCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO (Maybe a) +queryMaybeCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO (Maybe a) queryMaybeCol conn s = coerce @(IO (Maybe (Sqlite.Only a))) @(IO (Maybe a)) (queryMaybeRow conn s) -queryOneRow :: (Sqlite.FromRow a) => Connection -> Sql -> IO a +queryOneRow :: (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO a queryOneRow conn s = queryListRowCheck conn s \case [x] -> Right x xs -> Left (ExpectedExactlyOneRowException (anythingToString xs)) -queryOneCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO a +queryOneCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO a queryOneCol conn s = do coerce @(IO (Sqlite.Only a)) @(IO a) (queryOneRow conn s) -- With results, with checks queryListRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e) => + (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => Connection -> Sql -> ([a] -> Either e r) -> @@ -274,7 +274,7 @@ queryListRowCheck conn s check = gqueryListCheck conn s (mapLeft SomeSqliteExceptionReason . check) gqueryListCheck :: - (Sqlite.FromRow a) => + (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> ([a] -> Either SomeSqliteExceptionReason r) -> @@ -293,7 +293,7 @@ gqueryListCheck conn sql check = do queryListColCheck :: forall a e r. - (Sqlite.FromField a, SqliteExceptionReason e) => + (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Connection -> Sql -> ([a] -> Either e r) -> @@ -302,7 +302,7 @@ queryListColCheck conn s check = queryListRowCheck conn s (coerce @([a] -> Either e r) @([Sqlite.Only a] -> Either e r) check) queryMaybeRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e) => + (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => Connection -> Sql -> (a -> Either e r) -> @@ -315,7 +315,7 @@ queryMaybeRowCheck conn s check = queryMaybeColCheck :: forall a e r. - (Sqlite.FromField a, SqliteExceptionReason e) => + (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Connection -> Sql -> (a -> Either e r) -> @@ -324,7 +324,7 @@ queryMaybeColCheck conn s check = queryMaybeRowCheck conn s (coerce @(a -> Either e r) @(Sqlite.Only a -> Either e r) check) queryOneRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e) => + (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => Connection -> Sql -> (a -> Either e r) -> @@ -336,7 +336,7 @@ queryOneRowCheck conn s check = queryOneColCheck :: forall a e r. - (Sqlite.FromField a, SqliteExceptionReason e) => + (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Connection -> Sql -> (a -> Either e r) -> diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs b/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs index cf760c4936..e1473edfc2 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs @@ -24,7 +24,8 @@ where import Control.Concurrent (ThreadId, myThreadId) import Data.Typeable (cast) import Database.SQLite.Simple qualified as Sqlite -import GHC.Stack (currentCallStack) +import GHC.Stack (CallStack) +import GHC.Stack qualified as Stack import Unison.Prelude import Unison.Sqlite.Connection.Internal (Connection) import Unison.Sqlite.Sql (Sql (..)) @@ -112,7 +113,7 @@ data SqliteQueryException = SqliteQueryException -- | The inner exception. It is intentionally not 'SomeException', so that calling code cannot accidentally -- 'throwIO' domain-specific exception types, but must instead use a @*Check@ query variant. exception :: SomeSqliteExceptionReason, - callStack :: [String], + callStack :: CallStack, connection :: Connection, threadId :: ThreadId } @@ -137,16 +138,15 @@ data SqliteQueryExceptionInfo = SqliteQueryExceptionInfo exception :: SomeSqliteExceptionReason } -throwSqliteQueryException :: SqliteQueryExceptionInfo -> IO a +throwSqliteQueryException :: (HasCallStack) => SqliteQueryExceptionInfo -> IO a throwSqliteQueryException SqliteQueryExceptionInfo {connection, exception, sql = Sql sql params} = do threadId <- myThreadId - callStack <- currentCallStack throwIO SqliteQueryException { sql, params, exception, - callStack, + callStack = Stack.callStack, connection, threadId } diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Sql.hs b/lib/unison-sqlite/src/Unison/Sqlite/Sql.hs index 97ee636022..475cb0318a 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Sql.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Sql.hs @@ -193,7 +193,7 @@ sqlQQ input = Nothing -> fail ("Not in scope: " ++ Text.unpack var) Just name -> (,) <$> [|valuesSql $(TH.varE name)|] <*> [|foldMap Sqlite.Simple.toRow $(TH.varE name)|] -inSql :: Sqlite.Simple.ToField a => [a] -> Text +inSql :: (Sqlite.Simple.ToField a) => [a] -> Text inSql scalars = Text.Builder.run ("IN (" <> b_commaSep (map (\_ -> b_qmark) scalars) <> b_rparen) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 49a5e01aa8..b44a04b0fa 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -66,11 +66,11 @@ newtype Transaction a -- Omit MonadThrow instance so we always throw SqliteException (via *Check) with lots of context deriving (Applicative, Functor, Monad) via (ReaderT Connection IO) -instance Monoid a => Monoid (Transaction a) where - mempty :: Monoid a => Transaction a +instance (Monoid a) => Monoid (Transaction a) where + mempty :: (Monoid a) => Transaction a mempty = pure mempty -instance Semigroup a => Semigroup (Transaction a) where +instance (Semigroup a) => Semigroup (Transaction a) where (<>) :: Transaction a -> Transaction a -> Transaction a (<>) = liftA2 (<>) @@ -88,7 +88,7 @@ instance MonadIO TransactionWithMonadIO where coerce @(IO a -> Transaction a) unsafeIO -- | Run a transaction on the given connection. -runTransaction :: (MonadIO m) => Connection -> Transaction a -> m a +runTransaction :: (MonadIO m, HasCallStack) => Connection -> Transaction a -> m a runTransaction conn (Transaction f) = liftIO do uninterruptibleMask \restore -> do Connection.begin conn @@ -117,7 +117,7 @@ instance Show RollingBack where -- | Run a transaction on the given connection, providing a function that can short-circuit (and roll back) the -- transaction. runTransactionWithRollback :: - (MonadIO m) => + (MonadIO m, HasCallStack) => Connection -> ((forall void. a -> Transaction void) -> Transaction a) -> m a @@ -137,13 +137,13 @@ runTransactionWithRollback conn transaction = liftIO do -- -- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. If the transaction does -- attempt a write and gets SQLITE_BUSY, it's your fault! -runReadOnlyTransaction :: (MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a +runReadOnlyTransaction :: (MonadUnliftIO m, HasCallStack) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a runReadOnlyTransaction conn f = withRunInIO \runInIO -> runReadOnlyTransaction_ conn (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn)))) {-# SPECIALIZE runReadOnlyTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-} -runReadOnlyTransaction_ :: Connection -> IO a -> IO a +runReadOnlyTransaction_ :: (HasCallStack) => Connection -> IO a -> IO a runReadOnlyTransaction_ conn action = do bracketOnError_ (Connection.begin conn) @@ -160,7 +160,7 @@ runReadOnlyTransaction_ conn action = do -- BEGIN/COMMIT statements. -- -- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. -runWriteTransaction :: (MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a +runWriteTransaction :: (HasCallStack, MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a runWriteTransaction conn f = withRunInIO \runInIO -> uninterruptibleMask \restore -> @@ -170,7 +170,7 @@ runWriteTransaction conn f = (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn)))) {-# SPECIALIZE runWriteTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-} -runWriteTransaction_ :: (forall x. IO x -> IO x) -> Connection -> IO a -> IO a +runWriteTransaction_ :: (HasCallStack) => (forall x. IO x -> IO x) -> Connection -> IO a -> IO a runWriteTransaction_ restore conn transaction = do keepTryingToBeginImmediate restore conn result <- restore transaction `onException` ignoringExceptions (Connection.rollback conn) @@ -178,7 +178,7 @@ runWriteTransaction_ restore conn transaction = do pure result -- @BEGIN IMMEDIATE@ until success. -keepTryingToBeginImmediate :: (forall x. IO x -> IO x) -> Connection -> IO () +keepTryingToBeginImmediate :: (HasCallStack) => (forall x. IO x -> IO x) -> Connection -> IO () keepTryingToBeginImmediate restore conn = let loop = try @_ @SqliteQueryException (Connection.beginImmediate conn) >>= \case @@ -217,7 +217,7 @@ savepoint (Transaction action) = do -- transaction needs to retry. -- -- /Warning/: attempting to run a transaction inside a transaction will cause an exception! -unsafeIO :: IO a -> Transaction a +unsafeIO :: (HasCallStack) => IO a -> Transaction a unsafeIO action = Transaction \_ -> action @@ -232,18 +232,18 @@ unsafeUnTransaction (Transaction action) = -- Without results -execute :: Sql -> Transaction () +execute :: (HasCallStack) => Sql -> Transaction () execute s = Transaction \conn -> Connection.execute conn s -executeStatements :: Text -> Transaction () +executeStatements :: (HasCallStack) => Text -> Transaction () executeStatements s = Transaction \conn -> Connection.executeStatements conn s -- With results, without checks queryStreamRow :: - (Sqlite.FromRow a) => + (Sqlite.FromRow a, HasCallStack) => Sql -> (Transaction (Maybe a) -> Transaction r) -> Transaction r @@ -254,7 +254,7 @@ queryStreamRow sql callback = queryStreamCol :: forall a r. - (Sqlite.FromField a) => + (Sqlite.FromField a, HasCallStack) => Sql -> (Transaction (Maybe a) -> Transaction r) -> Transaction r @@ -264,34 +264,34 @@ queryStreamCol = @(Sql -> (Transaction (Maybe a) -> Transaction r) -> Transaction r) queryStreamRow -queryListRow :: (Sqlite.FromRow a) => Sql -> Transaction [a] +queryListRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction [a] queryListRow s = Transaction \conn -> Connection.queryListRow conn s -queryListCol :: (Sqlite.FromField a) => Sql -> Transaction [a] +queryListCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction [a] queryListCol s = Transaction \conn -> Connection.queryListCol conn s -queryMaybeRow :: (Sqlite.FromRow a) => Sql -> Transaction (Maybe a) +queryMaybeRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction (Maybe a) queryMaybeRow s = Transaction \conn -> Connection.queryMaybeRow conn s -queryMaybeCol :: (Sqlite.FromField a) => Sql -> Transaction (Maybe a) +queryMaybeCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction (Maybe a) queryMaybeCol s = Transaction \conn -> Connection.queryMaybeCol conn s -queryOneRow :: (Sqlite.FromRow a) => Sql -> Transaction a +queryOneRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction a queryOneRow s = Transaction \conn -> Connection.queryOneRow conn s -queryOneCol :: (Sqlite.FromField a) => Sql -> Transaction a +queryOneCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction a queryOneCol s = Transaction \conn -> Connection.queryOneCol conn s -- With results, with parameters, with checks queryListRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e) => + (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => Sql -> ([a] -> Either e r) -> Transaction r @@ -299,7 +299,7 @@ queryListRowCheck sql check = Transaction \conn -> Connection.queryListRowCheck conn sql check queryListColCheck :: - (Sqlite.FromField a, SqliteExceptionReason e) => + (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Sql -> ([a] -> Either e r) -> Transaction r @@ -307,7 +307,7 @@ queryListColCheck sql check = Transaction \conn -> Connection.queryListColCheck conn sql check queryMaybeRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e) => + (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => Sql -> (a -> Either e r) -> Transaction (Maybe r) @@ -315,7 +315,7 @@ queryMaybeRowCheck s check = Transaction \conn -> Connection.queryMaybeRowCheck conn s check queryMaybeColCheck :: - (Sqlite.FromField a, SqliteExceptionReason e) => + (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Sql -> (a -> Either e r) -> Transaction (Maybe r) @@ -323,7 +323,7 @@ queryMaybeColCheck s check = Transaction \conn -> Connection.queryMaybeColCheck conn s check queryOneRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e) => + (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => Sql -> (a -> Either e r) -> Transaction r @@ -331,7 +331,7 @@ queryOneRowCheck s check = Transaction \conn -> Connection.queryOneRowCheck conn s check queryOneColCheck :: - (Sqlite.FromField a, SqliteExceptionReason e) => + (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Sql -> (a -> Either e r) -> Transaction r diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 5a5561c5ef..28ea0f7c4f 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -65,12 +65,7 @@ library build-depends: base , direct-sqlite - , exceptions - , generic-lens - , lens , megaparsec - , mtl - , neat-interpolation , pretty-simple , random , recover-rtti @@ -82,7 +77,6 @@ library , unison-prelude , unison-util-cache , unliftio - , unliftio-core default-language: Haskell2010 test-suite tests @@ -126,25 +120,6 @@ test-suite tests build-depends: base , code-page - , direct-sqlite , easytest - , exceptions - , generic-lens - , lens - , megaparsec - , mtl - , neat-interpolation - , pretty-simple - , random - , recover-rtti - , sqlite-simple - , template-haskell - , text - , text-builder - , transformers - , unison-prelude , unison-sqlite - , unison-util-cache - , unliftio - , unliftio-core default-language: Haskell2010 diff --git a/lib/unison-util-base32hex/package.yaml b/lib/unison-util-base32hex/package.yaml index e179c0e37e..9ba9f24635 100644 --- a/lib/unison-util-base32hex/package.yaml +++ b/lib/unison-util-base32hex/package.yaml @@ -11,7 +11,6 @@ library: dependencies: - base - base32 - - bytestring - containers - unison-prelude - text diff --git a/lib/unison-util-base32hex/unison-util-base32hex.cabal b/lib/unison-util-base32hex/unison-util-base32hex.cabal index be0142debf..5d82fa8214 100644 --- a/lib/unison-util-base32hex/unison-util-base32hex.cabal +++ b/lib/unison-util-base32hex/unison-util-base32hex.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -48,7 +48,6 @@ library build-depends: base , base32 - , bytestring , containers , text , unison-prelude diff --git a/lib/unison-util-bytes/package.yaml b/lib/unison-util-bytes/package.yaml index 1836e6ce6b..50a5cca499 100644 --- a/lib/unison-util-bytes/package.yaml +++ b/lib/unison-util-bytes/package.yaml @@ -4,35 +4,38 @@ copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors ghc-options: -Wall -dependencies: - - base - - basement - - bytestring - - bytestring-to-vector - - deepseq - - memory - - primitive - - stringsearch - - text - - vector - - unison-prelude - - unison-util-rope - - zlib - library: source-dirs: src when: - condition: false other-modules: Paths_unison_util_bytes + dependencies: + - base + - basement + - bytestring + - bytestring-to-vector + - deepseq + - memory + - primitive + - stringsearch + - text + - vector + - unison-prelude + - unison-util-rope + - zlib + tests: util-bytes-tests: when: - condition: false other-modules: Paths_unison_util_bytes dependencies: + - base + - bytestring - code-page - easytest + - unison-prelude - unison-util-bytes main: Main.hs source-dirs: test diff --git a/lib/unison-util-bytes/test/Main.hs b/lib/unison-util-bytes/test/Main.hs index 6118703e43..98906571a4 100644 --- a/lib/unison-util-bytes/test/Main.hs +++ b/lib/unison-util-bytes/test/Main.hs @@ -42,10 +42,8 @@ test = scope "<>" . expect' $ Bytes.toArray (b1s <> b2s <> b3s) == b1 <> b2 <> b3 scope "Ord" . expect' $ - (b1 <> b2 <> b3) - `compare` b3 - == (b1s <> b2s <> b3s) - `compare` b3s + (b1 <> b2 <> b3) `compare` b3 + == (b1s <> b2s <> b3s) `compare` b3s scope "take" . expect' $ Bytes.toArray (Bytes.take k (b1s <> b2s)) == BS.take k (b1 <> b2) scope "drop" . expect' $ diff --git a/lib/unison-util-bytes/unison-util-bytes.cabal b/lib/unison-util-bytes/unison-util-bytes.cabal index 83df1a63e4..c8c6e38bf1 100644 --- a/lib/unison-util-bytes/unison-util-bytes.cabal +++ b/lib/unison-util-bytes/unison-util-bytes.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -105,19 +105,9 @@ test-suite util-bytes-tests ghc-options: -Wall build-depends: base - , basement , bytestring - , bytestring-to-vector , code-page - , deepseq , easytest - , memory - , primitive - , stringsearch - , text , unison-prelude , unison-util-bytes - , unison-util-rope - , vector - , zlib default-language: Haskell2010 diff --git a/lib/unison-util-cache/package.yaml b/lib/unison-util-cache/package.yaml index 0c8b57edf9..2cfd921a7a 100644 --- a/lib/unison-util-cache/package.yaml +++ b/lib/unison-util-cache/package.yaml @@ -6,8 +6,6 @@ ghc-options: -Wall dependencies: - base - - containers - - unliftio library: source-dirs: src @@ -15,6 +13,10 @@ library: - condition: false other-modules: Paths_unison_util_cache + dependencies: + - containers + - unliftio + tests: util-cache-tests: when: diff --git a/lib/unison-util-cache/unison-util-cache.cabal b/lib/unison-util-cache/unison-util-cache.cabal index fba24fbe7d..1baadefeab 100644 --- a/lib/unison-util-cache/unison-util-cache.cabal +++ b/lib/unison-util-cache/unison-util-cache.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -97,9 +97,7 @@ test-suite util-cache-tests async , base , code-page - , containers , easytest , stm , unison-util-cache - , unliftio default-language: Haskell2010 diff --git a/lib/unison-util-nametree/package.yaml b/lib/unison-util-nametree/package.yaml deleted file mode 100644 index fdac7c5760..0000000000 --- a/lib/unison-util-nametree/package.yaml +++ /dev/null @@ -1,56 +0,0 @@ -name: unison-util-nametree -github: unisonweb/unison -copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors - -ghc-options: -Wall - -dependencies: - - base - - containers - - lens - - semialign - - semigroups - - these - - unison-core - - unison-core1 - - unison-prelude - - unison-util-relation - -library: - source-dirs: src - when: - - condition: false - other-modules: Paths_unison_util_nametree - -default-extensions: - - BangPatterns - - BlockArguments - - DeriveAnyClass - - DeriveFoldable - - DeriveFunctor - - DeriveGeneric - - DeriveTraversable - - DerivingStrategies - - DerivingVia - - DoAndIfThenElse - - DuplicateRecordFields - - FlexibleContexts - - FlexibleInstances - - GADTs - - GeneralizedNewtypeDeriving - - ImportQualifiedPost - - InstanceSigs - - LambdaCase - - MultiParamTypeClasses - - MultiWayIf - - NamedFieldPuns - - NumericUnderscores - - OverloadedLabels - - OverloadedRecordDot - - OverloadedStrings - - PatternSynonyms - - RankNTypes - - ScopedTypeVariables - - TupleSections - - TypeApplications - - ViewPatterns diff --git a/lib/unison-util-nametree/unison-util-nametree.cabal b/lib/unison-util-nametree/unison-util-nametree.cabal deleted file mode 100644 index 80d3157ee3..0000000000 --- a/lib/unison-util-nametree/unison-util-nametree.cabal +++ /dev/null @@ -1,68 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.36.0. --- --- see: https://github.com/sol/hpack - -name: unison-util-nametree -version: 0.0.0 -homepage: https://github.com/unisonweb/unison#readme -bug-reports: https://github.com/unisonweb/unison/issues -copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors -build-type: Simple - -source-repository head - type: git - location: https://github.com/unisonweb/unison - -library - exposed-modules: - Unison.Util.Defns - Unison.Util.Nametree - hs-source-dirs: - src - default-extensions: - BangPatterns - BlockArguments - DeriveAnyClass - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DerivingVia - DoAndIfThenElse - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - InstanceSigs - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NumericUnderscores - OverloadedLabels - OverloadedRecordDot - OverloadedStrings - PatternSynonyms - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - ViewPatterns - ghc-options: -Wall - build-depends: - base - , containers - , lens - , semialign - , semigroups - , these - , unison-core - , unison-core1 - , unison-prelude - , unison-util-relation - default-language: Haskell2010 diff --git a/lib/unison-util-recursion/package.yaml b/lib/unison-util-recursion/package.yaml new file mode 100644 index 0000000000..21f83722ea --- /dev/null +++ b/lib/unison-util-recursion/package.yaml @@ -0,0 +1,46 @@ +name: unison-util-recursion +github: unisonweb/unison +copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors + +ghc-options: -Wall + +dependencies: + - base + - free + +library: + source-dirs: src + when: + - condition: false + other-modules: Paths_unison_util_recursion + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveAnyClass + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - DuplicateRecordFields + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GeneralizedNewtypeDeriving + - ImportQualifiedPost + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeApplications + - TypeFamilies + - ViewPatterns diff --git a/lib/unison-util-recursion/src/Unison/Util/Recursion.hs b/lib/unison-util-recursion/src/Unison/Util/Recursion.hs new file mode 100644 index 0000000000..e97ebae4db --- /dev/null +++ b/lib/unison-util-recursion/src/Unison/Util/Recursion.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UndecidableInstances #-} + +module Unison.Util.Recursion + ( Algebra, + Recursive (..), + cataM, + para, + Fix (..), + ) +where + +import Control.Arrow ((&&&)) +import Control.Comonad.Cofree (Cofree ((:<))) +import Control.Comonad.Trans.Cofree (CofreeF) +import Control.Comonad.Trans.Cofree qualified as CofreeF +import Control.Monad ((<=<)) + +type Algebra f a = f a -> a + +class Recursive t f | t -> f where + cata :: (Algebra f a) -> t -> a + default cata :: (Functor f) => (f a -> a) -> t -> a + cata φ = φ . fmap (cata φ) . project + project :: t -> f t + default project :: (Functor f) => t -> f t + project = cata (fmap embed) + embed :: f t -> t + {-# MINIMAL embed, (cata | project) #-} + +cataM :: (Recursive t f, Traversable f, Monad m) => (f a -> m a) -> t -> m a +cataM φ = cata $ φ <=< sequenceA + +para :: (Recursive t f, Functor f) => (f (t, a) -> a) -> t -> a +para φ = snd . cata (embed . fmap fst &&& φ) + +newtype Fix f = Fix (f (Fix f)) + +deriving instance (forall a. (Show a) => Show (f a)) => Show (Fix f) + +deriving instance (forall a. (Eq a) => Eq (f a)) => Eq (Fix f) + +deriving instance (Eq (Fix f), forall a. (Ord a) => Ord (f a)) => Ord (Fix f) + +instance (Functor f) => Recursive (Fix f) f where + embed = Fix + project (Fix f) = f + +-- | +-- +-- __NB__: `Cofree` from “free” is lazy, so this instance is technically partial. +instance (Functor f) => Recursive (Cofree f a) (CofreeF f a) where + embed (a CofreeF.:< fco) = a :< fco + project (a :< fco) = a CofreeF.:< fco diff --git a/lib/unison-util-recursion/unison-util-recursion.cabal b/lib/unison-util-recursion/unison-util-recursion.cabal new file mode 100644 index 0000000000..035b9f81d4 --- /dev/null +++ b/lib/unison-util-recursion/unison-util-recursion.cabal @@ -0,0 +1,57 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: unison-util-recursion +version: 0.0.0 +homepage: https://github.com/unisonweb/unison#readme +bug-reports: https://github.com/unisonweb/unison/issues +copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors +build-type: Simple + +source-repository head + type: git + location: https://github.com/unisonweb/unison + +library + exposed-modules: + Unison.Util.Recursion + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + ViewPatterns + ghc-options: -Wall + build-depends: + base + , free + default-language: Haskell2010 diff --git a/lib/unison-util-relation/package.yaml b/lib/unison-util-relation/package.yaml index 223acb5279..03bea64db6 100644 --- a/lib/unison-util-relation/package.yaml +++ b/lib/unison-util-relation/package.yaml @@ -8,12 +8,21 @@ library: - condition: false other-modules: Paths_unison_util_relation + dependencies: + - base + - containers + - deepseq + - extra + - nonempty-containers + - unison-prelude + tests: util-relation-tests: when: - condition: false other-modules: Paths_unison_util_relation dependencies: + - base - code-page - easytest - random @@ -35,14 +44,7 @@ benchmarks: - random - tasty-bench - unison-util-relation - -dependencies: - - base - - containers - - deepseq - - extra - - nonempty-containers - - unison-prelude + - unison-prelude ghc-options: -Wall diff --git a/lib/unison-util-relation/src/Unison/Util/BiMultimap.hs b/lib/unison-util-relation/src/Unison/Util/BiMultimap.hs index 9167d6e6bb..ee060e3ef7 100644 --- a/lib/unison-util-relation/src/Unison/Util/BiMultimap.hs +++ b/lib/unison-util-relation/src/Unison/Util/BiMultimap.hs @@ -3,6 +3,9 @@ module Unison.Util.BiMultimap ( BiMultimap, Unison.Util.BiMultimap.empty, + -- ** Basic queries + isEmpty, + -- ** Lookup memberDom, lookupDom, @@ -32,6 +35,9 @@ module Unison.Util.BiMultimap dom, ran, + -- ** Relations + toRelation, + -- ** Insert insert, unsafeInsert, @@ -47,6 +53,8 @@ import Data.Set.NonEmpty (NESet) import Data.Set.NonEmpty qualified as Set.NonEmpty import Unison.Prelude import Unison.Util.Map qualified as Map +import Unison.Util.Relation (Relation) +import Unison.Util.Relation qualified as Relation import Prelude hiding (filter) -- | A left-unique relation. @@ -62,32 +70,37 @@ data BiMultimap a b = BiMultimap empty :: (Ord a, Ord b) => BiMultimap a b empty = BiMultimap mempty mempty -memberDom :: Ord a => a -> BiMultimap a b -> Bool +-- | Is a left-unique relation empty? +isEmpty :: BiMultimap a b -> Bool +isEmpty = + Map.null . domain + +memberDom :: (Ord a) => a -> BiMultimap a b -> Bool memberDom x = Map.member x . domain -- | Look up the set of @b@ related to an @a@. -- -- /O(log a)/. -lookupDom :: Ord a => a -> BiMultimap a b -> Set b +lookupDom :: (Ord a) => a -> BiMultimap a b -> Set b lookupDom a = lookupDom_ a . domain -lookupDom_ :: Ord a => a -> Map a (NESet b) -> Set b +lookupDom_ :: (Ord a) => a -> Map a (NESet b) -> Set b lookupDom_ x xs = maybe Set.empty Set.NonEmpty.toSet (Map.lookup x xs) -- | Look up the @a@ related to a @b@. -- -- /O(log b)/. -lookupRan :: Ord b => b -> BiMultimap a b -> Maybe a +lookupRan :: (Ord b) => b -> BiMultimap a b -> Maybe a lookupRan b (BiMultimap _ r) = Map.lookup b r -- | Look up the @a@ related to a @b@. -- -- /O(log b)/. -unsafeLookupRan :: Ord b => b -> BiMultimap a b -> a +unsafeLookupRan :: (Ord b) => b -> BiMultimap a b -> a unsafeLookupRan b (BiMultimap _ r) = r Map.! b @@ -157,16 +170,17 @@ withoutRan ys m = domain :: BiMultimap a b -> Map a (NESet b) domain = toMultimap +-- | /O(1)/. range :: BiMultimap a b -> Map b a range = toMapR -- | Construct a left-unique relation from a mapping from its left-elements to set-of-right-elements. The caller is -- responsible for ensuring that no right-element is mapped to by two different left-elements. -unsafeFromDomain :: Ord b => Map a (NESet b) -> BiMultimap a b +unsafeFromDomain :: (Ord b) => Map a (NESet b) -> BiMultimap a b unsafeFromDomain domain = BiMultimap domain (invertDomain domain) -invertDomain :: forall a b. Ord b => Map a (NESet b) -> Map b a +invertDomain :: forall a b. (Ord b) => Map a (NESet b) -> Map b a invertDomain = Map.foldlWithKey' f Map.empty where @@ -178,6 +192,7 @@ invertDomain = g x acc y = Map.insert y x acc +-- | Construct a left-unique relation from a mapping from its right-elements to its left-elements. fromRange :: (Ord a, Ord b) => Map b a -> BiMultimap a b fromRange m = BiMultimap (Map.foldlWithKey' f Map.empty m) m @@ -199,6 +214,11 @@ ran :: BiMultimap a b -> Set b ran = Map.keysSet . toMapR +-- | Convert a left-unique relation to a relation (forgetting its left-uniqueness). +toRelation :: (Ord a, Ord b) => BiMultimap a b -> Relation a b +toRelation = + Relation.fromMultimap . Map.map Set.NonEmpty.toSet . domain + -- | Insert a pair into a left-unique relation, maintaining left-uniqueness, preferring the latest inserted element. -- -- That is, if a left-unique relation already contains the pair @(x, y)@, then inserting the pair @(z, y)@ will cause @@ -215,7 +235,7 @@ insert a b m@(BiMultimap l r) = l' = Map.upsert (maybe (Set.NonEmpty.singleton b) (Set.NonEmpty.insert b)) a l -- @upsertFunc x@ returns a function that upserts @x@, suitable for passing to @Map.alterF@. -upsertFunc :: Eq a => a -> Maybe a -> (UpsertResult a, Maybe a) +upsertFunc :: (Eq a) => a -> Maybe a -> (UpsertResult a, Maybe a) upsertFunc new existing = case existing of Nothing -> (Inserted, Just new) @@ -247,7 +267,7 @@ unsafeUnion xs ys = ------------------------------------------------------------------------------------------------------------------------ -- @deriveRangeFromDomain x ys range@ is a helper that inserts @(x, y1)@, @(x, y2)@, ... into range @r@. -deriveRangeFromDomain :: Ord b => a -> NESet b -> Map b a -> Map b a +deriveRangeFromDomain :: (Ord b) => a -> NESet b -> Map b a -> Map b a deriveRangeFromDomain x ys acc = foldr (flip Map.insert x) acc ys {-# INLINE deriveRangeFromDomain #-} diff --git a/lib/unison-util-relation/src/Unison/Util/Relation.hs b/lib/unison-util-relation/src/Unison/Util/Relation.hs index 060f990ad9..8e2fd5f5eb 100644 --- a/lib/unison-util-relation/src/Unison/Util/Relation.hs +++ b/lib/unison-util-relation/src/Unison/Util/Relation.hs @@ -88,6 +88,8 @@ module Unison.Util.Relation outerJoinRanMultimaps, union, unions, + unionDomainWith, + unionRangeWith, -- * Converting to other data structures toList, @@ -230,6 +232,14 @@ union r s = range = M.unionWith S.union (range r) (range s) } +unionDomainWith :: (Ord a, Ord b) => (a -> Set b -> Set b -> Set b) -> Relation a b -> Relation a b -> Relation a b +unionDomainWith f xs ys = + fromMultimap (Map.unionWithKey f (domain xs) (domain ys)) + +unionRangeWith :: (Ord a, Ord b) => (b -> Set a -> Set a -> Set a) -> Relation a b -> Relation a b -> Relation a b +unionRangeWith f xs ys = + swap (fromMultimap (Map.unionWithKey f (range xs) (range ys))) + intersection :: (Ord a, Ord b) => Relation a b -> Relation a b -> Relation a b intersection r s = Relation diff --git a/lib/unison-util-relation/unison-util-relation.cabal b/lib/unison-util-relation/unison-util-relation.cabal index e8d38d8b57..dc30238fa6 100644 --- a/lib/unison-util-relation/unison-util-relation.cabal +++ b/lib/unison-util-relation/unison-util-relation.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -74,13 +74,8 @@ test-suite util-relation-tests build-depends: base , code-page - , containers - , deepseq , easytest - , extra - , nonempty-containers , random - , unison-prelude , unison-util-relation default-language: Haskell2010 @@ -110,9 +105,6 @@ benchmark relation base , code-page , containers - , deepseq - , extra - , nonempty-containers , random , tasty-bench , unison-prelude diff --git a/nix/dependencies.nix b/nix/dependencies.nix new file mode 100644 index 0000000000..7df873660f --- /dev/null +++ b/nix/dependencies.nix @@ -0,0 +1,21 @@ +{nixpkgs-release}: final: prev: let + pinned-pkgs = import nixpkgs-release {inherit (final) system;}; +in { + stack = pinned-pkgs.stack; + + ## See https://docs.haskellstack.org/en/stable/nix_integration/#supporting-both-nix-and-non-nix-developers for an + ## explanation of this package. + stack-wrapped = final.symlinkJoin { + name = "stack"; # will be available as the usual `stack` in terminal + paths = [final.stack]; + buildInputs = [final.makeWrapper]; + postBuild = '' + wrapProgram $out/bin/stack \ + --add-flags "\ + --no-nix \ + --system-ghc \ + --no-install-ghc \ + " + ''; + }; +} diff --git a/nix/haskell-nix-flake.nix b/nix/haskell-nix-flake.nix index c0c992ae01..f63ffee53f 100644 --- a/nix/haskell-nix-flake.nix +++ b/nix/haskell-nix-flake.nix @@ -1,10 +1,10 @@ { - stack, - hpack, + lib, pkgs, + unison-project, versions, }: let - haskell-nix-flake = pkgs.unison-project.flake {}; + haskell-nix-flake = unison-project.flake {}; commonShellArgs = args: args // { @@ -12,13 +12,31 @@ # https://github.com/input-output-hk/haskell.nix/issues/1793 # https://github.com/input-output-hk/haskell.nix/issues/1885 allToolDeps = false; - additional = hpkgs: with hpkgs; [Cabal stm exceptions ghc ghc-heap]; - buildInputs = let - native-packages = - pkgs.lib.optionals pkgs.stdenv.isDarwin - (with pkgs.darwin.apple_sdk.frameworks; [Cocoa]); - in - (args.buildInputs or []) ++ [stack hpack pkgs.pkg-config pkgs.zlib pkgs.glibcLocales] ++ native-packages; + + additional = hpkgs: + (args.additional or (_: [])) hpkgs + ++ [ + hpkgs.Cabal + hpkgs.exceptions + hpkgs.ghc + hpkgs.ghc-heap + hpkgs.stm + ]; + buildInputs = + (args.buildInputs or []) + ++ [ + pkgs.glibcLocales + pkgs.zlib + ]; + nativeBuildInputs = + (args.nativeBuildInputs or []) + ++ [ + pkgs.cachix + pkgs.gettext # for envsubst, used by unison-src/builtin-tests/interpreter-tests.sh + pkgs.hpack + pkgs.pkg-config + pkgs.stack-wrapped + ]; # workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/11042 shellHook = '' export LD_LIBRARY_PATH=${pkgs.zlib}/lib:$LD_LIBRARY_PATH @@ -26,7 +44,7 @@ tools = (args.tools or {}) // { - cabal = {}; + cabal = {version = versions.cabal;}; ormolu = {version = versions.ormolu;}; haskell-language-server = { version = versions.hls; @@ -49,49 +67,42 @@ }; }; - shellFor = args: pkgs.unison-project.shellFor (commonShellArgs args); - - localPackages = with pkgs.lib; filterAttrs (k: v: v.isLocal or false) pkgs.unison-project.hsPkgs; - localPackageNames = builtins.attrNames localPackages; - devShells = let - mkDevShell = pkgName: - shellFor { - packages = hpkgs: [hpkgs."${pkgName}"]; - withHoogle = true; - }; - localPackageDevShells = - pkgs.lib.genAttrs localPackageNames mkDevShell; - in - { - only-tools = shellFor { - packages = _: []; - withHoogle = false; - }; - local = shellFor { - packages = hpkgs: (map (p: hpkgs."${p}") localPackageNames); - withHoogle = false; - }; - } - // localPackageDevShells; + shellFor = args: unison-project.shellFor (commonShellArgs args); - checks = - haskell-nix-flake.checks - // { - ## This check has a test that tries to write to $HOME, so we give it a fake one. - "unison-cli:test:cli-tests" = haskell-nix-flake.checks."unison-cli:test:cli-tests".overrideAttrs (old: { - ## The builder here doesn’t `runHook preBuild`, so we just prepend onto `buildPhase`. - buildPhase = - '' - export HOME="$TMP/fake-home" - mkdir -p "$HOME" - '' - + old.buildPhase or ""; - }); - }; + localPackages = lib.filterAttrs (k: v: v.isLocal or false) unison-project.hsPkgs; in haskell-nix-flake // { + checks = + haskell-nix-flake.checks + // { + ## This check has a test that tries to write to $HOME, so we give it a fake one. + "unison-cli:test:cli-tests" = haskell-nix-flake.checks."unison-cli:test:cli-tests".overrideAttrs (old: { + ## The builder here doesn’t `runHook preBuild`, so we just prepend onto `buildPhase`. + buildPhase = + '' + export HOME="$TMP/fake-home" + mkdir -p "$HOME" + '' + + old.buildPhase or ""; + }); + }; + defaultPackage = haskell-nix-flake.packages."unison-cli-main:exe:unison"; - inherit (pkgs) unison-project; - inherit checks devShells localPackageNames; + + devShells = let + mkDevShell = pkg: + shellFor { + packages = _hpkgs: [pkg]; + ## Enabling Hoogle causes us to rebuild GHC. + withHoogle = false; + }; + in + { + local = shellFor { + packages = _hpkgs: builtins.attrValues localPackages; + withHoogle = false; + }; + } + // pkgs.lib.mapAttrs (_name: mkDevShell) localPackages; } diff --git a/nix/haskell-nix-overlay.nix b/nix/haskell-nix-overlay.nix deleted file mode 100644 index b98ee874f2..0000000000 --- a/nix/haskell-nix-overlay.nix +++ /dev/null @@ -1,41 +0,0 @@ -final: prev: { - unison-project = with prev.lib.strings; let - cleanSource = pth: let - src' = prev.lib.cleanSourceWith { - filter = filt; - src = pth; - }; - filt = path: type: let - bn = baseNameOf path; - isHiddenFile = hasPrefix "." bn; - isFlakeLock = bn == "flake.lock"; - isNix = hasSuffix ".nix" bn; - in - !isHiddenFile && !isFlakeLock && !isNix; - in - src'; - in - final.haskell-nix.project' { - src = cleanSource ./..; - projectFileName = "stack.yaml"; - modules = [ - # enable profiling - { - enableLibraryProfiling = true; - profilingDetail = "none"; - } - # remove buggy build tool dependencies - ({lib, ...}: { - # this component has the build tool - # `unison-cli:unison` and somehow haskell.nix - # decides to add some file sharing package - # `unison` as a build-tool dependency. - packages.unison-cli.components.exes.cli-integration-tests.build-tools = lib.mkForce []; - }) - ]; - branchMap = { - "https://github.com/unisonweb/configurator.git"."e47e9e9fe1f576f8c835183b9def52d73c01327a" = "unison"; - "https://github.com/unisonweb/shellmet.git"."2fd348592c8f51bb4c0ca6ba4bc8e38668913746" = "topic/avoid-callCommand"; - }; - }; -} diff --git a/nix/nixpkgs-overlay.nix b/nix/nixpkgs-overlay.nix deleted file mode 100644 index 033ee5e881..0000000000 --- a/nix/nixpkgs-overlay.nix +++ /dev/null @@ -1,49 +0,0 @@ -{versions}: final: prev: { - unison-hls = final.haskell-language-server.override { - # build with our overridden haskellPackages that have our pinned - # version of ormolu and hls - haskellPackages = final.haskell.packages."ghc${versions.ghc}"; - dynamic = true; - supportedGhcVersions = [versions.ghc]; - }; - haskell = - prev.haskell - // { - packages = - prev.haskell.packages - // { - ghcunison = prev.haskell.packages."ghc${versions.ghc}".extend (hfinal: hprev: let - inherit (prev.haskell.lib) overrideCabal; - in { - # dependency overrides for ormolu 0.5.2.0 - haskell-language-server = let - p = - hfinal.callHackageDirect - { - pkg = "haskell-language-server"; - ver = versions.hls; - sha256 = "0kp586yc162raljyd5arsxm5ndcx5zfw9v94v27bkjg7x0hp1s8b"; - } - { - hls-fourmolu-plugin = null; - hls-stylish-haskell-plugin = null; - hls-hlint-plugin = null; - hls-floskell-plugin = null; - }; - override = drv: { - doCheck = false; - configureFlags = - (drv.configureFlags or []) - ++ [ - "-f-fourmolu" - "-f-stylishhaskell" - "-f-hlint" - "-f-floskell" - ]; - }; - in - overrideCabal p override; - }); - }; - }; -} diff --git a/nix/unison-overlay.nix b/nix/unison-overlay.nix deleted file mode 100644 index 5f7f1a336d..0000000000 --- a/nix/unison-overlay.nix +++ /dev/null @@ -1,15 +0,0 @@ -final: prev: { - # a wrapped version of stack that passes the necessary flags to use - # the nix provided ghc. - unison-stack = prev.symlinkJoin { - name = "stack"; - paths = [final.stack]; - buildInputs = [final.makeWrapper]; - postBuild = let - flags = ["--no-nix" "--system-ghc" "--no-install-ghc"]; - add-flags = "--add-flags '${prev.lib.concatStringsSep " " flags}'"; - in '' - wrapProgram "$out/bin/stack" ${add-flags} - ''; - }; -} diff --git a/nix/unison-project.nix b/nix/unison-project.nix new file mode 100644 index 0000000000..3ca79d706b --- /dev/null +++ b/nix/unison-project.nix @@ -0,0 +1,30 @@ +{ + haskell-nix, + lib, +}: let + cleanSource = src: + lib.cleanSourceWith { + inherit src; + filter = path: type: let + bn = baseNameOf path; + isHiddenFile = lib.hasPrefix "." bn; + isFlakeLock = bn == "flake.lock"; + isNix = lib.hasSuffix ".nix" bn; + in + !isHiddenFile && !isFlakeLock && !isNix; + }; +in + haskell-nix.project' { + src = cleanSource ./..; + projectFileName = "stack.yaml"; + modules = [ + # enable profiling + { + enableLibraryProfiling = true; + profilingDetail = "none"; + } + ]; + branchMap = { + "https://github.com/unisonweb/shellmet.git"."2fd348592c8f51bb4c0ca6ba4bc8e38668913746" = "topic/avoid-callCommand"; + }; + } diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000000..8b89522fdf --- /dev/null +++ b/package.yaml @@ -0,0 +1,77 @@ +name: unison-syntax +github: unisonweb/unison +copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors + +ghc-options: -Wall + +library: + source-dirs: src + when: + - condition: false + other-modules: Paths_unison_syntax + + dependencies: + - base + - bytes + - containers + - cryptonite + - deriving-compat + - extra + - free + - lens + - megaparsec + - mtl + - parser-combinators + - text + - unison-core + - unison-core1 + - unison-hash + - unison-prelude + - unison-util-base32hex + - unison-util-bytes + +tests: + syntax-tests: + when: + - condition: false + other-modules: Paths_unison_syntax + dependencies: + - base + - code-page + - easytest + - unison-syntax + - unison-core + - unison-prelude + main: Main.hs + source-dirs: test + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveAnyClass + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - DuplicateRecordFields + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GeneralizedNewtypeDeriving + - ImportQualifiedPost + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeApplications + - TypeFamilies + - ViewPatterns diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 8bb50c5183..a6757ae515 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -2,149 +2,7 @@ name: unison-parser-typechecker github: unisonweb/unison copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors -ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures - -flags: - optimized: - manual: true - default: true - arraychecks: - manual: true - default: false - -when: - - condition: flag(optimized) - ghc-options: -funbox-strict-fields -O2 - - condition: flag(arraychecks) - cpp-options: -DARRAY_CHECK - -dependencies: - - ListLike - - NanoID - - aeson - - ansi-terminal - - asn1-encoding - - asn1-types - - async - - atomic-primops - - base - - base16 >= 0.2.1.0 - - base64-bytestring - - basement - - binary - - bytes - - bytestring - - bytestring-to-vector - - cereal - - clock - - concurrent-output - - configurator - - containers >= 0.6.3 - - cryptonite - - data-default - - data-memocombinators - - deepseq - - directory - - either - - errors - - exceptions - - extra - - filelock - - filepath - - fingertree - - fuzzyfind - - free - - generic-lens - - hashable - - hashtables - - haskeline - - http-client - - http-media - - http-types - - IntervalMap - - iproute - - lens - - lucid - - megaparsec - - memory - - mmorph - - monad-validate - - mtl - - mutable-containers - - murmur-hash - - mwc-random - - natural-transformation - - network - - network-simple - - network-udp - - network-uri - - nonempty-containers - - open-browser - - openapi3 - - optparse-applicative >= 0.16.1.0 - - pem - - pretty-simple - - primitive - - process - - random >= 1.2.0 - - raw-strings-qq - - recover-rtti - - regex-base - - regex-tdfa - - safe - - safe-exceptions - - semialign - - semigroups - - servant - - servant-client - - servant-docs - - servant-openapi3 - - servant-server - - shellmet - - stm - - tagged - - temporary - - terminal-size >= 0.3.3 - - text - - text-short - - these - - time - - tls - - transformers - - unicode-show - - unison-codebase - - unison-codebase-sqlite - - unison-codebase-sqlite-hashing-v2 - - unison-codebase-sync - - unison-core - - unison-core1 - - unison-hash - - unison-hashing-v2 - - unison-prelude - - unison-pretty-printer - - unison-sqlite - - unison-syntax - - unison-util-base32hex - - unison-util-bytes - - unison-util-cache - - unison-util-nametree - - unison-util-relation - - unison-util-rope - - unison-util-serialization - - unliftio - - uuid - - uri-encode - - utf8-string - - vector - - wai - - warp - - witch - - witherable - - x509 - - x509-store - - x509-system - - yaml - - zlib +ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures library: source-dirs: src @@ -152,18 +10,91 @@ library: - condition: false other-modules: Paths_unison_parser_typechecker + dependencies: + - ListLike + - aeson + - async + - atomic-primops + - base + - bytes + - bytestring + - concurrent-output + - containers >= 0.6.3 + - errors + - extra + - filelock + - filepath + - free + - generic-lens + - hashable + - hashtables + - lens + - megaparsec + - mmorph + - mtl + - mutable-containers + - network-uri + - nonempty-containers + - pretty-simple + - regex-tdfa + - semialign + - semigroups + - servant-client + - stm + - text + - these + - time + - transformers + - unicode-show + - unison-codebase + - unison-codebase-sqlite + - unison-codebase-sqlite-hashing-v2 + - unison-codebase-sync + - unison-core + - unison-core1 + - unison-hash + - unison-hashing-v2 + - unison-prelude + - unison-pretty-printer + - unison-sqlite + - unison-syntax + - unison-util-base32hex + - unison-util-bytes + - unison-util-cache + - unison-util-recursion + - unison-util-relation + - unison-util-rope + - unison-util-serialization + - unliftio + - uuid + - vector + - witherable + tests: parser-typechecker-tests: source-dirs: tests main: Suite.hs ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 dependencies: + - base - code-page + - containers - easytest - - filemanip - - split - - hex-text + - text + - unison-core + - unison-core1 + - unison-hash - unison-parser-typechecker + - unison-prelude + - unison-pretty-printer + - unison-syntax + - unison-util-relation + - unison-util-rope + - megaparsec + - mtl + - temporary + - raw-strings-qq + - unison-hashing-v2 when: - condition: false other-modules: Paths_unison_parser_typechecker @@ -172,6 +103,7 @@ default-extensions: - ApplicativeDo - BangPatterns - BlockArguments + - ConstraintKinds - DeriveAnyClass - DeriveFunctor - DeriveGeneric diff --git a/parser-typechecker/src/U/Codebase/Branch/Diff.hs b/parser-typechecker/src/U/Codebase/Branch/Diff.hs index c4a7291547..430155a4cc 100644 --- a/parser-typechecker/src/U/Codebase/Branch/Diff.hs +++ b/parser-typechecker/src/U/Codebase/Branch/Diff.hs @@ -78,7 +78,7 @@ instance (Applicative m) => Semigroup (TreeDiff m) where instance (Applicative m) => Monoid (TreeDiff m) where mempty = TreeDiff (mempty :< Compose mempty) -hoistTreeDiff :: Functor m => (forall x. m x -> n x) -> TreeDiff m -> TreeDiff n +hoistTreeDiff :: (Functor m) => (forall x. m x -> n x) -> TreeDiff m -> TreeDiff n hoistTreeDiff f (TreeDiff cfr) = TreeDiff $ Cofree.hoistCofree (\(Compose m) -> Compose (fmap f m)) cfr diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 0c7e0514bf..15934d4895 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -103,7 +103,7 @@ builtinEffectDecls :: [(Symbol, (R.Id, EffectDeclaration))] builtinEffectDecls = [(v, (r, Intrinsic <$ d)) | (v, r, d) <- DD.builtinEffectDecls] codeLookup :: (Applicative m) => CodeLookup Symbol m Ann -codeLookup = CodeLookup (const $ pure Nothing) $ \r -> +codeLookup = CodeLookup (const $ pure Nothing) (const $ pure Nothing) $ \r -> pure $ lookup r [(r, Right x) | (r, x) <- snd <$> builtinDataDecls] <|> lookup r [(r, Left x) | (r, x) <- snd <$> builtinEffectDecls] @@ -985,7 +985,7 @@ refPromiseBuiltins = forall1 :: Text -> (Type -> Type) -> Type forall1 name body = let a = Var.named name - in Type.forall () a (body $ Type.var () a) + in Type.forAll () a (body $ Type.var () a) forall2 :: Text -> Text -> (Type -> Type -> Type) -> Type diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index b48bc44830..a918671d8d 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -174,13 +174,13 @@ rewriteCaseRef = lookupDeclRef "RewriteCase" pattern RewriteCase' :: Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a pattern RewriteCase' lhs rhs <- (unRewriteCase -> Just (lhs, rhs)) -rewriteCase :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +rewriteCase :: (Ord v) => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a rewriteCase a tm1 tm2 = Term.app a (Term.app a1 (Term.constructor a1 r) tm1) tm2 where a1 = ABT.annotation tm1 r = ConstructorReference rewriteCaseRef 0 -rewriteTerm :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +rewriteTerm :: (Ord v) => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a rewriteTerm a tm1 tm2 = Term.app a (Term.app a1 (Term.constructor a1 r) tm1) tm2 where a1 = ABT.annotation tm1 @@ -596,7 +596,7 @@ builtinEffectDecls = Structural () [] - [ ((), v "Exception.raise", Type.forall () (v "x") (failureType () `arr` self (var "x"))) + [ ((), v "Exception.raise", Type.forAll () (v "x") (failureType () `arr` self (var "x"))) ] pattern UnitRef :: Reference @@ -776,8 +776,8 @@ tupleTerm = foldr tupleConsTerm (unitTerm mempty) forceTerm :: (Var v) => a -> a -> Term v a -> Term v a forceTerm a au e = Term.app a e (unitTerm au) -delayTerm :: (Var v) => a -> Term v a -> Term v a -delayTerm a = Term.lam a $ Var.typed Var.Delay +delayTerm :: (Var v) => a -> a -> Term v a -> Term v a +delayTerm spanAnn argAnn = Term.lam spanAnn (argAnn, Var.typed Var.Delay) unTupleTerm :: Term.Term2 vt at ap v a -> diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 107b765c3e..1fcb0e5c7c 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -1,6 +1,11 @@ module Unison.Codebase ( Codebase, + -- * UCM session state + expectCurrentProjectPath, + setCurrentProjectPath, + resolveProjectPathIds, + -- * Terms getTerm, unsafeGetTerm, @@ -43,18 +48,20 @@ module Unison.Codebase lca, SqliteCodebase.Operations.before, getShallowBranchAtPath, + getMaybeShallowBranchAtPath, getShallowCausalAtPath, - getBranchAtPath, Operations.expectCausalBranchByCausalHash, - getShallowCausalFromRoot, - getShallowRootBranch, - getShallowRootCausal, + getShallowCausalAtPathFromRootHash, + getShallowProjectBranchRoot, + expectShallowProjectBranchRoot, + getShallowBranchAtProjectPath, + getMaybeShallowBranchAtProjectPath, + getShallowProjectRootByNames, + expectProjectBranchRoot, + getBranchAtProjectPath, + preloadProjectBranch, -- * Root branch - getRootBranch, - SqliteCodebase.Operations.getRootBranchExists, - Operations.expectRootCausalHash, - putRootBranch, SqliteCodebase.Operations.namesAtPath, -- * Patches @@ -70,7 +77,10 @@ module Unison.Codebase Queries.clearWatches, -- * Reflog - Operations.getReflog, + Operations.getDeprecatedRootReflog, + Operations.getProjectBranchReflog, + Operations.getProjectReflog, + Operations.getGlobalReflog, -- * Unambiguous hash length SqliteCodebase.Operations.hashLength, @@ -82,10 +92,6 @@ module Unison.Codebase -- * Sync - -- ** Local sync - syncFromDirectory, - syncToDirectory, - -- * Codebase path getCodebaseDir, CodebasePath, @@ -100,33 +106,36 @@ module Unison.Codebase addDefsToCodebase, componentReferencesForReference, installUcmDependencies, - toCodeLookup, typeLookupForDependencies, unsafeGetComponentLength, + SqliteCodebase.Operations.emptyCausalHash, ) where import Data.Map qualified as Map import Data.Set qualified as Set -import U.Codebase.Branch qualified as V2 import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash) +import U.Codebase.Sqlite.DbId qualified as Db import U.Codebase.Sqlite.Operations qualified as Operations +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Builtin qualified as Builtin import Unison.Builtin.Terms qualified as Builtin import Unison.Codebase.Branch (Branch) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation)) -import Unison.Codebase.CodeLookup qualified as CL import Unison.Codebase.Path import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Operations import Unison.Codebase.Type (Codebase (..)) import Unison.CodebasePath (CodebasePath, getCodebaseDir) import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) +import Unison.Core.Project (ProjectAndBranch) import Unison.DataDeclaration (Decl) import Unison.DataDeclaration qualified as DD import Unison.Hash (Hash) @@ -134,10 +143,10 @@ import Unison.Hashing.V2.Convert qualified as Hashing import Unison.Parser.Ann (Ann) import Unison.Parser.Ann qualified as Parser import Unison.Prelude -import Unison.Reference (Reference, TermReferenceId, TypeReference) +import Unison.Project (ProjectAndBranch (ProjectAndBranch), ProjectBranchName, ProjectName) +import Unison.Reference (Reference, TermReference, TermReferenceId, TypeReference) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent -import Unison.Runtime.IOSource qualified as IOSource import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Term (Term) @@ -147,6 +156,7 @@ import Unison.Type qualified as Type import Unison.Typechecker.TypeLookup (TypeLookup (TypeLookup)) import Unison.Typechecker.TypeLookup qualified as TL import Unison.UnisonFile qualified as UF +import Unison.Util.Defns (Defns (..), DefnsF) import Unison.Util.Relation qualified as Rel import Unison.Var (Var) import Unison.WatchKind qualified as WK @@ -164,72 +174,105 @@ runTransactionWithRollback :: runTransactionWithRollback Codebase {withConnection} action = withConnection \conn -> Sqlite.runTransactionWithRollback conn action -getShallowCausalFromRoot :: - -- Optional root branch, if Nothing use the codebase's root branch. - Maybe CausalHash -> +getShallowCausalAtPathFromRootHash :: + -- Causal to start at, if Nothing use the codebase's root branch. + CausalHash -> Path.Path -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -getShallowCausalFromRoot mayRootHash p = do - rootCausal <- case mayRootHash of - Nothing -> getShallowRootCausal - Just ch -> Operations.expectCausalBranchByCausalHash ch - getShallowCausalAtPath p (Just rootCausal) - --- | Get the shallow representation of the root branches without loading the children or --- history. -getShallowRootBranch :: Sqlite.Transaction (V2.Branch Sqlite.Transaction) -getShallowRootBranch = do - getShallowRootCausal >>= V2Causal.value - --- | Get the shallow representation of the root branches without loading the children or --- history. -getShallowRootCausal :: Sqlite.Transaction (V2.CausalBranch Sqlite.Transaction) -getShallowRootCausal = do - hash <- Operations.expectRootCausalHash - Operations.expectCausalBranchByCausalHash hash +getShallowCausalAtPathFromRootHash rootCausalHash p = do + rootCausal <- Operations.expectCausalBranchByCausalHash rootCausalHash + getShallowCausalAtPath p rootCausal -- | Recursively descend into causals following the given path, -- Use the root causal if none is provided. getShallowCausalAtPath :: Path -> - Maybe (V2Branch.CausalBranch Sqlite.Transaction) -> + (V2Branch.CausalBranch Sqlite.Transaction) -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -getShallowCausalAtPath path mayCausal = do - causal <- whenNothing mayCausal getShallowRootCausal +getShallowCausalAtPath path causal = do case path of Path.Empty -> pure causal ns Path.:< p -> do b <- V2Causal.value causal case V2Branch.childAt ns b of Nothing -> pure (Cv.causalbranch1to2 Branch.empty) - Just childCausal -> getShallowCausalAtPath p (Just childCausal) + Just childCausal -> getShallowCausalAtPath p childCausal -- | Recursively descend into causals following the given path, -- Use the root causal if none is provided. getShallowBranchAtPath :: Path -> - Maybe (V2Branch.Branch Sqlite.Transaction) -> + V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) -getShallowBranchAtPath path mayBranch = do - branch <- whenNothing mayBranch (getShallowRootCausal >>= V2Causal.value) +getShallowBranchAtPath path branch = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtPath path branch + +-- | Recursively descend into causals following the given path, +-- Use the root causal if none is provided. +getMaybeShallowBranchAtPath :: + Path -> + V2Branch.Branch Sqlite.Transaction -> + Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction)) +getMaybeShallowBranchAtPath path branch = do case path of - Path.Empty -> pure branch + Path.Empty -> pure $ Just branch ns Path.:< p -> do case V2Branch.childAt ns branch of - Nothing -> pure V2Branch.empty + Nothing -> pure Nothing Just childCausal -> do childBranch <- V2Causal.value childCausal - getShallowBranchAtPath p (Just childBranch) + getMaybeShallowBranchAtPath p childBranch + +-- | Recursively descend into causals following the given path, +-- Use the root causal if none is provided. +getShallowBranchAtProjectPath :: + PP.ProjectPath -> + Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) +getShallowBranchAtProjectPath pp = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtProjectPath pp + +-- | Recursively descend into causals following the given path, +-- Use the root causal if none is provided. +getMaybeShallowBranchAtProjectPath :: + PP.ProjectPath -> + Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction)) +getMaybeShallowBranchAtProjectPath (PP.ProjectPath _project projectBranch path) = do + getShallowProjectBranchRoot projectBranch >>= \case + Nothing -> pure Nothing + Just projectRootBranch -> getMaybeShallowBranchAtPath (Path.unabsolute path) projectRootBranch + +getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction)) +getShallowProjectRootByNames (ProjectAndBranch projectName branchName) = runMaybeT do + ProjectBranch {projectId, branchId} <- MaybeT $ Q.loadProjectBranchByNames projectName branchName + causalHashId <- lift $ Q.expectProjectBranchHead projectId branchId + causalHash <- lift $ Q.expectCausalHash causalHashId + lift $ Operations.expectCausalBranchByCausalHash causalHash + +expectProjectBranchRoot :: (MonadIO m) => Codebase m v a -> Db.ProjectId -> Db.ProjectBranchId -> m (Branch m) +expectProjectBranchRoot codebase projectId branchId = do + causalHash <- runTransaction codebase $ do + causalHashId <- Q.expectProjectBranchHead projectId branchId + Q.expectCausalHash causalHashId + expectBranchForHash codebase causalHash --- | Get a v1 branch from the root following the given path. -getBranchAtPath :: +expectShallowProjectBranchRoot :: ProjectBranch -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) +expectShallowProjectBranchRoot ProjectBranch {projectId, branchId} = do + causalHashId <- Q.expectProjectBranchHead projectId branchId + causalHash <- Q.expectCausalHash causalHashId + Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value + +getShallowProjectBranchRoot :: ProjectBranch -> Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction)) +getShallowProjectBranchRoot ProjectBranch {projectId, branchId} = do + causalHashId <- Q.expectProjectBranchHead projectId branchId + causalHash <- Q.expectCausalHash causalHashId + Operations.loadCausalBranchByCausalHash causalHash >>= traverse V2Causal.value + +getBranchAtProjectPath :: (MonadIO m) => Codebase m v a -> - Path.Absolute -> - m (Branch m) -getBranchAtPath codebase path = do - V2Causal.Causal {causalHash} <- runTransaction codebase $ getShallowCausalAtPath (Path.unabsolute path) Nothing - expectBranchForHash codebase causalHash + PP.ProjectPath -> + m (Maybe (Branch m)) +getBranchAtProjectPath codebase pp = runMaybeT do + rootBranch <- lift $ expectProjectBranchRoot codebase pp.branch.projectId pp.branch.branchId + hoistMaybe $ Branch.getAt (pp ^. PP.path_) rootBranch -- | Like 'getBranchForHash', but for when the hash is known to be in the codebase. expectBranchForHash :: (Monad m) => Codebase m v a -> CausalHash -> m (Branch m) @@ -315,35 +358,50 @@ lookupWatchCache codebase h = do -- and all of their type dependencies, including builtins. typeLookupForDependencies :: Codebase IO Symbol Ann -> - Set Reference -> + DefnsF Set TermReference TypeReference -> Sqlite.Transaction (TL.TypeLookup Symbol Ann) typeLookupForDependencies codebase s = do when debug $ traceM $ "typeLookupForDependencies " ++ show s - (<> Builtin.typeLookup) <$> depthFirstAccum mempty s + (<> Builtin.typeLookup) <$> depthFirstAccum s where - depthFirstAccum :: TL.TypeLookup Symbol Ann -> Set Reference -> Sqlite.Transaction (TL.TypeLookup Symbol Ann) - depthFirstAccum tl refs = foldM go tl (Set.filter (unseen tl) refs) + depthFirstAccum :: + DefnsF Set TermReference TypeReference -> + Sqlite.Transaction (TL.TypeLookup Symbol Ann) + depthFirstAccum refs = do + tl <- depthFirstAccumTypes mempty refs.types + foldM goTerm tl (Set.filter (unseen tl) refs.terms) + + depthFirstAccumTypes :: + TL.TypeLookup Symbol Ann -> + Set TypeReference -> + Sqlite.Transaction (TL.TypeLookup Symbol Ann) + depthFirstAccumTypes tl refs = + foldM goType tl (Set.filter (unseen tl) refs) -- We need the transitive dependencies of data decls -- that are scrutinized in a match expression for -- pattern match coverage checking (specifically for -- the inhabitation check). We ensure these are found -- by collecting all transitive type dependencies. - go tl ref@(Reference.DerivedId id) = + goTerm :: TypeLookup Symbol Ann -> TermReference -> Sqlite.Transaction (TypeLookup Symbol Ann) + goTerm tl ref = getTypeOfTerm codebase ref >>= \case Just typ -> let z = tl <> TypeLookup (Map.singleton ref typ) mempty mempty - in depthFirstAccum z (Type.dependencies typ) - Nothing -> - getTypeDeclaration codebase id >>= \case - Just (Left ed) -> - let z = tl <> TypeLookup mempty mempty (Map.singleton ref ed) - in depthFirstAccum z (DD.typeDependencies $ DD.toDataDecl ed) - Just (Right dd) -> - let z = tl <> TypeLookup mempty (Map.singleton ref dd) mempty - in depthFirstAccum z (DD.typeDependencies dd) - Nothing -> pure tl - go tl Reference.Builtin {} = pure tl -- codebase isn't consulted for builtins + in depthFirstAccumTypes z (Type.dependencies typ) + Nothing -> pure tl + + goType :: TypeLookup Symbol Ann -> TypeReference -> Sqlite.Transaction (TypeLookup Symbol Ann) + goType tl ref@(Reference.DerivedId id) = + getTypeDeclaration codebase id >>= \case + Just (Left ed) -> + let z = tl <> TypeLookup mempty mempty (Map.singleton ref ed) + in depthFirstAccumTypes z (DD.typeDependencies $ DD.toDataDecl ed) + Just (Right dd) -> + let z = tl <> TypeLookup mempty (Map.singleton ref dd) mempty + in depthFirstAccumTypes z (DD.typeDependencies dd) + Nothing -> pure tl + goType tl Reference.Builtin {} = pure tl -- codebase isn't consulted for builtins unseen :: TL.TypeLookup Symbol a -> Reference -> Bool unseen tl r = isNothing @@ -352,12 +410,6 @@ typeLookupForDependencies codebase s = do <|> Map.lookup r (TL.effectDecls tl) $> () ) -toCodeLookup :: (MonadIO m) => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann -toCodeLookup c = - CL.CodeLookup (runTransaction c . getTerm c) (runTransaction c . getTypeDeclaration c) - <> Builtin.codeLookup - <> IOSource.codeLookupM - -- | Get the type of a term. -- -- Note that it is possible to call 'putTerm', then 'getTypeOfTerm', and receive @Nothing@, per the semantics of @@ -416,14 +468,28 @@ termsOfTypeByReference c r = . Set.map (fmap Reference.DerivedId) <$> termsOfTypeImpl c r -filterTermsByReferentHavingType :: (Var v) => Codebase m v a -> Type v a -> Set Referent.Referent -> Sqlite.Transaction (Set Referent.Referent) +filterTermsByReferentHavingType :: + (Var v) => + Codebase m v a -> + Type v a -> + Set Referent.Referent -> + Sqlite.Transaction (Set Referent.Referent) filterTermsByReferentHavingType c ty = filterTermsByReferentHavingTypeByReference c $ Hashing.typeToReference ty -filterTermsByReferenceIdHavingType :: (Var v) => Codebase m v a -> Type v a -> Set TermReferenceId -> Sqlite.Transaction (Set TermReferenceId) +filterTermsByReferenceIdHavingType :: + (Var v) => + Codebase m v a -> + Type v a -> + Set TermReferenceId -> + Sqlite.Transaction (Set TermReferenceId) filterTermsByReferenceIdHavingType c ty = filterTermsByReferenceIdHavingTypeImpl c (Hashing.typeToReference ty) -- | Find the subset of `tms` which match the exact type `r` points to. -filterTermsByReferentHavingTypeByReference :: Codebase m v a -> TypeReference -> Set Referent.Referent -> Sqlite.Transaction (Set Referent.Referent) +filterTermsByReferentHavingTypeByReference :: + Codebase m v a -> + TypeReference -> + Set Referent.Referent -> + Sqlite.Transaction (Set Referent.Referent) filterTermsByReferentHavingTypeByReference c r tms = do let (builtins, derived) = partitionEithers . map p $ Set.toList tms let builtins' = @@ -509,3 +575,30 @@ unsafeGetTermComponent codebase hash = getTermComponentWithTypes codebase hash <&> \case Nothing -> error (reportBug "E769004" ("term component " ++ show hash ++ " not found")) Just terms -> terms + +expectCurrentProjectPath :: (HasCallStack) => Sqlite.Transaction PP.ProjectPath +expectCurrentProjectPath = do + (projectId, projectBranchId, path) <- Q.expectCurrentProjectPath + proj <- Q.expectProject projectId + projBranch <- Q.expectProjectBranch projectId projectBranchId + let absPath = Path.Absolute (Path.fromList path) + pure $ PP.ProjectPath proj projBranch absPath + +setCurrentProjectPath :: PP.ProjectPathIds -> Sqlite.Transaction () +setCurrentProjectPath (PP.ProjectPath projectId projectBranchId path) = + Q.setCurrentProjectPath projectId projectBranchId (Path.toList (Path.unabsolute path)) + +-- | Hydrate the project and branch from IDs. +resolveProjectPathIds :: PP.ProjectPathIds -> Sqlite.Transaction PP.ProjectPath +resolveProjectPathIds (PP.ProjectPath projectId projectBranchId path) = do + proj <- Q.expectProject projectId + projBranch <- Q.expectProjectBranch projectId projectBranchId + pure $ PP.ProjectPath proj projBranch path + +-- | Starts loading the given project branch into cache in a background thread without blocking. +preloadProjectBranch :: (MonadUnliftIO m) => Codebase m v a -> ProjectAndBranch Db.ProjectId Db.ProjectBranchId -> m () +preloadProjectBranch codebase (ProjectAndBranch projectId branchId) = do + ch <- runTransaction codebase $ do + causalHashId <- Q.expectProjectBranchHead projectId branchId + Q.expectCausalHash causalHashId + preloadBranch codebase ch diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index 2e981501c9..14629643ec 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -86,11 +86,14 @@ module Unison.Codebase.Branch -- ** Term/type queries deepTerms, deepTypes, + deepDefns, deepEdits, deepPaths, deepReferents, deepTermReferences, + deepTermReferenceIds, deepTypeReferences, + deepTypeReferenceIds, consBranchSnapshot, ) where @@ -110,6 +113,7 @@ import Unison.Codebase.Branch.Type UnwrappedBranch, branch0, children, + deepDefns, deepEdits, deepPaths, deepTerms, @@ -136,7 +140,8 @@ import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment import Unison.Prelude hiding (empty) -import Unison.Reference (TermReference, TypeReference) +import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId) +import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Util.List qualified as List @@ -201,9 +206,17 @@ deepTermReferences :: Branch0 m -> Set TermReference deepTermReferences = Set.mapMaybe Referent.toTermReference . deepReferents +deepTermReferenceIds :: Branch0 m -> Set TermReferenceId +deepTermReferenceIds = + Set.mapMaybe Referent.toTermReferenceId . deepReferents + deepTypeReferences :: Branch0 m -> Set TypeReference deepTypeReferences = R.dom . deepTypes +deepTypeReferenceIds :: Branch0 m -> Set TypeReferenceId +deepTypeReferenceIds = + Set.mapMaybe Reference.toId . deepTypeReferences + namespaceStats :: Branch0 m -> NamespaceStats namespaceStats b = NamespaceStats @@ -307,7 +320,7 @@ cons = step . const -- | Construct a two-parent merge node. mergeNode :: forall m. - Applicative m => + (Applicative m) => Branch0 m -> (CausalHash, m (Branch m)) -> (CausalHash, m (Branch m)) -> diff --git a/parser-typechecker/src/Unison/Codebase/Branch/Type.hs b/parser-typechecker/src/Unison/Codebase/Branch/Type.hs index a0692e5ab4..ebc0ae467e 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch/Type.hs @@ -10,8 +10,8 @@ module Unison.Codebase.Branch.Type Branch (..), Branch0, branch0, - terms, - types, + Unison.Codebase.Branch.Type.terms, + Unison.Codebase.Branch.Type.types, children, nonEmptyChildren, history, @@ -19,6 +19,7 @@ module Unison.Codebase.Branch.Type isEmpty0, deepTerms, deepTypes, + deepDefns, deepPaths, deepEdits, Star, @@ -47,9 +48,11 @@ import Unison.NameSegment qualified as NameSegment import Unison.Prelude hiding (empty) import Unison.Reference (Reference, TypeReference) import Unison.Referent (Referent) +import Unison.Util.Defns (Defns (..), DefnsF) import Unison.Util.Monoid qualified as Monoid import Unison.Util.Relation (Relation) import Unison.Util.Relation qualified as R +import Unison.Util.Relation qualified as Relation import Unison.Util.Star2 qualified as Star2 import Prelude hiding (head, read, subtract) @@ -148,6 +151,13 @@ deepTerms = _deepTerms deepTypes :: Branch0 m -> Relation TypeReference Name deepTypes = _deepTypes +deepDefns :: Branch0 m -> DefnsF (Relation Name) Referent TypeReference +deepDefns branch = + Defns + { terms = Relation.swap (deepTerms branch), + types = Relation.swap (deepTypes branch) + } + deepPaths :: Branch0 m -> Set Path deepPaths = _deepPaths diff --git a/parser-typechecker/src/Unison/Codebase/BranchUtil.hs b/parser-typechecker/src/Unison/Codebase/BranchUtil.hs index d0025cd87e..e639fd41b0 100644 --- a/parser-typechecker/src/Unison/Codebase/BranchUtil.hs +++ b/parser-typechecker/src/Unison/Codebase/BranchUtil.hs @@ -25,7 +25,8 @@ import Unison.Codebase.Branch (Branch, Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path -import Unison.HashQualified' (HashQualified (HashQualified, NameOnly)) +import Unison.HashQualifiedPrime (HashQualified (HashQualified, NameOnly)) +import Unison.NameSegment (NameSegment) import Unison.Names (Names) import Unison.Names qualified as Names import Unison.Prelude @@ -69,10 +70,10 @@ getBranch (p, seg) b = case Path.toList p of (Branch.head <$> Map.lookup h (b ^. Branch.children)) >>= getBranch (Path.fromList p, seg) -makeAddTermName :: Path.Split -> Referent -> (Path, Branch0 m -> Branch0 m) +makeAddTermName :: (p, NameSegment) -> Referent -> (p, Branch0 m -> Branch0 m) makeAddTermName (p, name) r = (p, Branch.addTermName r name) -makeDeleteTermName :: Path.Split -> Referent -> (Path, Branch0 m -> Branch0 m) +makeDeleteTermName :: (p, NameSegment) -> Referent -> (p, Branch0 m -> Branch0 m) makeDeleteTermName (p, name) r = (p, Branch.deleteTermName r name) makeAnnihilateTermName :: Path.Split -> (Path, Branch0 m -> Branch0 m) @@ -81,10 +82,10 @@ makeAnnihilateTermName (p, name) = (p, Branch.annihilateTermName name) makeAnnihilateTypeName :: Path.Split -> (Path, Branch0 m -> Branch0 m) makeAnnihilateTypeName (p, name) = (p, Branch.annihilateTypeName name) -makeAddTypeName :: Path.Split -> Reference -> (Path, Branch0 m -> Branch0 m) +makeAddTypeName :: (p, NameSegment) -> Reference -> (p, Branch0 m -> Branch0 m) makeAddTypeName (p, name) r = (p, Branch.addTypeName r name) -makeDeleteTypeName :: Path.Split -> Reference -> (Path, Branch0 m -> Branch0 m) +makeDeleteTypeName :: (p, NameSegment) -> Reference -> (p, Branch0 m -> Branch0 m) makeDeleteTypeName (p, name) r = (p, Branch.deleteTypeName r name) makeSetBranch :: Path.Split -> Branch m -> (Path, Branch0 m -> Branch0 m) diff --git a/parser-typechecker/src/Unison/Codebase/Causal.hs b/parser-typechecker/src/Unison/Codebase/Causal.hs index 8cca62cf05..9bdd089032 100644 --- a/parser-typechecker/src/Unison/Codebase/Causal.hs +++ b/parser-typechecker/src/Unison/Codebase/Causal.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Unison.Codebase.Causal - ( Causal (currentHash, head, tail, tails), + ( Causal (currentHash, valueHash, head, tail, tails), pattern One, pattern Cons, pattern Merge, @@ -40,7 +40,8 @@ import Unison.Codebase.Causal.Type currentHash, head, tail, - tails + tails, + valueHash ), before, lca, diff --git a/parser-typechecker/src/Unison/Codebase/CodeLookup.hs b/parser-typechecker/src/Unison/Codebase/CodeLookup.hs index bca52cecfb..b27a2e7948 100644 --- a/parser-typechecker/src/Unison/Codebase/CodeLookup.hs +++ b/parser-typechecker/src/Unison/Codebase/CodeLookup.hs @@ -8,37 +8,44 @@ import Unison.Prelude import Unison.Reference qualified as Reference import Unison.Term (Term) import Unison.Term qualified as Term +import Unison.Type (Type) +import Unison.Util.Defns (Defns (..)) import Unison.Util.Set qualified as Set import Unison.Var (Var) data CodeLookup v m a = CodeLookup { getTerm :: Reference.Id -> m (Maybe (Term v a)), + getTypeOfTerm :: Reference.Id -> m (Maybe (Type v a)), getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)) } instance MFunctor (CodeLookup v) where - hoist f (CodeLookup tm tp) = CodeLookup (f . tm) (f . tp) + hoist f (CodeLookup tm tmTyp tp) = CodeLookup (f . tm) (f . tmTyp) (f . tp) instance (Ord v, Functor m) => Functor (CodeLookup v m) where - fmap f cl = CodeLookup tm ty + fmap f cl = CodeLookup tm tmTyp ty where tm id = fmap (Term.amap f) <$> getTerm cl id ty id = fmap md <$> getTypeDeclaration cl id + tmTyp id = (fmap . fmap) f <$> getTypeOfTerm cl id md (Left e) = Left (f <$> e) md (Right d) = Right (f <$> d) instance (Monad m) => Semigroup (CodeLookup v m a) where - c1 <> c2 = CodeLookup tm ty + c1 <> c2 = CodeLookup tm tmTyp ty where tm id = do o <- getTerm c1 id case o of Nothing -> getTerm c2 id; Just _ -> pure o + tmTyp id = do + o <- getTypeOfTerm c1 id + case o of Nothing -> getTypeOfTerm c2 id; Just _ -> pure o ty id = do o <- getTypeDeclaration c1 id case o of Nothing -> getTypeDeclaration c2 id; Just _ -> pure o instance (Monad m) => Monoid (CodeLookup v m a) where - mempty = CodeLookup (const $ pure Nothing) (const $ pure Nothing) + mempty = CodeLookup (const $ pure Nothing) (const $ pure Nothing) (const $ pure Nothing) -- todo: can this be implemented in terms of TransitiveClosure.transitiveClosure? -- todo: add some tests on this guy? @@ -56,7 +63,7 @@ transitiveDependencies code seen0 rid = getIds = Set.mapMaybe Reference.toId in getTerm code rid >>= \case Just t -> - foldM (transitiveDependencies code) seen (getIds $ Term.dependencies t) + foldM (transitiveDependencies code) seen (getIds $ let deps = Term.dependencies t in deps.terms <> deps.types) Nothing -> getTypeDeclaration code rid >>= \case Nothing -> pure seen diff --git a/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs b/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs index 82c323fe78..708891159e 100644 --- a/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs +++ b/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs @@ -8,15 +8,18 @@ import Unison.DataDeclaration qualified as DataDeclaration import Unison.Prelude import Unison.Reference qualified as Reference import Unison.Term qualified as Term +import Unison.Type qualified as Type import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Type (TypecheckedUnisonFile) import Unison.Var (Var) fromTypecheckedUnisonFile :: forall m v a. (Var v, Monad m) => TypecheckedUnisonFile v a -> CodeLookup v m a -fromTypecheckedUnisonFile tuf = CodeLookup tm ty +fromTypecheckedUnisonFile tuf = CodeLookup tm tmTyp ty where tm :: Reference.Id -> m (Maybe (Term.Term v a)) - tm id = pure $ Map.lookup id termMap + tm id = pure . fmap fst $ Map.lookup id termMap + tmTyp :: Reference.Id -> m (Maybe (Type.Type v a)) + tmTyp id = pure . fmap snd $ Map.lookup id termMap ty :: Reference.Id -> m (Maybe (DataDeclaration.Decl v a)) ty id = pure $ Map.lookup id dataDeclMap <|> Map.lookup id effectDeclMap dataDeclMap = @@ -31,5 +34,5 @@ fromTypecheckedUnisonFile tuf = CodeLookup tm ty | (_, (Reference.DerivedId id, ad)) <- Map.toList (UF.effectDeclarations' tuf) ] - termMap :: Map Reference.Id (Term.Term v a) - termMap = Map.fromList [(id, tm) | (_a, id, _wk, tm, _tp) <- toList $ UF.hashTermsId tuf] + termMap :: Map Reference.Id (Term.Term v a, Type.Type v a) + termMap = Map.fromList [(id, (tm, typ)) | (_a, id, _wk, tm, typ) <- toList $ UF.hashTermsId tuf] diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index a3d5c63f51..bd352cbc26 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -1,8 +1,5 @@ module Unison.Codebase.Editor.RemoteRepo where -import Control.Lens (Lens') -import Control.Lens qualified as Lens -import Data.Void (absurd) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.NameSegment qualified as NameSegment @@ -35,12 +32,6 @@ displayShareCodeserver cs shareUser path = CustomCodeserver cu -> "share(" <> tShow cu <> ")." in shareServer <> shareUserHandleToText shareUser <> maybePrintPath path -writeNamespaceToRead :: WriteRemoteNamespace Void -> ReadRemoteNamespace void -writeNamespaceToRead = \case - WriteRemoteNamespaceShare WriteShareRemoteNamespace {server, repo, path} -> - ReadShare'LooseCode ReadShareLooseCode {server, repo, path} - WriteRemoteProjectBranch v -> absurd v - -- | print remote namespace printReadRemoteNamespace :: (a -> Text) -> ReadRemoteNamespace a -> Text printReadRemoteNamespace printProject = \case @@ -48,11 +39,8 @@ printReadRemoteNamespace printProject = \case ReadShare'ProjectBranch project -> printProject project -- | Render a 'WriteRemoteNamespace' as text. -printWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Text -printWriteRemoteNamespace = \case - WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server, repo, path}) -> - displayShareCodeserver server repo path - WriteRemoteProjectBranch projectAndBranch -> into @Text projectAndBranch +printWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Text +printWriteRemoteNamespace projectAndBranch = into @Text projectAndBranch maybePrintPath :: Path -> Text maybePrintPath path = @@ -80,28 +68,3 @@ isPublic ReadShareLooseCode {path} = case path of (segment Path.:< _) -> segment == NameSegment.publicLooseCodeSegment _ -> False - -data WriteRemoteNamespace a - = WriteRemoteNamespaceShare !WriteShareRemoteNamespace - | WriteRemoteProjectBranch a - deriving stock (Eq, Functor, Show) - --- | A lens which focuses the path of a remote namespace. -remotePath_ :: Lens' (WriteRemoteNamespace Void) Path -remotePath_ = Lens.lens getter setter - where - getter = \case - WriteRemoteNamespaceShare (WriteShareRemoteNamespace _ _ path) -> path - WriteRemoteProjectBranch v -> absurd v - setter remote path = - case remote of - WriteRemoteNamespaceShare (WriteShareRemoteNamespace server repo _) -> - WriteRemoteNamespaceShare $ WriteShareRemoteNamespace server repo path - WriteRemoteProjectBranch v -> absurd v - -data WriteShareRemoteNamespace = WriteShareRemoteNamespace - { server :: !ShareCodeserver, - repo :: !ShareUserHandle, - path :: !Path - } - deriving stock (Eq, Show) diff --git a/parser-typechecker/src/Unison/Codebase/Execute.hs b/parser-typechecker/src/Unison/Codebase/Execute.hs deleted file mode 100644 index e7f1ef0762..0000000000 --- a/parser-typechecker/src/Unison/Codebase/Execute.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | Execute a computation of type '{IO} () that has been previously added to --- the codebase, without setting up an interactive environment. --- --- This allows one to run standalone applications implemented in the Unison --- language. -module Unison.Codebase.Execute where - -import Control.Exception (finally) -import Control.Monad.Except -import Unison.Codebase qualified as Codebase -import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Branch.Names qualified as Branch -import Unison.Codebase.MainTerm (getMainTerm) -import Unison.Codebase.MainTerm qualified as MainTerm -import Unison.Codebase.Runtime (Runtime) -import Unison.Codebase.Runtime qualified as Runtime -import Unison.HashQualified qualified as HQ -import Unison.Name (Name) -import Unison.Names qualified as Names -import Unison.Parser.Ann (Ann) -import Unison.PrettyPrintEnv qualified as PPE -import Unison.Symbol (Symbol) -import Unison.Syntax.HashQualified qualified as HQ (toText) -import Unison.Util.Pretty qualified as P - -execute :: - Codebase.Codebase IO Symbol Ann -> - Runtime Symbol -> - HQ.HashQualified Name -> - IO (Either Runtime.Error ()) -execute codebase runtime mainName = - (`finally` Runtime.terminate runtime) . runExceptT $ do - root <- liftIO $ Codebase.getRootBranch codebase - let parseNames = Names.makeAbsolute (Branch.toNames (Branch.head root)) - loadTypeOfTerm = Codebase.getTypeOfTerm codebase - let mainType = Runtime.mainType runtime - mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm parseNames mainName mainType - case mt of - MainTerm.NotFound s -> throwError ("Not found: " <> P.text (HQ.toText s)) - MainTerm.BadType s _ -> throwError (P.text (HQ.toText s) <> " is not of type '{IO} ()") - MainTerm.Success _ tm _ -> do - let codeLookup = Codebase.toCodeLookup codebase - ppe = PPE.empty - (liftIO $ Runtime.evaluateTerm codeLookup ppe runtime tm) >>= \case - Left err -> throwError err - Right _ -> pure () diff --git a/parser-typechecker/src/Unison/Codebase/MainTerm.hs b/parser-typechecker/src/Unison/Codebase/MainTerm.hs index 9f99ae5599..4c48a8a95b 100644 --- a/parser-typechecker/src/Unison/Codebase/MainTerm.hs +++ b/parser-typechecker/src/Unison/Codebase/MainTerm.hs @@ -57,7 +57,7 @@ getMainTerm loadTypeOfTerm parseNames mainName mainType = do builtinMain :: (Var v) => a -> Type.Type v a builtinMain a = let result = Var.named "result" - in Type.forall a result (builtinMainWithResultType a (Type.var a result)) + in Type.forAll a result (builtinMainWithResultType a (Type.var a result)) -- '{io2.IO, Exception} res builtinMainWithResultType :: (Var v) => a -> Type.Type v a -> Type.Type v a diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index 516a6c86f6..d35a339990 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -5,7 +5,9 @@ module Unison.Codebase.Path Path' (..), Absolute (..), pattern AbsolutePath', + absPath_, Relative (..), + relPath_, pattern RelativePath', Resolve (..), pattern Empty, @@ -30,6 +32,8 @@ module Unison.Codebase.Path prefixNameIfRel, unprefixName, HQSplit, + HQSplitAbsolute, + AbsSplit, Split, Split', HQSplit', @@ -43,7 +47,7 @@ module Unison.Codebase.Path isRoot, isRoot', - -- * things that could be replaced with `Convert` instances + -- * conversions absoluteToPath', fromList, fromName, @@ -56,15 +60,15 @@ module Unison.Codebase.Path toList, toName, toName', - unsafeToName, - unsafeToName', toText, toText', + absToText, + relToText, unsplit, unsplit', unsplitAbsolute, - unsplitHQ, - unsplitHQ', + nameFromHQSplit, + nameFromHQSplit', nameFromSplit', splitFromName, splitFromName', @@ -76,8 +80,6 @@ module Unison.Codebase.Path -- * things that could be replaced with `Snoc` instances snoc, unsnoc, - -- This should be moved to a common util module, or we could use the 'witch' package. - Convert (..), ) where @@ -92,15 +94,20 @@ import Data.Sequence (Seq ((:<|), (:|>))) import Data.Sequence qualified as Seq import Data.Text qualified as Text import GHC.Exts qualified as GHC -import Unison.HashQualified' qualified as HQ' -import Unison.Name (Convert (..), Name) +import Unison.HashQualifiedPrime qualified as HQ' +import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.Prelude hiding (empty, toList) import Unison.Syntax.Name qualified as Name (toText, unsafeParseText) import Unison.Util.List qualified as List --- `Foo.Bar.baz` becomes ["Foo", "Bar", "baz"] +-- | A `Path` is an internal structure representing some namespace in the codebase. +-- +-- @Foo.Bar.baz@ becomes @["Foo", "Bar", "baz"]@. +-- +-- __NB__: This shouldn’t be exposed outside of this module (prefer`Path'`, `Absolute`, or `Relative`), but it’s +-- currently used pretty widely. Such usage should be replaced when encountered. newtype Path = Path {toSeq :: Seq NameSegment} deriving stock (Eq, Ord) deriving newtype (Semigroup, Monoid) @@ -112,10 +119,20 @@ instance GHC.IsList Path where toList (Path segs) = Foldable.toList segs fromList = Path . Seq.fromList +-- | An absolute from the current project root newtype Absolute = Absolute {unabsolute :: Path} deriving (Eq, Ord) +absPath_ :: Lens' Absolute Path +absPath_ = lens unabsolute (\_ new -> Absolute new) + +-- | A namespace path that doesn’t necessarily start from the root. +-- Typically refers to a path from the current namespace. newtype Relative = Relative {unrelative :: Path} deriving (Eq, Ord) +relPath_ :: Lens' Relative Path +relPath_ = lens unrelative (\_ new -> Relative new) + +-- | A namespace that may be either absolute or relative, This is the most general type that should be used. newtype Path' = Path' {unPath' :: Either Absolute Relative} deriving (Eq, Ord) @@ -144,14 +161,14 @@ absoluteToPath' = AbsolutePath' instance Show Path' where show = \case - AbsolutePath' abs -> show abs - RelativePath' rel -> show rel + AbsolutePath' abs -> Text.unpack $ absToText abs + RelativePath' rel -> Text.unpack $ relToText rel instance Show Absolute where - show s = "." ++ show (unabsolute s) + show s = Text.unpack $ absToText s instance Show Relative where - show = show . unrelative + show = Text.unpack . relToText unsplit' :: Split' -> Path' unsplit' = \case @@ -165,11 +182,13 @@ unsplitAbsolute :: (Absolute, NameSegment) -> Absolute unsplitAbsolute = coerce unsplit -unsplitHQ :: HQSplit -> HQ'.HashQualified Path -unsplitHQ (p, a) = fmap (snoc p) a +nameFromHQSplit :: HQSplit -> HQ'.HashQualified Name +nameFromHQSplit = nameFromHQSplit' . first (RelativePath' . Relative) -unsplitHQ' :: HQSplit' -> HQ'.HashQualified Path' -unsplitHQ' (p, a) = fmap (snoc' p) a +nameFromHQSplit' :: HQSplit' -> HQ'.HashQualified Name +nameFromHQSplit' (p, a) = fmap (nameFromSplit' . (p,)) a + +type AbsSplit = (Absolute, NameSegment) type Split = (Path, NameSegment) @@ -310,9 +329,6 @@ cons = Lens.cons snoc :: Path -> NameSegment -> Path snoc = Lens.snoc -snoc' :: Path' -> NameSegment -> Path' -snoc' = Lens.snoc - unsnoc :: Path -> Maybe (Path, NameSegment) unsnoc = Lens.unsnoc @@ -338,15 +354,6 @@ fromName' n where path = fromName n -unsafeToName :: Path -> Name -unsafeToName = - fromMaybe (error "empty path") . toName - --- | Convert a Path' to a Name -unsafeToName' :: Path' -> Name -unsafeToName' = - fromMaybe (error "empty path") . toName' - toName :: Path -> Maybe Name toName = \case Path Seq.Empty -> Nothing @@ -376,11 +383,29 @@ empty = Path mempty instance Show Path where show = Text.unpack . toText +instance From Path Text where + from = toText + +instance From Absolute Text where + from = absToText + +instance From Relative Text where + from = relToText + +instance From Path' Text where + from = toText' + -- | Note: This treats the path as relative. toText :: Path -> Text toText = maybe Text.empty Name.toText . toName +absToText :: Absolute -> Text +absToText abs = "." <> toText (unabsolute abs) + +relToText :: Relative -> Text +relToText rel = toText (unrelative rel) + unsafeParseText :: Text -> Path unsafeParseText = \case "" -> empty @@ -517,6 +542,9 @@ instance Resolve Absolute Relative Absolute where instance Resolve Absolute Relative Path' where resolve l r = AbsolutePath' (resolve l r) +instance Resolve Absolute Path Absolute where + resolve (Absolute l) r = Absolute (resolve l r) + instance Resolve Path' Path' Path' where resolve _ a@(AbsolutePath' {}) = a resolve (AbsolutePath' a) (RelativePath' r) = AbsolutePath' (resolve a r) @@ -534,34 +562,3 @@ instance Resolve Absolute HQSplit HQSplitAbsolute where instance Resolve Absolute Path' Absolute where resolve _ (AbsolutePath' a) = a resolve a (RelativePath' r) = resolve a r - -instance Convert Absolute Path where convert = unabsolute - -instance Convert Absolute Path' where convert = absoluteToPath' - -instance Convert Absolute Text where convert = toText' . absoluteToPath' - -instance Convert Relative Text where convert = toText . unrelative - -instance Convert Absolute String where convert = Text.unpack . convert - -instance Convert Relative String where convert = Text.unpack . convert - -instance Convert [NameSegment] Path where convert = fromList - -instance Convert Path [NameSegment] where convert = toList - -instance Convert HQSplit (HQ'.HashQualified Path) where convert = unsplitHQ - -instance Convert HQSplit' (HQ'.HashQualified Path') where convert = unsplitHQ' - -instance Convert Name Split where - convert = splitFromName - -instance Convert (path, NameSegment) (path, HQ'.HQSegment) where - convert (path, name) = - (path, HQ'.fromName name) - -instance (Convert path0 path1) => Convert (path0, name) (path1, name) where - convert = - over _1 convert diff --git a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs index e5411d4ad3..79bb738e6d 100644 --- a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs +++ b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs @@ -22,7 +22,7 @@ import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P (char) import Text.Megaparsec.Internal qualified as P (withParsecT) import Unison.Codebase.Path -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Prelude hiding (empty, toList) import Unison.ShortHash (ShortHash) import Unison.Syntax.Lexer qualified as Lexer diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs new file mode 100644 index 0000000000..651f7f2ca5 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -0,0 +1,136 @@ +module Unison.Codebase.ProjectPath + ( ProjectPathG (..), + ProjectPathIds, + ProjectPathNames, + ProjectPath, + fromProjectAndBranch, + projectBranchRoot, + toRoot, + absPath_, + path_, + path, + toProjectAndBranch, + projectAndBranch_, + toText, + toIds, + toNames, + projectPathParser, + parseProjectPath, + + -- * Re-exports, this also helps with using dot-notation + ProjectAndBranch (..), + Project (..), + ProjectBranch (..), + ) +where + +import Control.Lens hiding (from) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bitraversable (Bitraversable (..)) +import Data.Text qualified as Text +import Text.Megaparsec qualified as Megaparsec +import Text.Megaparsec.Char qualified as Megaparsec +import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import Unison.Codebase.Path qualified as Path +import Unison.Codebase.Path.Parse qualified as Path +import Unison.Prelude +import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) +import Unison.Project qualified as Project + +data ProjectPathG proj branch = ProjectPath + { project :: proj, + branch :: branch, + absPath :: Path.Absolute + } + deriving stock (Eq, Functor, Ord, Show, Generic) + +type ProjectPathIds = ProjectPathG ProjectId ProjectBranchId + +type ProjectPathNames = ProjectPathG ProjectName ProjectBranchName + +instance From ProjectPath Text where + from = from . toNames + +instance From ProjectPathNames Text where + from (ProjectPath proj branch (Path.Absolute path)) = + into @Text (ProjectAndBranch proj branch) <> ":" <> Path.toText path + +instance From (ProjectPathG () ProjectBranchName) Text where + from (ProjectPath () branch (Path.Absolute path)) = + "/" <> into @Text branch <> ":" <> Path.toText path + +type ProjectPath = ProjectPathG Project ProjectBranch + +projectBranchRoot :: ProjectAndBranch Project ProjectBranch -> ProjectPath +projectBranchRoot (ProjectAndBranch proj branch) = ProjectPath proj branch Path.absoluteEmpty + +-- | Discard any path within the project and get the project's root +toRoot :: ProjectPath -> ProjectPath +toRoot (ProjectPath proj branch _) = ProjectPath proj branch Path.absoluteEmpty + +fromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPath +fromProjectAndBranch (ProjectAndBranch proj branch) path = ProjectPath proj branch path + +-- | Project a project context into a project path of just IDs +toIds :: ProjectPath -> ProjectPathIds +toIds (ProjectPath proj branch path) = ProjectPath (proj ^. #projectId) (branch ^. #branchId) path + +-- | Project a project context into a project path of just names +toNames :: ProjectPath -> ProjectPathNames +toNames (ProjectPath proj branch path) = ProjectPath (proj ^. #name) (branch ^. #name) path + +toProjectAndBranch :: ProjectPathG p b -> ProjectAndBranch p b +toProjectAndBranch (ProjectPath proj branch _) = ProjectAndBranch proj branch + +instance Bifunctor ProjectPathG where + bimap f g (ProjectPath p b path) = ProjectPath (f p) (g b) path + +instance Bifoldable ProjectPathG where + bifoldMap f g (ProjectPath p b _) = f p <> g b + +instance Bitraversable ProjectPathG where + bitraverse f g (ProjectPath p b path) = ProjectPath <$> f p <*> g b <*> pure path + +toText :: ProjectPathG Project ProjectBranch -> Text +toText (ProjectPath proj branch path) = + into @Text (proj ^. #name) <> "/" <> into @Text (branch ^. #name) <> ":" <> Path.absToText path + +absPath_ :: Lens' (ProjectPathG p b) Path.Absolute +absPath_ = lens absPath set + where + set (ProjectPath n b _) p = ProjectPath n b p + +path :: (ProjectPathG p b) -> Path.Path +path (ProjectPath _ _ p) = Path.unabsolute p + +path_ :: Lens' (ProjectPathG p b) Path.Path +path_ = absPath_ . Path.absPath_ + +projectAndBranch_ :: Lens (ProjectPathG p b) (ProjectPathG p' b') (ProjectAndBranch p b) (ProjectAndBranch p' b') +projectAndBranch_ = lens go set + where + go (ProjectPath proj branch _) = ProjectAndBranch proj branch + set (ProjectPath _ _ p) (ProjectAndBranch proj branch) = ProjectPath proj branch p + +type Parser = Megaparsec.Parsec Void Text + +projectPathParser :: Parser ProjectPathNames +projectPathParser = do + (projName, hasTrailingSlash) <- Project.projectNameParser + projBranchName <- Project.projectBranchNameParser (not hasTrailingSlash) + _ <- Megaparsec.char ':' + path' >>= \case + Path.AbsolutePath' p -> pure $ ProjectPath projName projBranchName p + Path.RelativePath' {} -> fail "Expected an absolute path" + where + path' :: Parser Path.Path' + path' = do + pathStr <- Megaparsec.takeRest + case Path.parsePath' (Text.unpack pathStr) of + Left err -> fail (Text.unpack err) + Right x -> pure x + +parseProjectPath :: Text -> Either Text ProjectPathNames +parseProjectPath txt = first (Text.pack . Megaparsec.errorBundlePretty) $ Megaparsec.parse projectPathParser "" txt diff --git a/parser-typechecker/src/Unison/Codebase/RootBranchCache.hs b/parser-typechecker/src/Unison/Codebase/RootBranchCache.hs deleted file mode 100644 index ab092c8031..0000000000 --- a/parser-typechecker/src/Unison/Codebase/RootBranchCache.hs +++ /dev/null @@ -1,110 +0,0 @@ -module Unison.Codebase.RootBranchCache - ( RootBranchCache, - newEmptyRootBranchCache, - newEmptyRootBranchCacheIO, - fetchRootBranch, - withLock, - ) -where - -import Control.Concurrent.STM (newTVarIO) -import Control.Monad (join) -import Control.Monad.IO.Class -import Data.Coerce (coerce) -import Unison.Codebase.Branch.Type (Branch) -import Unison.Sqlite qualified as Sqlite -import UnliftIO (MonadUnliftIO, mask, onException) -import UnliftIO.STM - ( STM, - TVar, - atomically, - newTVar, - readTVar, - retrySTM, - writeTVar, - ) - -data RootBranchCacheVal - = Empty - | -- | Another thread is updating the cache. If this value is observed - -- then the reader should wait until the value is Empty or Full. The - -- api exposed from this module guarantees that a thread cannot exit - -- and leave the cache in this state. - ConcurrentModification - | Full (Branch Sqlite.Transaction) - --- This is isomorphic to @TMVar (Maybe (Branch Sqlite.Transaction))@ -newtype RootBranchCache = RootBranchCache (TVar RootBranchCacheVal) - -newEmptyRootBranchCacheIO :: (MonadIO m) => m RootBranchCache -newEmptyRootBranchCacheIO = liftIO (coerce $ newTVarIO Empty) - -newEmptyRootBranchCache :: STM RootBranchCache -newEmptyRootBranchCache = coerce (newTVar Empty) - -readRbc :: RootBranchCache -> STM RootBranchCacheVal -readRbc (RootBranchCache v) = readTVar v - -writeRbc :: RootBranchCache -> RootBranchCacheVal -> STM () -writeRbc (RootBranchCache v) x = writeTVar v x - --- | Read the root branch cache, wait if the cache is currently being --- updated -readRootBranchCache :: RootBranchCache -> STM (Maybe (Branch Sqlite.Transaction)) -readRootBranchCache v = - readRbc v >>= \case - Empty -> pure Nothing - ConcurrentModification -> retrySTM - Full x -> pure (Just x) - -fetchRootBranch :: forall m. (MonadUnliftIO m) => RootBranchCache -> m (Branch Sqlite.Transaction) -> m (Branch Sqlite.Transaction) -fetchRootBranch rbc getFromDb = mask \restore -> do - join (atomically (fetch restore)) - where - fetch :: (forall x. m x -> m x) -> STM (m (Branch Sqlite.Transaction)) - fetch restore = do - readRbc rbc >>= \case - Empty -> do - writeRbc rbc ConcurrentModification - pure do - rootBranch <- restore getFromDb `onException` atomically (writeRbc rbc Empty) - atomically (writeRbc rbc (Full rootBranch)) - pure rootBranch - ConcurrentModification -> retrySTM - Full x -> pure (pure x) - --- | Take a cache lock so that no other thread can read or write to --- the cache, perform an action with the cached value, then restore --- the cache to Empty or Full -withLock :: - forall m r. - (MonadUnliftIO m) => - RootBranchCache -> - -- | Perform an action with the cached value - ( -- restore masking state - (forall x. m x -> m x) -> - -- value retrieved from cache - Maybe (Branch Sqlite.Transaction) -> - m r - ) -> - -- | compute value to restore to the cache - (r -> Maybe (Branch Sqlite.Transaction)) -> - m r -withLock v f g = mask \restore -> do - mbranch <- atomically (takeLock v) - r <- f restore mbranch `onException` releaseLock mbranch - releaseLock (g r) - pure r - where - releaseLock :: Maybe (Branch Sqlite.Transaction) -> m () - releaseLock mbranch = - let !val = case mbranch of - Nothing -> Empty - Just x -> Full x - in atomically (writeRbc v val) - -takeLock :: RootBranchCache -> STM (Maybe (Branch Sqlite.Transaction)) -takeLock v = do - res <- readRootBranchCache v - writeRbc v ConcurrentModification - pure res diff --git a/parser-typechecker/src/Unison/Codebase/Runtime.hs b/parser-typechecker/src/Unison/Codebase/Runtime.hs index 2669df121f..f790076f27 100644 --- a/parser-typechecker/src/Unison/Codebase/Runtime.hs +++ b/parser-typechecker/src/Unison/Codebase/Runtime.hs @@ -29,6 +29,13 @@ type Error = P.Pretty P.ColorText type Term v = Term.Term v () +data CompileOpts = COpts + { profile :: Bool + } + +defaultCompileOpts :: CompileOpts +defaultCompileOpts = COpts {profile = False} + data Runtime v = Runtime { terminate :: IO (), evaluate :: @@ -37,6 +44,7 @@ data Runtime v = Runtime Term v -> IO (Either Error ([Error], Term v)), compileTo :: + CompileOpts -> CL.CodeLookup v IO () -> PPE.PrettyPrintEnv -> Reference -> diff --git a/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs b/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs index 7e8b40e75b..2872ec53d2 100644 --- a/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs +++ b/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs @@ -10,6 +10,7 @@ where import Data.Set qualified as Set import Data.Text qualified as Text +import U.Codebase.HashTags (CausalHash (unCausalHash)) import U.Util.Base32Hex qualified as Base32Hex import Unison.Hash qualified as Hash import Unison.Prelude @@ -24,9 +25,9 @@ toString = Text.unpack . toText toHash :: (Coercible Hash.Hash h) => ShortCausalHash -> Maybe h toHash = fmap coerce . Hash.fromBase32HexText . toText -fromHash :: (Coercible h Hash.Hash) => Int -> h -> ShortCausalHash +fromHash :: Int -> CausalHash -> ShortCausalHash fromHash len = - ShortCausalHash . Text.take len . Hash.toBase32HexText . coerce + ShortCausalHash . Text.take len . Hash.toBase32HexText . unCausalHash -- | This allows a full hash to be preserved as a `ShortCausalHash`. -- @@ -47,3 +48,6 @@ fromText _ = Nothing instance Show ShortCausalHash where show (ShortCausalHash h) = '#' : Text.unpack h + +instance From ShortCausalHash Text where + from = toText diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 18f21330e2..e4d363b4c0 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -12,22 +12,10 @@ module Unison.Codebase.SqliteCodebase ) where -import Control.Monad.Except qualified as Except -import Control.Monad.Extra qualified as Monad import Data.Either.Extra () -import Data.IORef import Data.Map qualified as Map -import Data.Set qualified as Set -import Data.Time (getCurrentTime) -import System.Console.ANSI qualified as ANSI import System.FileLock (SharedExclusive (Exclusive), withTryFileLock) -import U.Codebase.HashTags (CausalHash, PatchHash (..)) -import U.Codebase.Reflog qualified as Reflog -import U.Codebase.Sqlite.Operations qualified as Ops -import U.Codebase.Sqlite.Queries qualified as Q -import U.Codebase.Sqlite.Sync22 qualified as Sync22 -import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) -import U.Codebase.Sync qualified as Sync +import U.Codebase.HashTags (CausalHash) import Unison.Codebase (Codebase, CodebasePath) import Unison.Codebase qualified as Codebase1 import Unison.Codebase.Branch (Branch (..)) @@ -37,14 +25,10 @@ import Unison.Codebase.Init qualified as Codebase import Unison.Codebase.Init.CreateCodebaseError qualified as Codebase1 import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..)) import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase1 -import Unison.Codebase.RootBranchCache import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache) -import Unison.Codebase.SqliteCodebase.Branch.Dependencies qualified as BD -import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.Codebase.SqliteCodebase.Migrations qualified as Migrations import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps import Unison.Codebase.SqliteCodebase.Paths -import Unison.Codebase.SqliteCodebase.SyncEphemeral qualified as SyncEphemeral import Unison.Codebase.Type (LocalOrRemote (..)) import Unison.Codebase.Type qualified as C import Unison.DataDeclaration (Decl) @@ -59,15 +43,16 @@ import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Term (Term) import Unison.Type (Type) -import Unison.Util.Timing (time) +import Unison.Util.Cache qualified as Cache import Unison.WatchKind qualified as UF -import UnliftIO (UnliftIO (..), finally) -import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) +import UnliftIO (finally) +import UnliftIO qualified as UnliftIO +import UnliftIO.Concurrent qualified as UnliftIO +import UnliftIO.Directory (createDirectoryIfMissing, doesFileExist) import UnliftIO.STM -debug, debugProcessBranches :: Bool +debug :: Bool debug = False -debugProcessBranches = False init :: (HasCallStack, MonadUnliftIO m) => @@ -106,8 +91,7 @@ createCodebaseOrError onCreate debugName path lockOption action = do withConnection (debugName ++ ".createSchema") path \conn -> do Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL Sqlite.runTransaction conn do - Q.createSchema - void . Ops.saveRootBranch v2HashHandle $ Cv.causalbranch1to2 Branch.empty + CodebaseOps.createSchema onCreate sqliteCodebase debugName path Local lockOption DontMigrate action >>= \case @@ -130,14 +114,6 @@ withCodebaseOrError debugName dir lockOption migrationStrategy action = do False -> pure (Left Codebase1.OpenCodebaseDoesntExist) True -> sqliteCodebase debugName dir Local lockOption migrationStrategy action -initSchemaIfNotExist :: (MonadIO m) => FilePath -> m () -initSchemaIfNotExist path = liftIO do - unlessM (doesDirectoryExist $ makeCodebaseDirPath path) $ - createDirectoryIfMissing True (makeCodebaseDirPath path) - unlessM (doesFileExist $ makeCodebasePath path) $ - withConnection "initSchemaIfNotExist" path \conn -> - Sqlite.runTransaction conn Q.createSchema - -- 1) buffer up the component -- 2) in the event that the component is complete, then what? -- * can write component provided all of its dependency components are complete. @@ -167,8 +143,17 @@ sqliteCodebase :: (Codebase m Symbol Ann -> m r) -> m (Either Codebase1.OpenCodebaseError r) sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action = handleLockOption do - rootBranchCache <- newEmptyRootBranchCacheIO - branchCache <- newBranchCache + -- The branchLoadCache ephemerally caches branches in memory, but doesn't prevent them from being GC'd. + -- This is very useful when loading root branches because the cache shouldn't be limited in size. + -- But this cache will automatically clean itself up and remove entries that are no longer reachable. + -- If you load another branch, which shares namespaces with another branch that's in memory (and therefor in the cache) + -- then those shared namespaces will be loaded from the cache and will be shared in memory. + branchLoadCache <- newBranchCache + -- The rootBranchCache is a semispace cache which keeps the most recent branch roots (e.g. project roots) alive in memory. + -- Unlike the branchLoadCache, this cache is bounded in size and will evict older branches when it reaches its limit. + -- The two work in tandem, so the rootBranchCache keeps relevant branches alive, and the branchLoadCache + -- stores ALL the subnamespaces of those branches, deduping them when loading from the DB. + rootBranchCache <- Cache.semispaceCache 10 getDeclType <- CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType -- The v1 codebase interface has operations to read and write individual definitions -- whereas the v2 codebase writes them as complete components. These two fields buffer @@ -238,66 +223,28 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action putTypeDeclarationComponent = CodebaseOps.putTypeDeclarationComponent termBuffer declBuffer - getRootBranch :: m (Branch m) - getRootBranch = - Branch.transform runTransaction - <$> fetchRootBranch - rootBranchCache - (runTransaction (CodebaseOps.uncachedLoadRootBranch branchCache getDeclType)) - - putRootBranch :: Text -> Branch m -> m () - putRootBranch reason branch1 = do - now <- liftIO getCurrentTime - withRunInIO \runInIO -> do - -- this is naughty, the type says Transaction but it - -- won't run automatically with whatever Transaction - -- it is composed into unless the enclosing - -- Transaction is applied to the same db connection. - let branch1Trans = Branch.transform (Sqlite.unsafeIO . runInIO) branch1 - putRootBranchTrans :: Sqlite.Transaction () = do - let emptyCausalHash = Branch.headHash Branch.empty - fromRootCausalHash <- fromMaybe emptyCausalHash <$> Ops.loadRootCausalHash - let toRootCausalHash = Branch.headHash branch1 - CodebaseOps.putRootBranch branch1Trans - Ops.appendReflog (Reflog.Entry {time = now, fromRootCausalHash, toRootCausalHash, reason}) - - -- We need to update the database and the cached - -- value. We want to keep these in sync, so we take - -- the cache lock while updating sqlite. - withLock - rootBranchCache - (\restore _ -> restore $ runInIO $ runTransaction putRootBranchTrans) - (\_ -> Just branch1Trans) - -- if this blows up on cromulent hashes, then switch from `hashToHashId` -- to one that returns Maybe. getBranchForHash :: CausalHash -> m (Maybe (Branch m)) - getBranchForHash h = - fmap (Branch.transform runTransaction) <$> runTransaction (CodebaseOps.getBranchForHash branchCache getDeclType h) + getBranchForHash = + Cache.applyDefined rootBranchCache \h -> do + fmap (Branch.transform runTransaction) <$> runTransaction (CodebaseOps.getBranchForHash branchLoadCache getDeclType h) putBranch :: Branch m -> m () putBranch branch = withRunInIO \runInIO -> - runInIO (runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch))) - - syncFromDirectory :: Codebase1.CodebasePath -> Branch m -> m () - syncFromDirectory srcRoot b = - withConnection (debugName ++ ".sync.src") srcRoot \srcConn -> - withConn \destConn -> do - progressStateRef <- liftIO (newIORef emptySyncProgressState) - Sqlite.runReadOnlyTransaction srcConn \runSrc -> - Sqlite.runWriteTransaction destConn \runDest -> do - syncInternal (syncProgress progressStateRef) runSrc runDest b - - syncToDirectory :: Codebase1.CodebasePath -> Branch m -> m () - syncToDirectory destRoot b = - withConn \srcConn -> - withConnection (debugName ++ ".sync.dest") destRoot \destConn -> do - progressStateRef <- liftIO (newIORef emptySyncProgressState) - initSchemaIfNotExist destRoot - Sqlite.runReadOnlyTransaction srcConn \runSrc -> - Sqlite.runWriteTransaction destConn \runDest -> do - syncInternal (syncProgress progressStateRef) runSrc runDest b + runInIO $ do + Cache.insert rootBranchCache (Branch.headHash branch) branch + runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch)) + + preloadBranch :: CausalHash -> m () + preloadBranch h = do + void . UnliftIO.forkIO $ void $ do + getBranchForHash h >>= \case + Nothing -> pure () + Just b -> do + UnliftIO.evaluate b + pure () getWatch :: UF.WatchKind -> Reference.Id -> Sqlite.Transaction (Maybe (Term Symbol Ann)) getWatch = @@ -334,12 +281,8 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action putTypeDeclaration, putTypeDeclarationComponent, getTermComponentWithTypes, - getRootBranch, - putRootBranch, getBranchForHash, putBranch, - syncFromDirectory, - syncToDirectory, getWatch, termsOfTypeImpl, termsMentioningTypeImpl, @@ -347,7 +290,8 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action filterTermsByReferentIdHavingTypeImpl, termReferentsByPrefix = referentsByPrefix, withConnection = withConn, - withConnectionIO = withConnection debugName root + withConnectionIO = withConnection debugName root, + preloadBranch } Right <$> action codebase where @@ -366,79 +310,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action Nothing -> Left OpenCodebaseFileLockFailed Just x -> x -syncInternal :: - forall m. - (MonadUnliftIO m) => - Sync.Progress m Sync22.Entity -> - (forall a. Sqlite.Transaction a -> m a) -> - (forall a. Sqlite.Transaction a -> m a) -> - Branch m -> - m () -syncInternal progress runSrc runDest b = time "syncInternal" do - UnliftIO runInIO <- askUnliftIO - - let syncEnv = Sync22.Env runSrc runDest (16 * 1024 * 1024) - -- we want to use sync22 wherever possible - -- so for each source branch, we'll check if it exists in the destination codebase - -- or if it exists in the source codebase, then we can sync22 it - -- if it doesn't exist in the dest or source branch, - -- then just use putBranch to the dest - sync <- liftIO (Sync22.sync22 v2HashHandle (Sync22.hoistEnv lift syncEnv)) - let doSync :: [Sync22.Entity] -> m () - doSync = - throwExceptT - . Except.withExceptT SyncEphemeral.Sync22Error - . Sync.sync' sync (Sync.transformProgress lift progress) - let processBranches :: [Entity m] -> m () - processBranches = \case - [] -> pure () - b0@(B h mb) : rest -> do - when debugProcessBranches do - traceM $ "processBranches " ++ show b0 - traceM $ " queue: " ++ show rest - ifM - (runDest (CodebaseOps.branchExists h)) - do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " already exists in dest db" - processBranches rest - do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in dest db" - runSrc (Q.loadCausalHashIdByCausalHash h) >>= \case - Just chId -> do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " exists in source db, so delegating to direct sync" - doSync [Sync22.C chId] - processBranches rest - Nothing -> - mb >>= \b -> do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in either db, so delegating to Codebase.putBranch" - let (branchDeps, BD.to' -> BD.Dependencies' es ts ds) = BD.fromBranch b - when debugProcessBranches do - traceM $ " branchDeps: " ++ show (fst <$> branchDeps) - traceM $ " terms: " ++ show ts - traceM $ " decls: " ++ show ds - traceM $ " edits: " ++ show es - (cs, es, ts, ds) <- runDest do - cs <- filterM (fmap not . CodebaseOps.branchExists . fst) branchDeps - es <- filterM (fmap not . CodebaseOps.patchExists) es - ts <- filterM (fmap not . CodebaseOps.termExists) ts - ds <- filterM (fmap not . CodebaseOps.declExists) ds - pure (cs, es, ts, ds) - if null cs && null es && null ts && null ds - then do - runDest (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) b)) - processBranches rest - else do - let bs = map (uncurry B) cs - os = map O (coerce @[PatchHash] @[Hash] es <> ts <> ds) - processBranches (os ++ bs ++ b0 : rest) - O h : rest -> do - when debugProcessBranches $ traceM $ "processBranches O " ++ take 10 (show h) - oId <- runSrc (Q.expectHashIdByHash h >>= Q.expectObjectIdForAnyHashId) - doSync [Sync22.O oId] - processBranches rest - let bHash = Branch.headHash b - time "SyncInternal.processBranches" $ processBranches [B bHash (pure b)] - data Entity m = B CausalHash (m (Branch m)) | O Hash @@ -447,89 +318,6 @@ instance Show (Entity m) where show (B h _) = "B " ++ take 10 (show h) show (O h) = "O " ++ take 10 (show h) -data SyncProgressState = SyncProgressState - { _needEntities :: Maybe (Set Sync22.Entity), - _doneEntities :: Either Int (Set Sync22.Entity), - _warnEntities :: Either Int (Set Sync22.Entity) - } - -emptySyncProgressState :: SyncProgressState -emptySyncProgressState = SyncProgressState (Just mempty) (Right mempty) (Right mempty) - -syncProgress :: forall m. (MonadIO m) => IORef SyncProgressState -> Sync.Progress m Sync22.Entity -syncProgress progressStateRef = Sync.Progress (liftIO . need) (liftIO . done) (liftIO . warn) (liftIO allDone) - where - quiet = False - maxTrackedHashCount = 1024 * 1024 - size :: SyncProgressState -> Int - size = \case - SyncProgressState Nothing (Left i) (Left j) -> i + j - SyncProgressState (Just need) (Right done) (Right warn) -> Set.size need + Set.size done + Set.size warn - SyncProgressState _ _ _ -> undefined - - need, done, warn :: Sync22.Entity -> IO () - need h = do - unless quiet $ Monad.whenM (readIORef progressStateRef <&> (== 0) . size) $ putStr "\n" - readIORef progressStateRef >>= \case - SyncProgressState Nothing Left {} Left {} -> pure () - SyncProgressState (Just need) (Right done) (Right warn) -> - if Set.size need + Set.size done + Set.size warn > maxTrackedHashCount - then writeIORef progressStateRef $ SyncProgressState Nothing (Left $ Set.size done) (Left $ Set.size warn) - else - if Set.member h done || Set.member h warn - then pure () - else writeIORef progressStateRef $ SyncProgressState (Just $ Set.insert h need) (Right done) (Right warn) - SyncProgressState _ _ _ -> undefined - unless quiet printSynced - - done h = do - unless quiet $ Monad.whenM (readIORef progressStateRef <&> (== 0) . size) $ putStr "\n" - readIORef progressStateRef >>= \case - SyncProgressState Nothing (Left done) warn -> - writeIORef progressStateRef $ SyncProgressState Nothing (Left (done + 1)) warn - SyncProgressState (Just need) (Right done) warn -> - writeIORef progressStateRef $ SyncProgressState (Just $ Set.delete h need) (Right $ Set.insert h done) warn - SyncProgressState _ _ _ -> undefined - unless quiet printSynced - - warn h = do - unless quiet $ Monad.whenM (readIORef progressStateRef <&> (== 0) . size) $ putStr "\n" - readIORef progressStateRef >>= \case - SyncProgressState Nothing done (Left warn) -> - writeIORef progressStateRef $ SyncProgressState Nothing done (Left $ warn + 1) - SyncProgressState (Just need) done (Right warn) -> - writeIORef progressStateRef $ SyncProgressState (Just $ Set.delete h need) done (Right $ Set.insert h warn) - SyncProgressState _ _ _ -> undefined - unless quiet printSynced - - allDone = do - readIORef progressStateRef >>= putStrLn . renderState (" " ++ "Done syncing ") - - printSynced :: IO () - printSynced = - readIORef progressStateRef >>= \s -> - finally - do ANSI.hideCursor; putStr . renderState (" " ++ "Synced ") $ s - ANSI.showCursor - - renderState :: String -> SyncProgressState -> String - renderState prefix = \case - SyncProgressState Nothing (Left done) (Left warn) -> - "\r" ++ prefix ++ show done ++ " entities" ++ if warn > 0 then " with " ++ show warn ++ " warnings." else "." - SyncProgressState (Just _need) (Right done) (Right warn) -> - "\r" - ++ prefix - ++ show (Set.size done + Set.size warn) - ++ " entities" - ++ if Set.size warn > 0 - then " with " ++ show (Set.size warn) ++ " warnings." - else "." - SyncProgressState need done warn -> - "invalid SyncProgressState " - ++ show (fmap v need, bimap id v done, bimap id v warn) - where - v = const () - -- | Given two codebase roots (e.g. "./mycodebase"), safely copy the codebase -- at the source to the destination. -- Note: this does not copy the .unisonConfig file. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index 68dc7c0a9f..9052e5511a 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -21,6 +21,7 @@ import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase import Unison.Codebase.IntegrityCheck (IntegrityResult (..), integrityCheckAllBranches, integrityCheckAllCausals, prettyPrintIntegrityErrors) import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 (migrateSchema11To12) +import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6) @@ -30,27 +31,28 @@ import Unison.Codebase.SqliteCodebase.Operations qualified as Ops2 import Unison.Codebase.SqliteCodebase.Paths (backupCodebasePath) import Unison.Codebase.Type (LocalOrRemote (..)) import Unison.ConstructorType qualified as CT +import Unison.Debug qualified as Debug import Unison.Hash (Hash) import Unison.Prelude import Unison.Sqlite qualified as Sqlite import Unison.Sqlite.Connection qualified as Sqlite.Connection import Unison.Util.Monoid (foldMapM) -import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty qualified as Pretty import UnliftIO qualified -- | Mapping from schema version to the migration required to get there. -- E.g. The migration at index 2 must be run on a codebase at version 1. migrations :: + (MVar Region.ConsoleRegion) -> -- | A 'getDeclType'-like lookup, possibly backed by a cache. (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> TVar (Map Hash Ops2.TermBufferEntry) -> TVar (Map Hash Ops2.DeclBufferEntry) -> CodebasePath -> - Map SchemaVersion (Sqlite.Transaction ()) -migrations getDeclType termBuffer declBuffer rootCodebasePath = + Map SchemaVersion (Sqlite.Connection -> IO ()) +migrations regionVar getDeclType termBuffer declBuffer rootCodebasePath = Map.fromList - [ (2, migrateSchema1To2 getDeclType termBuffer declBuffer), + [ (2, runT $ migrateSchema1To2 getDeclType termBuffer declBuffer), -- The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this -- caused an issue: -- @@ -67,30 +69,34 @@ migrations getDeclType termBuffer declBuffer rootCodebasePath = -- This migration drops all the v1 hash objects to avoid this issue, since these hash objects -- weren't being used for anything anyways. sqlMigration 3 (Q.removeHashObjectsByHashingVersion (HashVersion 1)), - (4, migrateSchema3To4), + (4, runT (migrateSchema3To4 *> runIntegrityChecks regionVar)), -- The 4 to 5 migration adds initial support for out-of-order sync i.e. Unison Share sqlMigration 5 Q.addTempEntityTables, - (6, migrateSchema5To6 rootCodebasePath), - (7, migrateSchema6To7), - (8, migrateSchema7To8), + (6, runT $ migrateSchema5To6 rootCodebasePath), + (7, runT (migrateSchema6To7 *> runIntegrityChecks regionVar)), + (8, runT migrateSchema7To8), -- Recreates the name lookup tables because the primary key was missing the root hash id. sqlMigration 9 Q.fixScopedNameLookupTables, sqlMigration 10 Q.addProjectTables, sqlMigration 11 Q.addMostRecentBranchTable, - (12, migrateSchema11To12), + (12, runT migrateSchema11To12), sqlMigration 13 Q.addMostRecentNamespaceTable, sqlMigration 14 Q.addSquashResultTable, sqlMigration 15 Q.addSquashResultTableIfNotExists, - sqlMigration 16 Q.cdToProjectRoot + sqlMigration 16 Q.cdToProjectRoot, + (17 {- This migration takes a raw sqlite connection -}, \conn -> migrateSchema16To17 conn) ] where - sqlMigration :: SchemaVersion -> Sqlite.Transaction () -> (SchemaVersion, Sqlite.Transaction ()) + runT :: Sqlite.Transaction () -> Sqlite.Connection -> IO () + runT t conn = Sqlite.runWriteTransaction conn (\run -> run t) + sqlMigration :: SchemaVersion -> Sqlite.Transaction () -> (SchemaVersion, Sqlite.Connection -> IO ()) sqlMigration ver migration = ( ver, - do - Q.expectSchemaVersion (ver - 1) - migration - Q.setSchemaVersion ver + \conn -> Sqlite.runWriteTransaction conn \run -> run + do + Q.expectSchemaVersion (ver - 1) + migration + Q.setSchemaVersion ver ) data CodebaseVersionStatus @@ -109,9 +115,9 @@ checkCodebaseIsUpToDate = do -- The highest schema that this ucm knows how to migrate to. pure $ if - | schemaVersion == Q.currentSchemaVersion -> CodebaseUpToDate - | schemaVersion < Q.currentSchemaVersion -> CodebaseRequiresMigration schemaVersion Q.currentSchemaVersion - | otherwise -> CodebaseUnknownSchemaVersion schemaVersion + | schemaVersion == Q.currentSchemaVersion -> CodebaseUpToDate + | schemaVersion < Q.currentSchemaVersion -> CodebaseRequiresMigration schemaVersion Q.currentSchemaVersion + | otherwise -> CodebaseUnknownSchemaVersion schemaVersion -- | Migrates a codebase up to the most recent version known to ucm. -- This is a No-op if it's up to date @@ -140,7 +146,7 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh Region.displayConsoleRegions do (`UnliftIO.finally` finalizeRegion) do - let migs = migrations getDeclType termBuffer declBuffer root + let migs = migrations regionVar getDeclType termBuffer declBuffer root -- The highest schema that this ucm knows how to migrate to. let highestKnownSchemaVersion = fst . head $ Map.toDescList migs currentSchemaVersion <- Sqlite.runTransaction conn Q.schemaVersion @@ -149,11 +155,10 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh when shouldPrompt do putStrLn "Press to start the migration once all other ucm processes are shutdown..." void $ liftIO getLine - ranMigrations <- - Sqlite.runWriteTransaction conn \run -> do + ranMigrations <- do + currentSchemaVersion <- Sqlite.runTransaction conn $ do -- Get the schema version again now that we're in a transaction. - currentSchemaVersion <- run Q.schemaVersion - let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs + Q.schemaVersion -- This is a bit of a hack, hopefully we can remove this when we have a more -- reliable way to freeze old migration code in time. -- The problem is that 'saveObject' has been changed to flush temp entity tables, @@ -163,48 +168,29 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh -- -- Hopefully we can remove this once we've got better methods of freezing migration -- code in time. - when (currentSchemaVersion < 5) $ run Q.addTempEntityTables - when (currentSchemaVersion < 6) $ run Q.addNamespaceStatsTables - for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do - putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..." - run migration - let ranMigrations = not (null migrationsToRun) - when ranMigrations do - region <- - UnliftIO.mask_ do - region <- Region.openConsoleRegion Region.Linear - putMVar regionVar region - pure region - result <- do - -- Ideally we'd check everything here, but certain codebases are known to have objects - -- with missing Hash Objects, we'll want to clean that up in a future migration. - -- integrityCheckAllHashObjects, - let checks = - Monoid.whenM - (currentSchemaVersion < 7) -- Only certain migrations actually make changes which reasonably need to be checked - [ integrityCheckAllBranches, - integrityCheckAllCausals - ] - - zip [(1 :: Int) ..] checks & foldMapM \(i, check) -> do - Region.setConsoleRegion - region - (Text.pack (printf "🕵️ Checking codebase integrity (step %d of %d)..." i (length checks))) - run check - case result of - NoIntegrityErrors -> pure () - IntegrityErrorDetected errs -> do - let msg = prettyPrintIntegrityErrors errs - let rendered = Pretty.toPlain 80 (Pretty.border 2 msg) - Region.setConsoleRegion region (Text.pack rendered) - run (abortMigration "Codebase integrity error detected.") - pure ranMigrations + when (currentSchemaVersion < 5) Q.addTempEntityTables + when (currentSchemaVersion < 6) Q.addNamespaceStatsTables + pure currentSchemaVersion + let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs + for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do + putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..." + migration conn + let ranMigrations = not (null migrationsToRun) + pure ranMigrations + Debug.debugLogM Debug.Migration "Migrations complete" when ranMigrations do - region <- readMVar regionVar + region <- + UnliftIO.mask_ do + region <- Region.openConsoleRegion Region.Linear + putMVar regionVar region + pure region -- Vacuum once now that any migrations have taken place. Region.setConsoleRegion region ("✅ All good, cleaning up..." :: Text) case vacuumStrategy of - Vacuum -> void $ Sqlite.Connection.vacuum conn + Vacuum -> do + Debug.debugLogM Debug.Migration "About to VACUUM" + void $ Sqlite.Connection.vacuum conn + Debug.debugLogM Debug.Migration "Done VACUUM" NoVacuum -> pure () Region.setConsoleRegion region ("🏁 Migrations complete 🏁" :: Text) @@ -224,3 +210,34 @@ backupCodebaseIfNecessary backupStrategy localOrRemote conn currentSchemaVersion Sqlite.trySetJournalMode backupConn Sqlite.JournalMode'WAL putStrLn ("📋 I backed up your codebase to " ++ (root backupPath)) putStrLn "⚠️ Please close all other ucm processes and wait for the migration to complete before interacting with your codebase." + +runIntegrityChecks :: + (MVar Region.ConsoleRegion) -> + Sqlite.Transaction () +runIntegrityChecks regionVar = do + region <- Sqlite.unsafeIO . UnliftIO.mask_ $ do + region <- Region.openConsoleRegion Region.Linear + putMVar regionVar region + pure region + result <- do + -- Ideally we'd check everything here, but certain codebases are known to have objects + -- with missing Hash Objects, we'll want to clean that up in a future migration. + -- integrityCheckAllHashObjects, + let checks = + [ integrityCheckAllBranches, + integrityCheckAllCausals + ] + + zip [(1 :: Int) ..] checks & foldMapM \(i, check) -> do + Sqlite.unsafeIO $ + Region.setConsoleRegion + region + (Text.pack (printf "🕵️ Checking codebase integrity (step %d of %d)..." i (length checks))) + check + case result of + NoIntegrityErrors -> pure () + IntegrityErrorDetected errs -> do + let msg = prettyPrintIntegrityErrors errs + let rendered = Pretty.toPlain 80 (Pretty.border 2 msg) + Sqlite.unsafeIO $ Region.setConsoleRegion region (Text.pack rendered) + (abortMigration "Codebase integrity error detected.") diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs new file mode 100644 index 0000000000..7771c08291 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17) where + +import Control.Lens +import Data.Aeson qualified as Aeson +import Data.Map qualified as Map +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.UUID (UUID) +import Data.UUID qualified as UUID +import U.Codebase.Branch.Type qualified as V2Branch +import U.Codebase.Causal qualified as V2Causal +import U.Codebase.Sqlite.DbId (CausalHashId, ProjectBranchId (..), ProjectId (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.Queries qualified as Q +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Path qualified as Path +import Unison.Codebase.SqliteCodebase.Branch.Cache qualified as BranchCache +import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps +import Unison.Codebase.SqliteCodebase.Operations qualified as Ops +import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName), ProjectName (UnsafeProjectName)) +import Unison.Debug qualified as Debug +import Unison.NameSegment (NameSegment) +import Unison.NameSegment.Internal (NameSegment (NameSegment)) +import Unison.NameSegment.Internal qualified as NameSegment +import Unison.Prelude +import Unison.Sqlite qualified as Sqlite +import Unison.Sqlite.Connection qualified as Connection +import Unison.Syntax.NameSegment qualified as NameSegment +import UnliftIO qualified +import UnliftIO qualified as UnsafeIO + +-- | This migration converts the codebase from having all projects in a single codebase root to having separate causal +-- roots for each project branch. +-- It: +-- +-- * Adds the new project reflog table +-- * Adds the project-branch head as a causal-hash-id column on the project-branch table, and populates it from all the projects in the project root. +-- * Makes a new legacy project from the existing root branch (minus .__projects) +-- * Adds a new scratch/main project +-- * Adds a currentProjectPath table to replace the most-recent-path functionality. +-- +-- It requires a Connection argument rather than working inside a Transaction because it needs to temporarily disable +-- foreign key checking, and the foreign_key pragma cannot be set within a transaction. +migrateSchema16To17 :: Sqlite.Connection -> IO () +migrateSchema16To17 conn = withDisabledForeignKeys $ do + Q.expectSchemaVersion 16 + Q.addProjectBranchReflogTable + Debug.debugLogM Debug.Migration "Adding causal hashes to project branches table." + addCausalHashesToProjectBranches + Debug.debugLogM Debug.Migration "Making legacy project from loose code." + makeLegacyProjectFromLooseCode + Debug.debugLogM Debug.Migration "Adding scratch project" + scratchMain <- + Q.loadProjectBranchByNames scratchProjectName scratchBranchName >>= \case + Just pb -> pure pb + Nothing -> do + (_, emptyCausalHashId) <- Codebase.emptyCausalHash + (_proj, pb) <- Ops.insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId + pure pb + + -- Try to set the recent project branch to what it was, default back to scratch if it doesn't exist or the user is in + -- loose code. + mayRecentProjectBranch <- runMaybeT $ do + (projectId, branchId) <- MaybeT getMostRecentProjectBranchIds + -- Make sure the project-branch still exists. + _projBranch <- MaybeT $ Q.loadProjectBranch projectId branchId + pure (projectId, branchId) + + Debug.debugLogM Debug.Migration "Adding current project path table" + Q.addCurrentProjectPathTable + Debug.debugLogM Debug.Migration "Setting current project path to scratch project" + + case mayRecentProjectBranch of + Just (projectId, branchId) -> + Q.setCurrentProjectPath projectId branchId [] + Nothing -> Q.setCurrentProjectPath scratchMain.projectId scratchMain.branchId [] + Debug.debugLogM Debug.Migration "Done migrating to version 17" + Q.setSchemaVersion 17 + where + scratchProjectName = UnsafeProjectName "scratch" + scratchBranchName = UnsafeProjectBranchName "main" + withDisabledForeignKeys :: Sqlite.Transaction r -> IO r + withDisabledForeignKeys m = do + let disable = Connection.execute conn [Sqlite.sql| PRAGMA foreign_keys=OFF |] + let enable = Connection.execute conn [Sqlite.sql| PRAGMA foreign_keys=ON |] + let action = Sqlite.runWriteTransaction conn \run -> run $ m + UnsafeIO.bracket disable (const enable) (const action) + +data ForeignKeyFailureException + = ForeignKeyFailureException + -- We leave the data as raw as possible to ensure we can display it properly rather than get decoding errors while + -- trying to display some other error. + [[Sqlite.SQLData]] + | MissingRootBranch + deriving stock (Show) + deriving anyclass (Exception) + +addCausalHashesToProjectBranches :: Sqlite.Transaction () +addCausalHashesToProjectBranches = do + Debug.debugLogM Debug.Migration "Creating new_project_branch" + -- Create the new version of the project_branch table with the causal_hash_id column. + Sqlite.execute + [Sqlite.sql| +CREATE TABLE new_project_branch ( + project_id uuid NOT NULL REFERENCES project (id), + branch_id uuid NOT NULL, + name text NOT NULL, + causal_hash_id integer NOT NULL REFERENCES causal(self_hash_id), + + primary key (project_id, branch_id), + + unique (project_id, name) +) +without rowid; +|] + rootCausalHashId <- expectNamespaceRoot + rootCh <- Q.expectCausalHash rootCausalHashId + projectsRoot <- Codebase.getShallowCausalAtPathFromRootHash rootCh (Path.singleton $ projectsNameSegment) >>= V2Causal.value + ifor_ (V2Branch.children projectsRoot) \projectIdNS projectsCausal -> do + projectId <- case projectIdNS of + UUIDNameSegment projectIdUUID -> pure $ ProjectId projectIdUUID + _ -> error $ "Invalid Project Id NameSegment:" <> show projectIdNS + Debug.debugM Debug.Migration "Migrating project" projectId + projectsBranch <- V2Causal.value projectsCausal + case (Map.lookup branchesNameSegment $ V2Branch.children projectsBranch) of + Nothing -> pure () + Just branchesCausal -> do + branchesBranch <- V2Causal.value branchesCausal + ifor_ (V2Branch.children branchesBranch) \branchIdNS projectBranchCausal -> void . runMaybeT $ do + projectBranchId <- case branchIdNS of + UUIDNameSegment branchIdUUID -> pure $ ProjectBranchId branchIdUUID + _ -> error $ "Invalid Branch Id NameSegment:" <> show branchIdNS + Debug.debugM Debug.Migration "Migrating project branch" projectBranchId + let branchCausalHash = V2Causal.causalHash projectBranchCausal + causalHashId <- lift $ Q.expectCausalHashIdByCausalHash branchCausalHash + branchName <- + MaybeT $ + Sqlite.queryMaybeCol @ProjectBranchName + [Sqlite.sql| + SELECT project_branch.name + FROM project_branch + WHERE + project_branch.project_id = :projectId + AND project_branch.branch_id = :projectBranchId + |] + -- Insert the full project branch with HEAD into the new table + lift $ + Sqlite.execute + [Sqlite.sql| + INSERT INTO new_project_branch (project_id, branch_id, name, causal_hash_id) + VALUES (:projectId, :projectBranchId, :branchName, :causalHashId) + |] + + Debug.debugLogM Debug.Migration "Deleting orphaned project branch data" + -- Delete any project branch data that don't have a matching branch in the current root. + -- This is to make sure any old or invalid project branches get cleared out and won't cause problems when we rewrite + -- foreign key references. + -- We have to do this manually since we had to disable foreign key checks to add the new column. + Sqlite.execute + [Sqlite.sql| DELETE FROM project_branch_parent AS pbp + WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbp.project_id AND npb.branch_id = pbp.branch_id) + |] + Debug.debugLogM Debug.Migration "Deleting orphaned remote mapping data" + Sqlite.execute + [Sqlite.sql| DELETE FROM project_branch_remote_mapping AS pbrp + WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbrp.local_project_id AND npb.branch_id = pbrp.local_branch_id) + |] + -- Delete any project branch rows that don't have a matching branch in the current root. + Sqlite.execute + [Sqlite.sql| + DELETE FROM most_recent_branch AS mrb + WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = mrb.project_id AND npb.branch_id = mrb.branch_id) + |] + + Debug.debugLogM Debug.Migration "Swapping old and new project branch tables" + -- Drop the old project_branch table and rename the new one to take its place. + Sqlite.execute [Sqlite.sql| DROP TABLE project_branch |] + Sqlite.execute [Sqlite.sql| ALTER TABLE new_project_branch RENAME TO project_branch |] + Debug.debugLogM Debug.Migration "Checking foreign keys" + foreignKeyErrs <- Sqlite.queryListRow [Sqlite.sql| PRAGMA foreign_key_check |] + when (not . null $ foreignKeyErrs) . Sqlite.unsafeIO . UnliftIO.throwIO $ ForeignKeyFailureException foreignKeyErrs + +makeLegacyProjectFromLooseCode :: Sqlite.Transaction () +makeLegacyProjectFromLooseCode = do + rootChId <- + Sqlite.queryOneCol @CausalHashId + [Sqlite.sql| + SELECT causal_id + FROM namespace_root + |] + rootCh <- Q.expectCausalHash rootChId + branchCache <- Sqlite.unsafeIO BranchCache.newBranchCache + getDeclType <- Sqlite.unsafeIO $ CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType + rootBranch <- + CodebaseOps.getBranchForHash branchCache getDeclType rootCh `whenNothingM` do + Sqlite.unsafeIO . UnliftIO.throwIO $ MissingRootBranch + -- Remove the hidden projects root if one existed. + let rootWithoutProjects = rootBranch & over (Branch.head_ . Branch.children) (Map.delete projectsNameSegment) + CodebaseOps.putBranch rootWithoutProjects + let legacyBranchRootHash = Branch.headHash rootWithoutProjects + legacyBranchRootHashId <- Q.expectCausalHashIdByCausalHash legacyBranchRootHash + + let findLegacyName :: Maybe Int -> Sqlite.Transaction ProjectName + findLegacyName mayN = do + let tryProjName = case mayN of + Nothing -> UnsafeProjectName "legacy" + Just n -> UnsafeProjectName $ "legacy" <> Text.pack (show n) + Q.loadProjectBranchByNames tryProjName legacyBranchName >>= \case + Nothing -> pure tryProjName + Just _ -> findLegacyName . Just $ maybe 1 succ mayN + legacyProjName <- findLegacyName Nothing + void $ Ops.insertProjectAndBranch legacyProjName legacyBranchName legacyBranchRootHashId + pure () + where + legacyBranchName = UnsafeProjectBranchName "main" + +expectNamespaceRoot :: Sqlite.Transaction CausalHashId +expectNamespaceRoot = + Sqlite.queryOneCol loadNamespaceRootSql + +loadNamespaceRootSql :: Sqlite.Sql +loadNamespaceRootSql = + [Sqlite.sql| + SELECT causal_id + FROM namespace_root + |] + +pattern UUIDNameSegment :: UUID -> NameSegment +pattern UUIDNameSegment uuid <- + ( NameSegment.toUnescapedText -> + (Text.uncons -> Just ('_', UUID.fromText . Text.map (\c -> if c == '_' then '-' else c) -> Just uuid)) + ) + where + UUIDNameSegment uuid = + NameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid))) + +projectsNameSegment :: NameSegment +projectsNameSegment = NameSegment.unsafeParseText "__projects" + +branchesNameSegment :: NameSegment +branchesNameSegment = NameSegment.unsafeParseText "branches" + +expectMostRecentNamespace :: Sqlite.Transaction [NameSegment] +expectMostRecentNamespace = + Sqlite.queryOneColCheck + [Sqlite.sql| + SELECT namespace + FROM most_recent_namespace + |] + check + where + check :: Text -> Either Q.JsonParseFailure [NameSegment] + check bytes = + case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of + Left failure -> Left (Q.JsonParseFailure {bytes, failure = Text.pack failure}) + Right namespace -> Right (map NameSegment namespace) + +getMostRecentProjectBranchIds :: Sqlite.Transaction (Maybe (ProjectId, ProjectBranchId)) +getMostRecentProjectBranchIds = do + nameSegments <- expectMostRecentNamespace + case nameSegments of + (proj : UUIDNameSegment projectId : branches : UUIDNameSegment branchId : _) + | proj == projectsNameSegment && branches == branchesNameSegment -> + pure . Just $ (ProjectId projectId, ProjectBranchId branchId) + _ -> pure Nothing diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 475e19d338..066c4c03a9 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 @@ -72,7 +73,7 @@ import Unison.Pattern qualified as Pattern import Unison.Prelude import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent -import Unison.Referent' qualified as Referent' +import Unison.ReferentPrime qualified as Referent' import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Term qualified as Term @@ -103,7 +104,7 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do log "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." log "Updating Namespace Root..." - rootCausalHashId <- Q.expectNamespaceRoot + rootCausalHashId <- expectNamespaceRoot numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] v2EmptyBranchHashInfo <- saveV2EmptyBranch watches <- @@ -115,7 +116,7 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId log "Updating Namespace Root..." - Q.setNamespaceRoot newRootCausalHashId + setNamespaceRoot newRootCausalHashId log "Rewriting old object IDs..." ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do Q.recordObjectRehash oldObjId newObjId @@ -149,6 +150,23 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do allDone = lift $ log $ "\nFinished migrating, initiating cleanup." in Sync.Progress {need, done, error = errorHandler, allDone} +expectNamespaceRoot :: Sqlite.Transaction CausalHashId +expectNamespaceRoot = + Sqlite.queryOneCol loadNamespaceRootSql + +loadNamespaceRootSql :: Sqlite.Sql +loadNamespaceRootSql = + [Sqlite.sql| + SELECT causal_id + FROM namespace_root + |] + +setNamespaceRoot :: CausalHashId -> Sqlite.Transaction () +setNamespaceRoot id = + Sqlite.queryOneCol [Sqlite.sql| SELECT EXISTS (SELECT 1 FROM namespace_root) |] >>= \case + False -> Sqlite.execute [Sqlite.sql| INSERT INTO namespace_root VALUES (:id) |] + True -> Sqlite.execute [Sqlite.sql| UPDATE namespace_root SET causal_id = :id |] + log :: String -> Sqlite.Transaction () log = Sqlite.unsafeIO . putStrLn diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs index 57dbdea27b..b68ee1541e 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs @@ -81,7 +81,7 @@ numMigrated = migrateSchema3To4 :: Sqlite.Transaction () migrateSchema3To4 = do Q.expectSchemaVersion 3 - rootCausalHashId <- Q.expectNamespaceRoot + rootCausalHashId <- expectNamespaceRoot totalCausals <- causalCount migrationState <- flip execStateT (MigrationState mempty mempty 0) $ Sync.sync migrationSync (migrationProgress totalCausals) [rootCausalHashId] let MigrationState {_canonicalBranchForCausalHashId = mapping} = migrationState @@ -98,6 +98,17 @@ migrateSchema3To4 = do SELECT count(*) FROM causal; |] +expectNamespaceRoot :: Sqlite.Transaction DB.CausalHashId +expectNamespaceRoot = + Sqlite.queryOneCol loadNamespaceRootSql + +loadNamespaceRootSql :: Sqlite.Sql +loadNamespaceRootSql = + [Sqlite.sql| + SELECT causal_id + FROM namespace_root + |] + migrationProgress :: Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) DB.CausalHashId migrationProgress totalCausals = Sync.Progress {Sync.need, Sync.done, Sync.error, Sync.allDone} diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs index 9395c3919d..2fa0205484 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6) where +import Data.Bitraversable import Data.Text qualified as Text import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) import System.FilePath (()) import U.Codebase.HashTags (CausalHash (CausalHash)) import U.Codebase.Reflog qualified as Reflog -import U.Codebase.Sqlite.Operations qualified as Ops import U.Codebase.Sqlite.Queries qualified as Q import Unison.Codebase (CodebasePath) import Unison.Hash qualified as Hash @@ -30,12 +33,21 @@ migrateCurrentReflog codebasePath = do -- so we check first to avoid triggering a bad foreign key constraint. haveFrom <- isJust <$> Q.loadCausalByCausalHash (Reflog.fromRootCausalHash oldEntry) haveTo <- isJust <$> Q.loadCausalByCausalHash (Reflog.toRootCausalHash oldEntry) - when (haveFrom && haveTo) $ Ops.appendReflog oldEntry + when (haveFrom && haveTo) $ appendReflog oldEntry Sqlite.unsafeIO . putStrLn $ "I migrated old reflog entries from " <> reflogPath <> " into the codebase; you may delete that file now if you like." where reflogPath :: FilePath reflogPath = codebasePath "reflog" + appendReflog :: Reflog.Entry CausalHash Text -> Sqlite.Transaction () + appendReflog entry = do + dbEntry <- (bitraverse Q.saveCausalHash pure) entry + Sqlite.execute + [Sqlite.sql| + INSERT INTO reflog (time, from_root_causal_id, to_root_causal_id, reason) + VALUES (@dbEntry, @, @, @) + |] + oldReflogEntries :: CodebasePath -> UTCTime -> IO [Reflog.Entry CausalHash Text] oldReflogEntries reflogPath now = ( do diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs index b62708f70c..f09ff8559c 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs @@ -4,7 +4,6 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema6To7 (migrateSchema6To7) where -import Control.Monad.Except import Control.Monad.State import U.Codebase.Branch.Type (NamespaceStats) import U.Codebase.Sqlite.DbId qualified as DB diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 98a6db75ef..050d7f5fda 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} -- | This module contains sqlite-specific operations on high-level "parser-typechecker" types all in the Transaction -- monad. @@ -16,6 +18,7 @@ import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1) import Data.Map qualified as Map import Data.Maybe (fromJust) import Data.Set qualified as Set +import Data.UUID.V4 qualified as UUID import U.Codebase.Branch qualified as V2Branch import U.Codebase.Branch.Diff (TreeDiff (TreeDiff)) import U.Codebase.Branch.Diff qualified as BranchDiff @@ -30,11 +33,14 @@ import U.Codebase.Sqlite.NamedRef qualified as S import U.Codebase.Sqlite.ObjectType qualified as OT import U.Codebase.Sqlite.Operations (NamesInPerspective (..)) import U.Codebase.Sqlite.Operations qualified as Ops +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.Project qualified as Project import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) import Unison.Builtin qualified as Builtins import Unison.Codebase.Branch (Branch (..)) +import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Patch (Patch) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path @@ -43,7 +49,7 @@ import Unison.Codebase.SqliteCodebase.Branch.Cache (BranchCache) import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorType qualified as CT -import Unison.Core.Project (ProjectBranchName, ProjectName) +import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.DataDeclaration (Decl) import Unison.DataDeclaration qualified as Decl import Unison.Hash (Hash) @@ -74,6 +80,35 @@ import Unison.Util.Set qualified as Set import Unison.WatchKind qualified as UF import UnliftIO.STM +createSchema :: Transaction () +createSchema = do + Q.runCreateSql + Q.addTempEntityTables + Q.addNamespaceStatsTables + Q.addReflogTable + Q.fixScopedNameLookupTables + Q.addProjectTables + Q.addMostRecentBranchTable + Q.addNameLookupMountTables + Q.addMostRecentNamespaceTable + Sqlite.execute insertSchemaVersionSql + Q.addSquashResultTable + Q.addCurrentProjectPathTable + Q.addProjectBranchReflogTable + Q.addProjectBranchCausalHashIdColumn + (_, emptyCausalHashId) <- emptyCausalHash + (_, ProjectBranch {projectId, branchId}) <- insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId + Q.setCurrentProjectPath projectId branchId [] + where + scratchProjectName = UnsafeProjectName "scratch" + scratchBranchName = UnsafeProjectBranchName "main" + currentSchemaVersion = Q.currentSchemaVersion + insertSchemaVersionSql = + [Sqlite.sql| + INSERT INTO schema_version (version) + VALUES (:currentSchemaVersion) + |] + ------------------------------------------------------------------------------------------------------------------------ -- Buffer entry @@ -382,25 +417,6 @@ tryFlushDeclBuffer termBuffer declBuffer = h in loop -uncachedLoadRootBranch :: - BranchCache Sqlite.Transaction -> - (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - Transaction (Branch Transaction) -uncachedLoadRootBranch branchCache getDeclType = do - causal2 <- Ops.expectRootCausal - Cv.causalbranch2to1 branchCache getDeclType causal2 - --- | Get whether the root branch exists. -getRootBranchExists :: Transaction Bool -getRootBranchExists = - isJust <$> Ops.loadRootCausalHash - -putRootBranch :: Branch Transaction -> Transaction () -putRootBranch branch1 = do - -- todo: check to see if root namespace hash has been externally modified - -- and do something (merge?) it if necessary. But for now, we just overwrite it. - void (Ops.saveRootBranch v2HashHandle (Cv.causalbranch1to2 branch1)) - -- if this blows up on cromulent hashes, then switch from `hashToHashId` -- to one that returns Maybe. getBranchForHash :: @@ -735,14 +751,34 @@ makeMaybeCachedTransaction size action = do conn <- Sqlite.unsafeGetConnection Sqlite.unsafeIO (Cache.applyDefined cache (\x -> Sqlite.unsafeUnTransaction (action x) conn) x) -insertProjectAndBranch :: Db.ProjectId -> ProjectName -> Db.ProjectBranchId -> ProjectBranchName -> Sqlite.Transaction () -insertProjectAndBranch projectId projectName branchId branchName = do - Q.insertProject projectId projectName +-- | Creates a project by name if one doesn't already exist, creates a branch in that project, then returns the project and branch ids. Fails if a branch by that name already exists in the project. +insertProjectAndBranch :: ProjectName -> ProjectBranchName -> Db.CausalHashId -> Sqlite.Transaction (Project, ProjectBranch) +insertProjectAndBranch projectName branchName chId = do + projectId <- whenNothingM (fmap Project.projectId <$> Q.loadProjectByName projectName) do + projectId <- Sqlite.unsafeIO (Db.ProjectId <$> UUID.nextRandom) + Q.insertProject projectId projectName + pure projectId + branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom) + let projectBranch = + ProjectBranch + { projectId, + branchId, + name = branchName, + parentBranchId = Nothing + } Q.insertProjectBranch - ProjectBranch - { projectId, - branchId, - name = branchName, - parentBranchId = Nothing - } + "Project Created" + chId + projectBranch Q.setMostRecentBranch projectId branchId + pure (Project {name = projectName, projectId}, ProjectBranch {projectId, name = branchName, branchId, parentBranchId = Nothing}) + +-- | Often we need to assign something to an empty causal, this ensures the empty causal +-- exists in the codebase and returns its hash. +emptyCausalHash :: Sqlite.Transaction (CausalHash, Db.CausalHashId) +emptyCausalHash = do + let emptyBranch = Branch.empty + putBranch emptyBranch + let causalHash = Branch.headHash emptyBranch + causalHashId <- Q.expectCausalHashIdByCausalHash causalHash + pure (causalHash, causalHashId) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs index 1dcbb24b27..b9247fdf70 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs @@ -2,7 +2,6 @@ module Unison.Codebase.SqliteCodebase.SyncEphemeral where import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.DbId (SchemaVersion) -import U.Codebase.Sqlite.Sync22 qualified as Sync22 import Unison.Hash (Hash) import Unison.Prelude @@ -12,8 +11,7 @@ data Dependencies = Dependencies } data Error - = Sync22Error Sync22.Error - | SrcWrongSchema SchemaVersion + = SrcWrongSchema SchemaVersion | DestWrongSchema SchemaVersion | DisappearingBranch CausalHash deriving stock (Show) diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 0b803dd73a..e7ee5ef640 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -9,14 +9,13 @@ module Unison.Codebase.Type where import U.Codebase.HashTags (CausalHash) -import U.Codebase.Reference qualified as V2 import Unison.Codebase.Branch (Branch) import Unison.CodebasePath (CodebasePath) import Unison.ConstructorType qualified as CT import Unison.DataDeclaration (Decl) import Unison.Hash (Hash) import Unison.Prelude -import Unison.Reference (Reference, TypeReference) +import Unison.Reference (Reference, TermReferenceId, TypeReference, TypeReferenceId) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.ShortHash (ShortHash) @@ -31,49 +30,38 @@ data Codebase m v a = Codebase -- -- Note that it is possible to call 'putTerm', then 'getTerm', and receive @Nothing@, per the semantics of -- 'putTerm'. - getTerm :: Reference.Id -> Sqlite.Transaction (Maybe (Term v a)), + getTerm :: TermReferenceId -> Sqlite.Transaction (Maybe (Term v a)), -- | Get the type of a user-defined term. -- -- Note that it is possible to call 'putTerm', then 'getTypeOfTermImpl', and receive @Nothing@, per the semantics of -- 'putTerm'. - getTypeOfTermImpl :: Reference.Id -> Sqlite.Transaction (Maybe (Type v a)), + getTypeOfTermImpl :: TermReferenceId -> Sqlite.Transaction (Maybe (Type v a)), -- | Get a type declaration. -- -- Note that it is possible to call 'putTypeDeclaration', then 'getTypeDeclaration', and receive @Nothing@, per the -- semantics of 'putTypeDeclaration'. - getTypeDeclaration :: Reference.Id -> Sqlite.Transaction (Maybe (Decl v a)), + getTypeDeclaration :: TypeReferenceId -> Sqlite.Transaction (Maybe (Decl v a)), -- | Get the type of a given decl. - getDeclType :: V2.Reference -> Sqlite.Transaction CT.ConstructorType, + getDeclType :: TypeReference -> Sqlite.Transaction CT.ConstructorType, -- | Enqueue the put of a user-defined term (with its type) into the codebase, if it doesn't already exist. The -- implementation may choose to delay the put until all of the term's (and its type's) references are stored as -- well. - putTerm :: Reference.Id -> Term v a -> Type v a -> Sqlite.Transaction (), + putTerm :: TermReferenceId -> Term v a -> Type v a -> Sqlite.Transaction (), putTermComponent :: Hash -> [(Term v a, Type v a)] -> Sqlite.Transaction (), -- | Enqueue the put of a type declaration into the codebase, if it doesn't already exist. The implementation may -- choose to delay the put until all of the type declaration's references are stored as well. - putTypeDeclaration :: Reference.Id -> Decl v a -> Sqlite.Transaction (), + putTypeDeclaration :: TypeReferenceId -> Decl v a -> Sqlite.Transaction (), putTypeDeclarationComponent :: Hash -> [Decl v a] -> Sqlite.Transaction (), -- getTermComponent :: Hash -> m (Maybe [Term v a]), getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term v a, Type v a)]), - -- | Get the root branch. - getRootBranch :: m (Branch m), - -- | Like 'putBranch', but also adjusts the root branch pointer afterwards. - putRootBranch :: - Text -> -- Reason for the change, will be recorded in the reflog - Branch m -> - m (), getBranchForHash :: CausalHash -> m (Maybe (Branch m)), -- | Put a branch into the codebase, which includes its children, its patches, and the branch itself, if they don't -- already exist. -- -- The terms and type declarations that a branch references must already exist in the codebase. putBranch :: Branch m -> m (), - -- | Copy a branch and all of its dependencies from the given codebase into this one. - syncFromDirectory :: CodebasePath -> Branch m -> m (), - -- | Copy a branch and all of its dependencies from this codebase into the given codebase. - syncToDirectory :: CodebasePath -> Branch m -> m (), -- | @getWatch k r@ returns watch result @t@ that was previously put by @putWatch k r t@. - getWatch :: WK.WatchKind -> Reference.Id -> Sqlite.Transaction (Maybe (Term v a)), + getWatch :: WK.WatchKind -> TermReferenceId -> Sqlite.Transaction (Maybe (Term v a)), -- | Get the set of user-defined terms-or-constructors that have the given type. termsOfTypeImpl :: Reference -> Sqlite.Transaction (Set Referent.Id), -- | Get the set of user-defined terms-or-constructors mention the given type anywhere in their signature. @@ -87,7 +75,12 @@ data Codebase m v a = Codebase -- | Acquire a new connection to the same underlying database file this codebase object connects to. withConnection :: forall x. (Sqlite.Connection -> m x) -> m x, -- | Acquire a new connection to the same underlying database file this codebase object connects to. - withConnectionIO :: forall x. (Sqlite.Connection -> IO x) -> IO x + withConnectionIO :: forall x. (Sqlite.Connection -> IO x) -> IO x, + -- | This optimization allows us to pre-fetch a branch from SQLite into the branch cache when we know we'll need it + -- soon, but not immediately. E.g. the user has switched a branch, but hasn't run any commands on it yet. + -- + -- This combinator returns immediately, but warms the cache in the background with the desired branch. + preloadBranch :: CausalHash -> m () } -- | Whether a codebase is local or remote. diff --git a/parser-typechecker/src/Unison/Codebase/UniqueTypeGuidLookup.hs b/parser-typechecker/src/Unison/Codebase/UniqueTypeGuidLookup.hs index d2e9aa5bcf..649a629cdc 100644 --- a/parser-typechecker/src/Unison/Codebase/UniqueTypeGuidLookup.hs +++ b/parser-typechecker/src/Unison/Codebase/UniqueTypeGuidLookup.hs @@ -10,6 +10,7 @@ import U.Codebase.Branch qualified as Codebase.Branch import U.Codebase.Decl qualified as Codebase.Decl import U.Codebase.Reference qualified as Codebase.Reference import U.Codebase.Sqlite.Operations qualified as Operations +import Unison.Codebase.ProjectPath (ProjectPath) import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Sqlite qualified as Sqlite @@ -21,8 +22,8 @@ import Witherable (witherM) -- For (potential) efficiency, this function accepts an argument that loads a namespace at a path, which may be backed -- by a cache. loadUniqueTypeGuid :: - ([NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) -> - [NameSegment] -> + (ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) -> + ProjectPath -> NameSegment -> Sqlite.Transaction (Maybe Text) loadUniqueTypeGuid loadNamespaceAtPath path name = diff --git a/parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs b/parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs index 0a218b0c34..0958aaf9c4 100644 --- a/parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs +++ b/parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs @@ -40,7 +40,7 @@ import Unison.Var qualified as Var -- -- Note that we can't actually tell whether the Decl was originally a record or not, so we -- include all possible accessors, but they may or may not exist in the codebase. -labeledDeclDependenciesIncludingSelfAndFieldAccessors :: Var v => TypeReference -> (DD.Decl v a) -> Set LD.LabeledDependency +labeledDeclDependenciesIncludingSelfAndFieldAccessors :: (Var v) => TypeReference -> (DD.Decl v a) -> Set LD.LabeledDependency labeledDeclDependenciesIncludingSelfAndFieldAccessors selfRef decl = DD.labeledDeclDependenciesIncludingSelf selfRef decl <> case decl of @@ -121,5 +121,6 @@ hashFieldAccessors ppe declName vars declRef dd = do dataDecls = Map.singleton declRef (void dd), effectDecls = mempty }, - termsByShortname = mempty + termsByShortname = mempty, + topLevelComponents = Map.empty } diff --git a/parser-typechecker/src/Unison/FileParsers.hs b/parser-typechecker/src/Unison/FileParsers.hs index cc02c9f736..f1c352aea8 100644 --- a/parser-typechecker/src/Unison/FileParsers.hs +++ b/parser-typechecker/src/Unison/FileParsers.hs @@ -9,20 +9,22 @@ import Control.Lens import Control.Monad.State (evalStateT) import Data.Foldable qualified as Foldable import Data.List (partition) -import Data.List.NonEmpty qualified as List.NonEmpty +import Data.List qualified as List import Data.Map qualified as Map import Data.Sequence qualified as Seq import Data.Set qualified as Set import Unison.ABT qualified as ABT import Unison.Blank qualified as Blank import Unison.Builtin qualified as Builtin -import Unison.Name qualified as Name +import Unison.ConstructorReference qualified as ConstructorReference +import Unison.Name (Name) import Unison.Names qualified as Names -import Unison.NamesWithHistory qualified as Names +import Unison.Names.ResolvesTo (ResolvesTo (..)) import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyPrintEnv.Names qualified as PPE -import Unison.Reference (Reference) +import Unison.Reference (TermReference, TypeReference) +import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Result (CompilerBug (..), Note (..), ResultT, pattern Result) import Unison.Result qualified as Result @@ -37,7 +39,10 @@ import Unison.Typechecker.TypeLookup qualified as TL import Unison.UnisonFile (definitionLocation) import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UF +import Unison.Util.Defns (Defns (..), DefnsF) import Unison.Util.List qualified as List +import Unison.Util.Map qualified as Map (upsert) +import Unison.Util.Relation (Relation) import Unison.Util.Relation qualified as Rel import Unison.Var (Var) import Unison.Var qualified as Var @@ -73,10 +78,11 @@ data ShouldUseTndr m -- * The parsing environment that was used to parse the parsed Unison file. -- * The parsed Unison file for which the typechecking environment is applicable. computeTypecheckingEnvironment :: + forall m v. (Var v, Monad m) => ShouldUseTndr m -> [Type v] -> - (Set Reference -> m (TL.TypeLookup v Ann)) -> + (DefnsF Set TermReference TypeReference -> m (TL.TypeLookup v Ann)) -> UnisonFile v -> m (Typechecker.Env v Ann) computeTypecheckingEnvironment shouldUseTndr ambientAbilities typeLookupf uf = @@ -87,52 +93,53 @@ computeTypecheckingEnvironment shouldUseTndr ambientAbilities typeLookupf uf = Typechecker.Env { ambientAbilities = ambientAbilities, typeLookup = tl, - termsByShortname = Map.empty + termsByShortname = Map.empty, + topLevelComponents = Map.empty } ShouldUseTndr'Yes parsingEnv -> do - let preexistingNames = Parser.names parsingEnv - tm = UF.typecheckingTerm uf - possibleDeps = - [ (name, shortname, r) - | (name, r) <- Rel.toList (Names.terms preexistingNames), - v <- Set.toList (Term.freeVars tm), - let shortname = Name.unsafeParseVar v, - name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments shortname) - ] - possibleRefs = Referent.toReference . view _3 <$> possibleDeps - tl <- fmap (UF.declsToTypeLookup uf <>) (typeLookupf (UF.dependencies uf <> Set.fromList possibleRefs)) - -- For populating the TDNR environment, we pick definitions - -- from the namespace and from the local file whose full name - -- has a suffix that equals one of the free variables in the file. - -- Example, the namespace has [foo.bar.baz, qux.quaffle] and - -- the file has definitons [utils.zonk, utils.blah] and - -- the file has free variables [bar.baz, zonk]. - -- - -- In this case, [foo.bar.baz, utils.zonk] are used to create - -- the TDNR environment. - let fqnsByShortName = - List.multimap $ - -- external TDNR possibilities - [ (shortname, nr) - | (name, shortname, r) <- possibleDeps, - typ <- toList $ TL.typeOfReferent tl r, - let nr = Typechecker.NamedReference name typ (Context.ReplacementRef r) - ] - <> - -- local file TDNR possibilities - [ (shortname, nr) - | (name, r) <- Rel.toList (Names.terms $ UF.toNames uf), - v <- Set.toList (Term.freeVars tm), - let shortname = Name.unsafeParseVar v, - name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments shortname), - typ <- toList $ TL.typeOfReferent tl r, - let nr = Typechecker.NamedReference name typ (Context.ReplacementRef r) - ] + let tm = UF.typecheckingTerm uf + resolveName :: Name -> Relation Name (ResolvesTo Referent) + resolveName = + Names.resolveNameIncludingNames + (Names.shadowing1 (Names.terms (UF.toNames uf)) (Names.terms (Parser.names parsingEnv))) + (Set.map Name.unsafeParseVar (UF.toTermAndWatchNames uf)) + possibleDeps = do + v <- Set.toList (Term.freeVars tm) + let shortname = Name.unsafeParseVar v + (name, ref) <- Rel.toList (resolveName shortname) + [(name, shortname, ref)] + possibleRefs = + List.foldl' + ( \acc -> \case + (_, _, ResolvesToNamespace ref0) -> + case ref0 of + Referent.Con ref _ -> acc & over #types (Set.insert (ref ^. ConstructorReference.reference_)) + Referent.Ref ref -> acc & over #terms (Set.insert ref) + (_, _, ResolvesToLocal _) -> acc + ) + (Defns Set.empty Set.empty) + possibleDeps + tl <- fmap (UF.declsToTypeLookup uf <>) (typeLookupf (UF.dependencies uf <> possibleRefs)) + let termsByShortname :: Map Name [Either Name (Typechecker.NamedReference v Ann)] + termsByShortname = + List.foldl' + ( \acc -> \case + (name, shortname, ResolvesToLocal _) -> let v = Left name in Map.upsert (maybe [v] (v :)) shortname acc + (name, shortname, ResolvesToNamespace ref) -> + case TL.typeOfReferent tl ref of + Just ty -> + let v = Right (Typechecker.NamedReference name ty (Context.ReplacementRef ref)) + in Map.upsert (maybe [v] (v :)) shortname acc + Nothing -> acc + ) + Map.empty + possibleDeps pure Typechecker.Env - { ambientAbilities = ambientAbilities, + { ambientAbilities, typeLookup = tl, - termsByShortname = fqnsByShortName + termsByShortname, + topLevelComponents = Map.empty } synthesizeFile :: diff --git a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs index 7585e6b8b9..972c55db2a 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs @@ -227,7 +227,7 @@ h2mReferent getCT = \case hashDataDecls :: (Var v) => Map v (Memory.DD.DataDeclaration v a) -> - ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)] + ResolutionResult a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)] hashDataDecls memDecls = do let hashingDecls = fmap m2hDecl memDecls hashingResult <- Hashing.hashDecls Name.unsafeParseVar hashingDecls @@ -239,7 +239,7 @@ hashDataDecls memDecls = do hashDecls :: (Var v) => Map v (Memory.DD.Decl v a) -> - ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.Decl v a)] + ResolutionResult a [(v, Memory.Reference.Id, Memory.DD.Decl v a)] hashDecls memDecls = do -- want to unwrap the decl before doing the rehashing, and then wrap it back up the same way let howToReassemble = diff --git a/parser-typechecker/src/Unison/KindInference.hs b/parser-typechecker/src/Unison/KindInference.hs index 8265f042b0..081b758690 100644 --- a/parser-typechecker/src/Unison/KindInference.hs +++ b/parser-typechecker/src/Unison/KindInference.hs @@ -79,7 +79,7 @@ inferDecls ppe declMap = -- | Break the decls into strongly connected components in reverse -- topological order -intoComponents :: forall v a. Ord v => Map Reference (Decl v a) -> [[(Reference, Decl v a)]] +intoComponents :: forall v a. (Ord v) => Map Reference (Decl v a) -> [[(Reference, Decl v a)]] intoComponents declMap = let graphInput :: [(Decl v a, Reference, [Reference])] graphInput = Map.foldrWithKey (\k a b -> (a, k, declReferences a) : b) [] declMap diff --git a/parser-typechecker/src/Unison/KindInference/Constraint/Pretty.hs b/parser-typechecker/src/Unison/KindInference/Constraint/Pretty.hs index 5f261aa2cb..27609d13f8 100644 --- a/parser-typechecker/src/Unison/KindInference/Constraint/Pretty.hs +++ b/parser-typechecker/src/Unison/KindInference/Constraint/Pretty.hs @@ -43,7 +43,7 @@ prettyArrow prec lhs rhs = in wrap (lhs <> " -> " <> rhs) prettyCyclicSolvedConstraint :: - Var v => + (Var v) => Solved.Constraint (UVar v loc) v loc -> Int -> Map (UVar v loc) (P.Pretty P.ColorText) -> @@ -62,7 +62,7 @@ prettyCyclicSolvedConstraint constraint prec nameMap visitingSet = case constrai pure (prettyArrow prec pa pb, cyclicLhs <> cyclicRhs) prettyCyclicUVarKindWorker :: - Var v => + (Var v) => Int -> UVar v loc -> Map (UVar v loc) (P.Pretty P.ColorText) -> @@ -78,11 +78,11 @@ prettyCyclicUVarKindWorker prec u nameMap visitingSet = -- | Pretty print the kind constraint on the given @UVar@. -- -- __Precondition:__ The @ConstraintMap@ is acyclic. -prettyUVarKind :: Var v => PrettyPrintEnv -> ConstraintMap v loc -> UVar v loc -> P.Pretty P.ColorText +prettyUVarKind :: (Var v) => PrettyPrintEnv -> ConstraintMap v loc -> UVar v loc -> P.Pretty P.ColorText prettyUVarKind ppe constraints uvar = ppRunner ppe constraints do prettyUVarKind' arrPrec uvar -prettyUVarKind' :: Var v => Int -> UVar v loc -> Solve v loc (P.Pretty P.ColorText) +prettyUVarKind' :: (Var v) => Int -> UVar v loc -> Solve v loc (P.Pretty P.ColorText) prettyUVarKind' prec u = find u >>= \case Nothing -> pure (prettyUnknown prec) @@ -92,7 +92,7 @@ prettyUVarKind' prec u = -- -- __Precondition:__ The @ConstraintMap@ is acyclic. prettySolvedConstraint :: - Var v => + (Var v) => PrettyPrintEnv -> ConstraintMap v loc -> Solved.Constraint (UVar v loc) v loc -> @@ -100,7 +100,7 @@ prettySolvedConstraint :: prettySolvedConstraint ppe constraints c = ppRunner ppe constraints (prettySolvedConstraint' arrPrec c) -prettySolvedConstraint' :: Var v => Int -> Solved.Constraint (UVar v loc) v loc -> Solve v loc (P.Pretty P.ColorText) +prettySolvedConstraint' :: (Var v) => Int -> Solved.Constraint (UVar v loc) v loc -> Solve v loc (P.Pretty P.ColorText) prettySolvedConstraint' prec = \case Solved.IsAbility _ -> pure (prettyAbility prec) Solved.IsType _ -> pure (prettyType prec) @@ -113,7 +113,7 @@ prettySolvedConstraint' prec = \case -- constraint map, but no constraints are added. This runner just -- allows running pretty printers outside of the @Solve@ monad by -- discarding the resulting state. -ppRunner :: Var v => PrettyPrintEnv -> ConstraintMap v loc -> (forall r. Solve v loc r -> r) +ppRunner :: (Var v) => PrettyPrintEnv -> ConstraintMap v loc -> (forall r. Solve v loc r -> r) ppRunner ppe constraints = let st = SolveState @@ -130,7 +130,7 @@ ppRunner ppe constraints = -- -- __Precondition:__ The @UVar@ has a cyclic constraint. prettyCyclicUVarKind :: - Var v => + (Var v) => PrettyPrintEnv -> ConstraintMap v loc -> UVar v loc -> diff --git a/parser-typechecker/src/Unison/KindInference/Error.hs b/parser-typechecker/src/Unison/KindInference/Error.hs index 2e977e0493..e9d0900a0a 100644 --- a/parser-typechecker/src/Unison/KindInference/Error.hs +++ b/parser-typechecker/src/Unison/KindInference/Error.hs @@ -28,7 +28,7 @@ data ConstraintConflict v loc = ConstraintConflict' conflictedConstraint :: Solved.Constraint (UVar v loc) v loc } -lspLoc :: Semigroup loc => KindError v loc -> loc +lspLoc :: (Semigroup loc) => KindError v loc -> loc lspLoc = \case CycleDetected loc _ _ -> loc UnexpectedArgument _ abs arg _ -> varLoc abs <> varLoc arg @@ -45,30 +45,30 @@ data KindError v loc CycleDetected loc (UVar v loc) (ConstraintMap v loc) | -- | Something of kind * or Effect is applied to an argument UnexpectedArgument + -- | src span of abs loc - -- ^ src span of abs + -- | abs var (UVar v loc) - -- ^ abs var + -- | arg var (UVar v loc) - -- ^ arg var - (ConstraintMap v loc) - -- ^ context + -- | context -- | An arrow kind is applied to a type, but its kind doesn't match -- the expected argument kind + (ConstraintMap v loc) | ArgumentMismatch + -- | abs var (UVar v loc) - -- ^ abs var + -- | expected var (UVar v loc) - -- ^ expected var + -- | given var (UVar v loc) - -- ^ given var - (ConstraintMap v loc) - -- ^ context + -- | context -- | Same as @ArgumentMismatch@, but for applications to the builtin -- @Arrow@ type. + (ConstraintMap v loc) | ArgumentMismatchArrow + -- | (The applied arrow range, lhs, rhs) (loc, Type v loc, Type v loc) - -- ^ (The applied arrow range, lhs, rhs) (ConstraintConflict v loc) (ConstraintMap v loc) | -- | Something appeared in an effect list that isn't of kind Effect @@ -77,22 +77,22 @@ data KindError v loc (ConstraintMap v loc) | -- | Generic constraint conflict ConstraintConflict + -- | Failed to add this constraint (GeneratedConstraint v loc) - -- ^ Failed to add this constraint + -- | Due to this conflict (ConstraintConflict v loc) - -- ^ Due to this conflict + -- | in this context (ConstraintMap v loc) - -- ^ in this context -- | Transform generic constraint conflicts into more specific error -- by examining its @ConstraintContext@. -improveError :: Var v => KindError v loc -> Solve v loc (KindError v loc) +improveError :: (Var v) => KindError v loc -> Solve v loc (KindError v loc) improveError = \case ConstraintConflict a b c -> improveError' a b c e -> pure e improveError' :: - Var v => + (Var v) => GeneratedConstraint v loc -> ConstraintConflict v loc -> ConstraintMap v loc -> diff --git a/parser-typechecker/src/Unison/KindInference/Error/Pretty.hs b/parser-typechecker/src/Unison/KindInference/Error/Pretty.hs index b1db1ac911..cf14da1ad6 100644 --- a/parser-typechecker/src/Unison/KindInference/Error/Pretty.hs +++ b/parser-typechecker/src/Unison/KindInference/Error/Pretty.hs @@ -17,7 +17,7 @@ import Unison.Var (Var) -- | Pretty print a user-facing @KindError@. prettyKindError :: - Var v => + (Var v) => -- | How to print types (Type v loc -> Pretty ColorText) -> -- | How to print source spans diff --git a/parser-typechecker/src/Unison/KindInference/Generate.hs b/parser-typechecker/src/Unison/KindInference/Generate.hs index b235108745..0886cacc4c 100644 --- a/parser-typechecker/src/Unison/KindInference/Generate.hs +++ b/parser-typechecker/src/Unison/KindInference/Generate.hs @@ -27,6 +27,7 @@ import Unison.Prelude import Unison.Reference (Reference) import Unison.Term qualified as Term import Unison.Type qualified as Type +import Unison.Util.Recursion import Unison.Var (Type (User), Var (typed), freshIn) -------------------------------------------------------------------------------- @@ -101,12 +102,12 @@ typeConstraintTree resultVar term@ABT.Term {annotation, out} = do restConstraints <- typeConstraintTree resultVar b pure $ Node [effConstraints, restConstraints] Type.Effects effs -> do - Node <$> for effs \eff -> do + ParentConstraint (IsAbility resultVar (Provenance EffectsList annotation)) . Node <$> for effs \eff -> do effKind <- freshVar eff effConstraints <- typeConstraintTree effKind eff pure $ ParentConstraint (IsAbility effKind (Provenance EffectsList $ ABT.annotation eff)) effConstraints -handleIntroOuter :: Var v => v -> loc -> (GeneratedConstraint v loc -> Gen v loc r) -> Gen v loc r +handleIntroOuter :: (Var v) => v -> loc -> (GeneratedConstraint v loc -> Gen v loc r) -> Gen v loc r handleIntroOuter v loc k = do let typ = Type.var loc v new <- freshVar typ @@ -160,7 +161,7 @@ instantiateType type0 k = -- | Process type annotations depth-first. Allows processing -- annotations with lexical scoping. dfAnns :: (loc -> Type.Type v loc -> b -> b) -> (b -> b -> b) -> b -> Term.Term v loc -> b -dfAnns annAlg cons nil = ABT.cata \ann abt0 -> case abt0 of +dfAnns annAlg cons nil = cata \(ABT.Term' _ ann abt0) -> case abt0 of ABT.Var _ -> nil ABT.Cycle x -> x ABT.Abs _ x -> x @@ -171,9 +172,9 @@ dfAnns annAlg cons nil = ABT.cata \ann abt0 -> case abt0 of -- Our rewrite signature machinery generates type annotations that are -- not well kinded. Work around this for now by stripping those -- annotations. -hackyStripAnns :: Ord v => Term.Term v loc -> Term.Term v loc +hackyStripAnns :: (Ord v) => Term.Term v loc -> Term.Term v loc hackyStripAnns = - snd . ABT.cata \ann abt0 -> case abt0 of + snd . cata \(ABT.Term' _ ann abt0) -> case abt0 of ABT.Var v -> (False, ABT.var ann v) ABT.Cycle (_, x) -> (False, ABT.cycle ann x) ABT.Abs v (_, x) -> (False, ABT.abs ann v x) @@ -188,7 +189,7 @@ hackyStripAnns = in (isHack, Term.constructor ann cref) t -> (False, ABT.tm ann (snd <$> t)) where - stripAnns = ABT.cata \ann abt0 -> case abt0 of + stripAnns = cata \(ABT.Term' _ ann abt0) -> case abt0 of ABT.Var v -> ABT.var ann v ABT.Cycle x -> ABT.cycle ann x ABT.Abs v x -> ABT.abs ann v x diff --git a/parser-typechecker/src/Unison/KindInference/Generate/Monad.hs b/parser-typechecker/src/Unison/KindInference/Generate/Monad.hs index 7b374d6efa..4271665beb 100644 --- a/parser-typechecker/src/Unison/KindInference/Generate/Monad.hs +++ b/parser-typechecker/src/Unison/KindInference/Generate/Monad.hs @@ -52,7 +52,7 @@ run :: Gen v loc a -> GenState v loc -> (a, GenState v loc) run (Gen ma) st0 = ma st0 -- | Create a unique @UVar@ associated with @typ@ -freshVar :: Var v => T.Type v loc -> Gen v loc (UVar v loc) +freshVar :: (Var v) => T.Type v loc -> Gen v loc (UVar v loc) freshVar typ = do st@GenState {unifVars, newVars} <- get let var :: Symbol @@ -63,7 +63,7 @@ freshVar typ = do pure uvar -- | Associate a fresh @UVar@ with @t@, push onto context -pushType :: Var v => T.Type v loc -> Gen v loc (UVar v loc) +pushType :: (Var v) => T.Type v loc -> Gen v loc (UVar v loc) pushType t = do GenState {typeMap} <- get (var, newTypeMap) <- @@ -75,13 +75,13 @@ pushType t = do pure var -- | Lookup the @UVar@ associated with a @Type@ -lookupType :: Var v => T.Type v loc -> Gen v loc (Maybe (UVar v loc)) +lookupType :: (Var v) => T.Type v loc -> Gen v loc (Maybe (UVar v loc)) lookupType t = do GenState {typeMap} <- get pure (NonEmpty.head <$> Map.lookup t typeMap) -- | Remove a @Type@ from the context -popType :: Var v => T.Type v loc -> Gen v loc () +popType :: (Var v) => T.Type v loc -> Gen v loc () popType t = do modify \st -> st {typeMap = del (typeMap st)} where @@ -94,7 +94,7 @@ popType t = do in Map.alter f t m -- | Helper to run an action with the given @Type@ in the context -scopedType :: Var v => T.Type v loc -> (UVar v loc -> Gen v loc r) -> Gen v loc r +scopedType :: (Var v) => T.Type v loc -> (UVar v loc -> Gen v loc r) -> Gen v loc r scopedType t m = do s <- pushType t r <- m s diff --git a/parser-typechecker/src/Unison/KindInference/Solve.hs b/parser-typechecker/src/Unison/KindInference/Solve.hs index 1bf58960f5..623152972a 100644 --- a/parser-typechecker/src/Unison/KindInference/Solve.hs +++ b/parser-typechecker/src/Unison/KindInference/Solve.hs @@ -89,7 +89,7 @@ step e st cs = Right () -> Right finalState -- | Default any unconstrained vars to @Type@ -defaultUnconstrainedVars :: Var v => SolveState v loc -> SolveState v loc +defaultUnconstrainedVars :: (Var v) => SolveState v loc -> SolveState v loc defaultUnconstrainedVars st = let newConstraints = foldl' phi (constraints st) (newUnifVars st) phi b a = U.alter a handleNothing handleJust b @@ -167,8 +167,7 @@ reduce cs0 = dbg "reduce" cs0 (go False []) -- contradictory constraint. addConstraint :: forall v loc. - Ord loc => - Var v => + (Ord loc, Var v) => GeneratedConstraint v loc -> Solve v loc (Either (KindError v loc) ()) addConstraint constraint = do @@ -200,8 +199,7 @@ addConstraint constraint = do -- satisfied. addConstraint' :: forall v loc. - Ord loc => - Var v => + (Ord loc, Var v) => UnsolvedConstraint v loc -> Solve v loc (Either (ConstraintConflict v loc) [UnsolvedConstraint v loc]) addConstraint' = \case @@ -304,7 +302,7 @@ union _unionLoc a b = do -- | Do an occurence check and return an error or the resulting solve -- state verify :: - Var v => + (Var v) => SolveState v loc -> Either (NonEmpty (KindError v loc)) (SolveState v loc) verify st = @@ -347,7 +345,7 @@ assertGen gen = do -- | occurence check and report any errors occCheck :: forall v loc. - Var v => + (Var v) => ConstraintMap v loc -> Either (NonEmpty (KindError v loc)) (ConstraintMap v loc) occCheck constraints0 = @@ -401,7 +399,7 @@ data OccCheckState v loc = OccCheckState kindErrors :: [KindError v loc] } -markVisiting :: Var v => UVar v loc -> M.State (OccCheckState v loc) CycleCheck +markVisiting :: (Var v) => UVar v loc -> M.State (OccCheckState v loc) CycleCheck markVisiting x = do OccCheckState {visitingSet, visitingStack} <- M.get case Set.member x visitingSet of @@ -420,7 +418,7 @@ markVisiting x = do } pure NoCycle -unmarkVisiting :: Var v => UVar v loc -> M.State (OccCheckState v loc) () +unmarkVisiting :: (Var v) => UVar v loc -> M.State (OccCheckState v loc) () unmarkVisiting x = M.modify \st -> st { visitingSet = Set.delete x (visitingSet st), @@ -431,7 +429,7 @@ unmarkVisiting x = M.modify \st -> addError :: KindError v loc -> M.State (OccCheckState v loc) () addError ke = M.modify \st -> st {kindErrors = ke : kindErrors st} -isSolved :: Var v => UVar v loc -> M.State (OccCheckState v loc) Bool +isSolved :: (Var v) => UVar v loc -> M.State (OccCheckState v loc) Bool isSolved x = do OccCheckState {solvedSet} <- M.get pure $ Set.member x solvedSet @@ -444,7 +442,7 @@ data CycleCheck -- Debug output helpers -------------------------------------------------------------------------------- -prettyConstraintD' :: Show loc => Var v => PrettyPrintEnv -> UnsolvedConstraint v loc -> P.Pretty P.ColorText +prettyConstraintD' :: (Show loc, Var v) => PrettyPrintEnv -> UnsolvedConstraint v loc -> P.Pretty P.ColorText prettyConstraintD' ppe = P.wrap . \case Unsolved.IsType v p -> prettyUVar ppe v <> " ~ Type" <> prettyProv p @@ -455,10 +453,10 @@ prettyConstraintD' ppe = prettyProv x = "[" <> P.string (show x) <> "]" -prettyConstraints :: Show loc => Var v => PrettyPrintEnv -> [UnsolvedConstraint v loc] -> P.Pretty P.ColorText +prettyConstraints :: (Show loc, Var v) => PrettyPrintEnv -> [UnsolvedConstraint v loc] -> P.Pretty P.ColorText prettyConstraints ppe = P.sep "\n" . map (prettyConstraintD' ppe) -prettyUVar :: Var v => PrettyPrintEnv -> UVar v loc -> P.Pretty P.ColorText +prettyUVar :: (Var v) => PrettyPrintEnv -> UVar v loc -> P.Pretty P.ColorText prettyUVar ppe (UVar s t) = TP.pretty ppe t <> " :: " <> P.prettyVar s tracePretty :: P.Pretty P.ColorText -> a -> a diff --git a/parser-typechecker/src/Unison/KindInference/Solve/Monad.hs b/parser-typechecker/src/Unison/KindInference/Solve/Monad.hs index d0d8fc58fb..21cd38b95e 100644 --- a/parser-typechecker/src/Unison/KindInference/Solve/Monad.hs +++ b/parser-typechecker/src/Unison/KindInference/Solve/Monad.hs @@ -14,6 +14,7 @@ module Unison.KindInference.Solve.Monad where import Control.Lens (Lens', (%%~)) +import Control.Monad.Fix (MonadFix (..)) import Control.Monad.Reader qualified as M import Control.Monad.State.Strict qualified as M import Data.Functor.Identity @@ -64,7 +65,7 @@ newtype Solve v loc a = Solve {unSolve :: Env -> SolveState v loc -> (a, SolveSt ( Functor, Applicative, Monad, - M.MonadFix, + MonadFix, M.MonadReader Env, M.MonadState (SolveState v loc) ) @@ -87,7 +88,7 @@ genStateL f st = } -- | Interleave constraint generation into constraint solving -runGen :: Var v => Gen v loc a -> Solve v loc a +runGen :: (Var v) => Gen v loc a -> Solve v loc a runGen gena = do st <- M.get let gena' = do @@ -103,7 +104,7 @@ runGen gena = do -- | Add a unification variable to the constarint mapping with no -- constraints. This is done on uvars created during constraint -- generation to initialize the new uvars (see 'runGen'). -addUnconstrainedVar :: Var v => UVar v loc -> Solve v loc () +addUnconstrainedVar :: (Var v) => UVar v loc -> Solve v loc () addUnconstrainedVar uvar = do st@SolveState {constraints} <- M.get let constraints' = U.insert uvar Descriptor {descriptorConstraint = Nothing} constraints @@ -124,7 +125,7 @@ emptyState = } -- | Lookup the constraints associated with a unification variable -find :: Var v => UVar v loc -> Solve v loc (Maybe (Constraint (UVar v loc) v loc)) +find :: (Var v) => UVar v loc -> Solve v loc (Maybe (Constraint (UVar v loc) v loc)) find k = do st@SolveState {constraints} <- M.get case U.lookupCanon k constraints of diff --git a/parser-typechecker/src/Unison/Parsers.hs b/parser-typechecker/src/Unison/Parsers.hs index 0e985764d9..13ce658a8a 100644 --- a/parser-typechecker/src/Unison/Parsers.hs +++ b/parser-typechecker/src/Unison/Parsers.hs @@ -78,8 +78,10 @@ unsafeParseFileBuiltinsOnly = Parser.ParsingEnv { uniqueNames = mempty, uniqueTypeGuid = \_ -> pure Nothing, - names = Builtin.names + names = Builtin.names, + maybeNamespace = Nothing, + localNamespacePrefixedTypesAndConstructors = mempty } -unsafeParseFile :: Monad m => String -> Parser.ParsingEnv m -> m (UnisonFile Symbol Ann) +unsafeParseFile :: (Monad m) => String -> Parser.ParsingEnv m -> m (UnisonFile Symbol Ann) unsafeParseFile s pEnv = unsafeGetRightFrom s <$> parseFile "" s pEnv diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage.hs b/parser-typechecker/src/Unison/PatternMatchCoverage.hs index 7a431a486a..75cd0a7ce4 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage.hs @@ -53,20 +53,19 @@ import Unison.Util.Pretty qualified as P checkMatch :: forall vt v loc m. (Pmc vt v loc m) => - -- | the match location - loc -> -- | scrutinee type Type.Type vt loc -> -- | match cases [Term.MatchCase loc (Term.Term' vt v loc)] -> -- | (redundant locations, inaccessible locations, inhabitants of uncovered refinement type) m ([loc], [loc], [Pattern ()]) -checkMatch matchLocation scrutineeType cases = do +checkMatch scrutineeType cases = do ppe <- getPrettyPrintEnv v0 <- fresh - grdtree0 <- desugarMatch matchLocation scrutineeType v0 cases + grdtree0 <- desugarMatch scrutineeType v0 cases doDebug (P.hang (title "desugared:") (prettyGrdTree (prettyPmGrd ppe) (\_ -> "") grdtree0)) (pure ()) - (uncovered, grdtree1) <- uncoverAnnotate (Set.singleton (NC.markDirty v0 $ NC.declVar v0 scrutineeType id NC.emptyNormalizedConstraints)) grdtree0 + let initialUncovered = Set.singleton (NC.markDirty v0 $ NC.declVar v0 scrutineeType id NC.emptyNormalizedConstraints) + (uncovered, grdtree1) <- uncoverAnnotate initialUncovered grdtree0 doDebug ( P.sep "\n" diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/Constraint.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/Constraint.hs index 06088b8618..10e7ed42a1 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/Constraint.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/Constraint.hs @@ -39,20 +39,20 @@ data Constraint vt v loc NegLit v PmLit | -- | Positive constraint on list element with position relative to head of list PosListHead + -- | list root v - -- ^ list root + -- | cons position (0 is head) Int - -- ^ cons position (0 is head) + -- | element variable v - -- ^ element variable | -- | Positive constraint on list element with position relative to end of list PosListTail + -- | list root v - -- ^ list root + -- | snoc position (0 is last) Int - -- ^ snoc position (0 is last) + -- | element variable v - -- ^ element variable | -- | Negative constraint on length of the list (/i.e./ the list -- may not be an element of the interval set) NegListInterval v IntervalSet diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/Desugar.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/Desugar.hs index ce015cc51b..273f1298e2 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/Desugar.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/Desugar.hs @@ -3,25 +3,22 @@ module Unison.PatternMatchCoverage.Desugar ) where -import Data.List.NonEmpty (NonEmpty (..)) import U.Core.ABT qualified as ABT import Unison.Pattern import Unison.Pattern qualified as Pattern import Unison.PatternMatchCoverage.Class -import Unison.PatternMatchCoverage.Fix import Unison.PatternMatchCoverage.GrdTree import Unison.PatternMatchCoverage.PmGrd import Unison.PatternMatchCoverage.PmLit qualified as PmLit import Unison.Term (MatchCase (..), Term', app, var) import Unison.Type (Type) import Unison.Type qualified as Type +import Unison.Util.Recursion -- | Desugar a match into a 'GrdTree' desugarMatch :: forall loc vt v m. (Pmc vt v loc m) => - -- | loc of match - loc -> -- | scrutinee type Type vt loc -> -- | scrutinee variable @@ -29,10 +26,7 @@ desugarMatch :: -- | match cases [MatchCase loc (Term' vt v loc)] -> m (GrdTree (PmGrd vt v loc) loc) -desugarMatch loc0 scrutineeType v0 cs0 = - traverse desugarClause cs0 >>= \case - [] -> pure $ Leaf loc0 - x : xs -> pure $ Fork (x :| xs) +desugarMatch scrutineeType v0 cs0 = Fork <$> traverse desugarClause cs0 where desugarClause :: MatchCase loc (Term' vt v loc) -> m (GrdTree (PmGrd vt v loc) loc) desugarClause MatchCase {matchPattern, matchGuard} = @@ -120,32 +114,31 @@ listToGrdTree :: [v] -> m (GrdTree (PmGrd vt v loc) loc) listToGrdTree _listTyp elemTyp listVar nl0 k0 vs0 = - let (minLen, maxLen) = countMinListLen nl0 - in Grd (PmListInterval listVar minLen maxLen) <$> go 0 0 nl0 k0 vs0 + let (minLen, maxLen) = cata countMinListLen nl0 0 + in Grd (PmListInterval listVar minLen maxLen) <$> cata go nl0 0 0 k0 vs0 where - go consCount snocCount (Fix pat) k vs = case pat of + go pat consCount snocCount k vs = case pat of N'ConsF x xs -> do element <- fresh let grd = PmListHead listVar consCount element elemTyp let !consCount' = consCount + 1 - Grd grd <$> desugarPattern elemTyp element x (go consCount' snocCount xs k) vs + Grd grd <$> desugarPattern elemTyp element x (xs consCount' snocCount k) vs N'SnocF xs x -> do element <- fresh let grd = PmListTail listVar snocCount element elemTyp let !snocCount' = snocCount + 1 - Grd grd <$> go consCount snocCount' xs (desugarPattern elemTyp element x k) vs + Grd grd <$> xs consCount snocCount' (desugarPattern elemTyp element x k) vs N'NilF -> k vs N'VarF _ -> k (listVar : vs) N'UnboundF _ -> k vs - countMinListLen :: NormalizedList loc -> (Int, Int) - countMinListLen = - ($ 0) . cata \case - N'ConsF _ b -> \acc -> b $! acc + 1 - N'SnocF b _ -> \acc -> b $! acc + 1 - N'NilF -> \ !n -> (n, n) - N'VarF _ -> \ !n -> (n, maxBound) - N'UnboundF _ -> \ !n -> (n, maxBound) + countMinListLen :: Algebra (NormalizedListF loc) (Int -> (Int, Int)) + countMinListLen = \case + N'ConsF _ b -> \acc -> b $! acc + 1 + N'SnocF b _ -> \acc -> b $! acc + 1 + N'NilF -> \ !n -> (n, n) + N'VarF _ -> \ !n -> (n, maxBound) + N'UnboundF _ -> \ !n -> (n, maxBound) data NormalizedListF loc a = N'ConsF (Pattern loc) a diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/Fix.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/Fix.hs deleted file mode 100644 index 9accc06fb4..0000000000 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/Fix.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -module Unison.PatternMatchCoverage.Fix where - -newtype Fix f = Fix {unFix :: f (Fix f)} - -deriving instance (forall a. (Show a) => Show (f a)) => Show (Fix f) - -deriving instance (forall a. (Eq a) => Eq (f a)) => Eq (Fix f) - -deriving instance (Eq (Fix f), forall a. (Ord a) => Ord (f a)) => Ord (Fix f) - -cata :: (Functor f) => (f a -> a) -> Fix f -> a -cata alg = let c = alg . fmap c . unFix in c - -para :: (Functor f) => (f (Fix f, a) -> a) -> Fix f -> a -para alg = let c = alg . fmap (\x -> (x, c x)) . unFix in c diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/GrdTree.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/GrdTree.hs index 15b28e3da3..3d6e142b9d 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/GrdTree.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/GrdTree.hs @@ -10,12 +10,10 @@ module Unison.PatternMatchCoverage.GrdTree ) where -import Data.List.NonEmpty (NonEmpty (..)) -import Data.List.NonEmpty qualified as NEL import Data.ListLike (ListLike) -import Unison.PatternMatchCoverage.Fix import Unison.Prelude import Unison.Util.Pretty +import Unison.Util.Recursion -- | A @GrdTree@ is the simple language to desugar matches into. All -- pattern matching constructs (/e.g./ structural pattern matching, @@ -55,7 +53,7 @@ data GrdTreeF n l a | -- | A constraint of some kind (structural pattern match, boolan guard, etc) GrdF n a | -- | A list of alternative matches, tried in order - ForkF (NonEmpty a) + ForkF [a] deriving stock (Functor, Show) prettyGrdTree :: forall n l s. (ListLike s Char, IsString s) => (n -> Pretty s) -> (l -> Pretty s) -> GrdTree n l -> Pretty s @@ -64,7 +62,7 @@ prettyGrdTree prettyNode prettyLeaf = cata phi phi = \case LeafF l -> prettyLeaf l GrdF n rest -> sep " " [prettyNode n, "──", rest] - ForkF xs -> "──" <> group (sep "\n" (makeTree $ NEL.toList xs)) + ForkF xs -> "──" <> group (sep "\n" $ makeTree xs) makeTree :: [Pretty s] -> [Pretty s] makeTree = \case [] -> [] @@ -82,7 +80,7 @@ pattern Leaf x = Fix (LeafF x) pattern Grd :: n -> GrdTree n l -> GrdTree n l pattern Grd x rest = Fix (GrdF x rest) -pattern Fork :: NonEmpty (GrdTree n l) -> GrdTree n l +pattern Fork :: [GrdTree n l] -> GrdTree n l pattern Fork alts = Fix (ForkF alts) {-# COMPLETE Leaf, Grd, Fork #-} diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs index 38feb90cc5..7a353817a6 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs @@ -43,21 +43,21 @@ data Literal vt v loc NegLit v PmLit | -- | Positive constraint on list element with position relative to head of list PosListHead + -- | list root v - -- ^ list root + -- | cons position (0 is head) Int - -- ^ cons position (0 is head) + -- | element variable v - -- ^ element variable (Type vt loc) | -- | Positive constraint on list element with position relative to end of list PosListTail + -- | list root v - -- ^ list root + -- | snoc position (0 is last) Int - -- ^ snoc position (0 is last) + -- | element variable v - -- ^ element variable (Type vt loc) | -- | Negative constraint on length of the list (/i.e./ the list -- may not be an element of the interval set) diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/NormalizedConstraints.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/NormalizedConstraints.hs index 4cb60551bd..832a8bb5fe 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/NormalizedConstraints.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/NormalizedConstraints.hs @@ -216,14 +216,14 @@ data VarConstraints vt v loc | Vc'Text (Maybe Text) (Set Text) | Vc'Char (Maybe Char) (Set Char) | Vc'ListRoot + -- | type of list elems (Type vt loc) - -- ^ type of list elems + -- | Positive constraint on cons elements (Seq v) - -- ^ Positive constraint on cons elements + -- | Positive constraint on snoc elements (Seq v) - -- ^ Positive constraint on snoc elements + -- | positive constraint on input list size IntervalSet - -- ^ positive constraint on input list size deriving stock (Show, Eq, Ord, Generic) data EffectInfo diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/PmGrd.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/PmGrd.hs index 9a7721cf58..41bf27573a 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/PmGrd.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/PmGrd.hs @@ -17,39 +17,39 @@ data loc -- annotation = -- | @PmCon x Con xs ys@ corresponds to the constraint @Con ys <- x@ PmCon + -- | Variable v - -- ^ Variable + -- | Constructor ConstructorReference - -- ^ Constructor + -- | Constructor argument values and types [(v, Type vt loc)] - -- ^ Constructor argument values and types | PmEffect + -- | Variable v - -- ^ Variable + -- | Constructor ConstructorReference - -- ^ Constructor + -- | Constructor argument values and types [(v, Type vt loc)] - -- ^ Constructor argument values and types | PmEffectPure v (v, Type vt loc) | PmLit v PmLit | PmListHead + -- | list root v - -- ^ list root + -- | cons position (0 is head) Int - -- ^ cons position (0 is head) + -- | element variable v - -- ^ element variable + -- | element type (Type vt loc) - -- ^ element type | PmListTail + -- | list root v - -- ^ list root + -- | snoc position (0 is last) Int - -- ^ snoc position (0 is last) + -- | element variable v - -- ^ element variable + -- | element type (Type vt loc) - -- ^ element type | -- | The size of the list must fall within this inclusive range PmListInterval v Int Int | -- | If a guard performs an effect diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs index 5c10aa36ee..8986f4c409 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs @@ -16,7 +16,6 @@ import Data.Foldable import Data.Function import Data.Functor import Data.Functor.Compose -import Data.List.NonEmpty (NonEmpty (..)) import Data.Map qualified as Map import Data.Sequence qualified as Seq import Data.Set qualified as Set @@ -29,7 +28,6 @@ import Unison.PatternMatchCoverage.Class import Unison.PatternMatchCoverage.Constraint (Constraint) import Unison.PatternMatchCoverage.Constraint qualified as C import Unison.PatternMatchCoverage.EffectHandler -import Unison.PatternMatchCoverage.Fix import Unison.PatternMatchCoverage.GrdTree import Unison.PatternMatchCoverage.IntervalSet (IntervalSet) import Unison.PatternMatchCoverage.IntervalSet qualified as IntervalSet @@ -43,6 +41,7 @@ import Unison.Prelude import Unison.Type (Type) import Unison.Type qualified as Type import Unison.Util.Pretty qualified as P +import Unison.Util.Recursion import Unison.Var (Var) -- | top-down traversal of the 'GrdTree' that produces: @@ -74,12 +73,11 @@ uncoverAnnotate z grdtree0 = cata phi grdtree0 z LeafF l -> \nc -> do nc' <- ensureInhabited' nc pure (Set.empty, Leaf (nc', l)) - ForkF (kinit :| ks) -> \nc0 -> do + ForkF ks -> \nc0 -> do -- depth-first fold in match-case order to acculate the -- constraints for a match failure at every case. - (nc1, t1) <- kinit nc0 - (ncfinal, ts) <- foldlM (\(nc, ts) a -> a nc >>= \(nc', t) -> pure (nc', t : ts)) (nc1, []) ks - pure (ncfinal, Fork (t1 :| reverse ts)) + (ncfinal, ts) <- foldlM (\(nc, ts) a -> a nc >>= \(nc', t) -> pure (nc', t : ts)) (nc0, []) ks + pure (ncfinal, Fork $ reverse ts) GrdF grd k -> \nc0 -> case grd of PmEffect var con convars -> handleGrd (PosEffect var (Effect con) convars) (NegEffect var (Effect con)) k nc0 PmEffectPure var resume -> handleGrd (PosEffect var NoEffect [resume]) (NegEffect var NoEffect) k nc0 @@ -518,12 +516,9 @@ addConstraint con0 nc = do C.PosLit var pmlit -> let updateLiteral pos neg lit | Just lit1 <- pos, - lit1 == lit = case lit1 == lit of + lit1 == lit = -- we already have this positive constraint - True -> (pure (), Ignore) - -- contradicts positive info - False -> (contradiction, Ignore) - -- the constraint contradicts negative info + (pure (), Ignore) | Set.member lit neg = (contradiction, Ignore) | otherwise = (pure (), Update (Just lit, neg)) in modifyLiteralC var pmlit updateLiteral nc diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv.hs b/parser-typechecker/src/Unison/PrettyPrintEnv.hs index 07fa935074..005bce8472 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv.hs @@ -28,7 +28,7 @@ import Unison.ConstructorReference (ConstructorReference) import Unison.ConstructorType qualified as CT import Unison.HashQualified (HashQualified) import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.LabeledDependency (LabeledDependency) import Unison.LabeledDependency qualified as LD import Unison.Name (Name) diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs index cace699ec8..77937c6d56 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs @@ -1,38 +1,36 @@ -{-# LANGUAGE ConstraintKinds #-} +module Unison.PrettyPrintEnv.MonadPretty + ( MonadPretty, + Env (..), + runPretty, + addTypeVars, + willCaptureType, + withBoundTerm, + withBoundTerms, + ) +where -module Unison.PrettyPrintEnv.MonadPretty where - -import Control.Lens (views, _1, _2) +import Control.Lens (views) import Control.Monad.Reader (MonadReader, Reader, local, runReader) import Data.Set qualified as Set import Unison.Prelude import Unison.PrettyPrintEnv (PrettyPrintEnv) +import Unison.Util.Set qualified as Set import Unison.Var (Var) +import Unison.Var qualified as Var -type MonadPretty v m = (Var v, MonadReader (PrettyPrintEnv, Set v) m) - -getPPE :: (MonadPretty v m) => m PrettyPrintEnv -getPPE = view _1 - --- | Run a computation with a modified PrettyPrintEnv, restoring the original -withPPE :: (MonadPretty v m) => PrettyPrintEnv -> m a -> m a -withPPE p = local (set _1 p) - -applyPPE :: (MonadPretty v m) => (PrettyPrintEnv -> a) -> m a -applyPPE = views _1 - -applyPPE2 :: (MonadPretty v m) => (PrettyPrintEnv -> a -> b) -> a -> m b -applyPPE2 f a = views _1 (`f` a) +type MonadPretty v m = (Var v, MonadReader (Env v) m) -applyPPE3 :: (MonadPretty v m) => (PrettyPrintEnv -> a -> b -> c) -> a -> b -> m c -applyPPE3 f a b = views _1 (\ppe -> f ppe a b) - --- | Run a computation with a modified PrettyPrintEnv, restoring the original -modifyPPE :: (MonadPretty v m) => (PrettyPrintEnv -> PrettyPrintEnv) -> m a -> m a -modifyPPE = local . over _1 +-- See Note [Bound and free term variables] for an explanation of boundTerms/freeTerms +data Env v = Env + { boundTerms :: !(Set v), + boundTypes :: !(Set v), + freeTerms :: !(Set v), + ppe :: !PrettyPrintEnv + } + deriving stock (Generic) modifyTypeVars :: (MonadPretty v m) => (Set v -> Set v) -> m a -> m a -modifyTypeVars = local . over _2 +modifyTypeVars = local . over #boundTypes -- | Add type variables to the set of variables that need to be avoided addTypeVars :: (MonadPretty v m) => [v] -> m a -> m a @@ -40,8 +38,79 @@ addTypeVars = modifyTypeVars . Set.union . Set.fromList -- | Check if a list of type variables contains any variables that need to be -- avoided -willCapture :: (MonadPretty v m) => [v] -> m Bool -willCapture vs = views _2 (not . Set.null . Set.intersection (Set.fromList vs)) +willCaptureType :: (MonadPretty v m) => [v] -> m Bool +willCaptureType vs = views #boundTypes (Set.intersects (Set.fromList vs)) + +withBoundTerm :: (MonadPretty v m) => v -> m a -> m a +withBoundTerm v = + local (over #boundTerms (Set.insert (Var.reset v))) + +withBoundTerms :: (MonadPretty v m) => [v] -> m a -> m a +withBoundTerms vs = + local (over #boundTerms (Set.union (foldMap (Set.singleton . Var.reset) vs))) + +runPretty :: (Var v) => PrettyPrintEnv -> Reader (Env v) a -> a +runPretty ppe m = + runReader + m + Env + { boundTerms = Set.empty, + boundTypes = Set.empty, + freeTerms = Set.empty, + ppe + } -runPretty :: (Var v) => PrettyPrintEnv -> Reader (PrettyPrintEnv, Set v) a -> a -runPretty ppe m = runReader m (ppe, mempty) +-- Note [Bound and free term variables] +-- +-- When rendering a Unison file, we render top-level bindings independently, which may end up referring to each +-- other after all are parsed together. Any individual term, therefore, may have free variables. For example, +-- +-- foo = ... bar ... +-- ^^^ +-- this "bar" variable is free in foo +-- +-- bar = ... +-- ^^^ +-- it's ultimately bound by a different top-level term rendering +-- +-- Therefore, we pass down all free variables of a top-level term binding, so that we can decide, when rendering one of +-- them, whether to add a leading dot. +-- +-- Now, when do we need to add a leading dot? Basically, any time a binder introduces a var that, when rendered reset, +-- clashes with the free var. +-- +-- Here are a few examples using a made-up Unison syntax in which we can see whether a let is recursive or +-- non-recursive, and using "%" to separate a var name from its unique id. +-- +-- Example 1 +-- +-- Made-up syntax Actual syntax +-- -------------- ---------------- +-- foo%0 = foo = +-- let bar%0 = bar%0 bar = #someref -- rendered as ".bar", then parsed as var "bar" +-- in 5 5 +-- +-- bar%0 = ... bar = ... +-- +-- In this example, we have a non-recursive let that binds a local variable called bar%0. The body of the bar%0 binding +-- can itself refer to a different bar%0, which isn't captured, since a non-recursive let binding body can't refer to +-- the binding. +-- +-- So, when rendering the free bar%0 in the right-hand side, we ask: should we add a leading dot? And the answer is: is +-- the var bar%0 in the set of all reset locally-bound vars {bar%0}? Yes? Then yes. +-- +-- Example 2 +-- +-- Made-up syntax Actual syntax +-- -------------- ---------------- +-- foo%0 = foo = +-- letrec bar%1 = do bar%0 hey%0 bar = do #someref hey -- rendered as ".bar", then parsed as var "bar" +-- hey%0 = do bar%1 hey = do bar +-- in 5 5 +-- +-- bar%0 = ... bar = ... +-- +-- In this example, we have a recursive let that binds a bar%1 variable, and refers to bar%0 from inside. Same +-- situation, but variable resetting is relevant, because when walking underneath binder bar%1, we want to add its reset +-- form (bar%0) to the set of bound variables to check against, when rendering a free var (which we assume to have +-- unique id 0). diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs index 4d511091eb..1ed83d451f 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs @@ -8,7 +8,9 @@ module Unison.PrettyPrintEnv.Names Suffixifier, dontSuffixify, suffixifyByHash, + suffixifyByHashName, suffixifyByName, + suffixifyByHashWithUnhashedTermsInScope, -- * Pretty-print env makePPE, @@ -18,16 +20,19 @@ module Unison.PrettyPrintEnv.Names where import Data.Set qualified as Set -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.Names (Names) import Unison.Names qualified as Names +import Unison.Names.ResolvesTo (ResolvesTo (..)) import Unison.NamesWithHistory qualified as Names import Unison.Prelude import Unison.PrettyPrintEnv (PrettyPrintEnv (PrettyPrintEnv)) import Unison.Reference (TypeReference) import Unison.Referent (Referent) +import Unison.Util.Relation (Relation) +import Unison.Util.Relation qualified as Relation ------------------------------------------------------------------------------------------------------------------------ -- Namer @@ -84,6 +89,27 @@ suffixifyByHash names = suffixifyType = \name -> Name.suffixifyByHash name (Names.types names) } +suffixifyByHashName :: Names -> Suffixifier +suffixifyByHashName names = + Suffixifier + { suffixifyTerm = \name -> Name.suffixifyByHashName name (Names.terms names), + suffixifyType = \name -> Name.suffixifyByHashName name (Names.types names) + } + +suffixifyByHashWithUnhashedTermsInScope :: Set Name -> Names -> Suffixifier +suffixifyByHashWithUnhashedTermsInScope localTermNames namespaceNames = + Suffixifier + { suffixifyTerm = \name -> Name.suffixifyByHash name terms, + suffixifyType = \name -> Name.suffixifyByHash name (Names.types namespaceNames) + } + where + terms :: Relation Name (ResolvesTo Referent) + terms = + Names.terms namespaceNames + & Relation.subtractDom localTermNames + & Relation.mapRan ResolvesToNamespace + & Relation.union (Relation.fromList (map (\name -> (name, ResolvesToLocal name)) (Set.toList localTermNames))) + ------------------------------------------------------------------------------------------------------------------------ -- Pretty-print env diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index d95ffed4a1..9d5dd0cf84 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -32,8 +32,8 @@ import Text.Megaparsec qualified as P import Unison.ABT qualified as ABT import Unison.Builtin.Decls (unitRef, pattern TupleType') import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) -import Unison.HashQualified (HashQualified) -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualified qualified as HQ +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Kind (Kind) import Unison.Kind qualified as Kind import Unison.KindInference.Error.Pretty (prettyKindError) @@ -54,11 +54,12 @@ import Unison.Result qualified as Result import Unison.Settings qualified as Settings import Unison.Symbol (Symbol) import Unison.Syntax.HashQualified qualified as HQ (toText) -import Unison.Syntax.Lexer qualified as L +import Unison.Syntax.Lexer.Unison qualified as L import Unison.Syntax.Name qualified as Name (toText) import Unison.Syntax.NamePrinter (prettyHashQualified0) import Unison.Syntax.Parser (Annotated, ann) import Unison.Syntax.Parser qualified as Parser +import Unison.Syntax.Precedence qualified as Precedence import Unison.Syntax.TermPrinter qualified as TermPrinter import Unison.Term qualified as Term import Unison.Type (Type) @@ -75,6 +76,7 @@ import Unison.Util.Monoid (intercalateMap) import Unison.Util.Pretty (ColorText, Pretty) import Unison.Util.Pretty qualified as Pr import Unison.Util.Range (Range (..), startingLine) +import Unison.Util.Text (ordinal) import Unison.Var (Var) import Unison.Var qualified as Var @@ -126,6 +128,10 @@ styleAnnotated sty a = (,sty) <$> rangeForAnnotated a style :: s -> String -> Pretty (AnnotatedText s) style sty str = Pr.lit . AT.annotate sty $ fromString str +-- | Applies the color highlighting for `Code`, but also quotes the code, to separate it from the containing context. +quoteCode :: String -> Pretty ColorText +quoteCode = Pr.backticked . style Code + stylePretty :: Color -> Pretty ColorText -> Pretty ColorText stylePretty = Pr.map . AT.annotate @@ -827,14 +833,6 @@ renderTypeError e env src = case e of let sz = length wrongs pl a b = if sz == 1 then a else b in mconcat [txt pl, intercalateMap "\n" (renderSuggestion env) wrongs] - ordinal :: (IsString s) => Int -> s - ordinal n = - fromString $ - show n ++ case last (show n) of - '1' -> "st" - '2' -> "nd" - '3' -> "rd" - _ -> "th" debugNoteLoc a = if Settings.debugNoteLoc then a else mempty debugSummary :: C.ErrorNote v loc -> Pretty ColorText debugSummary note = @@ -1129,13 +1127,10 @@ renderContext env ctx@(C.Context es) = renderTerm :: (IsString s, Var v) => Env -> Term.Term' (TypeVar.TypeVar loc0 v) v loc1 -> s renderTerm env e = - let s = Color.toPlain $ TermPrinter.pretty' (Just 80) env (TypeVar.lowerTerm e) - in if length s > Settings.renderTermMaxLength - then fromString ("..." <> drop (length s - Settings.renderTermMaxLength) s) - else fromString s + fromString (Color.toPlain $ TermPrinter.pretty' (Just 80) env (TypeVar.lowerTerm e)) renderPattern :: Env -> Pattern ann -> ColorText -renderPattern env e = Pr.renderUnbroken . Pr.syntaxToColor . fst $ TermPrinter.prettyPattern env TermPrinter.emptyAc 0 ([] :: [Symbol]) e +renderPattern env e = Pr.renderUnbroken . Pr.syntaxToColor . fst $ TermPrinter.prettyPattern env TermPrinter.emptyAc Precedence.Annotation ([] :: [Symbol]) e -- | renders a type with no special styling renderType' :: (IsString s, Var v) => Env -> Type v loc -> s @@ -1339,7 +1334,7 @@ prettyParseError s e = lexerOutput :: Pretty (AnnotatedText a) lexerOutput = if showLexerOutput - then "\nLexer output:\n" <> fromString (L.debugLex' s) + then "\nLexer output:\n" <> fromString (L.debugPreParse' s) else mempty renderParseErrors :: @@ -1366,31 +1361,31 @@ renderParseErrors s = \case <> style ErrorSite (fromString open) <> ".\n\n" <> excerpt - L.InvalidWordyId _id -> + L.ReservedWordyId id -> Pr.lines - [ "This identifier isn't valid syntax: ", + [ "The identifier " <> quoteCode id <> " used here is a reserved keyword: ", "", excerpt, - "Here's a few examples of valid syntax: " - <> style Code "abba1', snake_case, Foo.zoink!, 🌻" - ] - L.ReservedWordyId _id -> - Pr.lines - [ "The identifier used here isn't allowed to be a reserved keyword: ", - "", - excerpt + Pr.wrap $ + "You can avoid this problem either by renaming the identifier or wrapping it in backticks (like " + <> style Code ("`" <> id <> "`") + <> ")." ] - L.InvalidSymbolyId _id -> + L.InvalidSymbolyId id -> Pr.lines - [ "This infix identifier isn't valid syntax: ", + [ "The infix identifier " <> quoteCode id <> " isn’t valid syntax: ", "", excerpt, - "Here's a few valid examples: " - <> style Code "++, Float./, `List.map`" + "Here are a few valid examples: " + <> quoteCode "++" + <> ", " + <> quoteCode "Float./" + <> ", and " + <> quoteCode "List.map" ] - L.ReservedSymbolyId _id -> + L.ReservedSymbolyId id -> Pr.lines - [ "This identifier is reserved by Unison and can't be used as an operator: ", + [ "The identifier " <> quoteCode id <> " is reserved by Unison and can't be used as an operator: ", "", excerpt ] @@ -1430,6 +1425,18 @@ renderParseErrors s = \case <> "after the" <> Pr.group (style ErrorSite "0o" <> ".") ] + L.InvalidBinaryLiteral -> + Pr.lines + [ "This number isn't valid syntax: ", + "", + excerpt, + Pr.wrap $ + "I was expecting only binary characters" + <> "(one of" + <> Pr.group (style Code "01" <> ")") + <> "after the" + <> Pr.group (style ErrorSite "0b" <> ".") + ] L.InvalidShortHash h -> Pr.lines [ "Invalid hash: " <> style ErrorSite (fromString h), @@ -1444,11 +1451,12 @@ renderParseErrors s = \case "", excerpt, Pr.wrap $ - "I was expecting some digits after the '.'," - <> "for example: " - <> style Code (n <> "0") + "I was expecting some digits after the " + <> quoteCode "." + <> ", for example: " + <> quoteCode (n <> "0") <> "or" - <> Pr.group (style Code (n <> "1e37") <> ".") + <> Pr.group (quoteCode (n <> "1e37") <> ".") ] L.MissingExponent n -> Pr.lines @@ -1458,7 +1466,7 @@ renderParseErrors s = \case Pr.wrap $ "I was expecting some digits for the exponent," <> "for example: " - <> Pr.group (style Code (n <> "37") <> ".") + <> Pr.group (quoteCode (n <> "37") <> ".") ] L.TextLiteralMissingClosingQuote _txt -> Pr.lines @@ -1474,7 +1482,7 @@ renderParseErrors s = \case "", "I only know about the following escape characters:", "", - let s ch = style Code (fromString $ "\\" <> [ch]) + let s ch = quoteCode (fromString $ "\\" <> [ch]) in Pr.indentN 2 $ intercalateMap "," s (fst <$> L.escapeChars) ] L.LayoutError -> @@ -1705,7 +1713,7 @@ renderParseErrors s = \case let msg = mconcat [ "This looks like the start of an expression here but I was expecting a binding.", - "\nDid you mean to use a single " <> style Code ":", + "\nDid you mean to use a single " <> quoteCode ":", " here for a type signature?", "\n\n", tokenAsErrorSite s t @@ -1776,21 +1784,6 @@ renderParseErrors s = \case tokenAsErrorSite s tok ] in (msg, [rangeForToken tok]) - go (Parser.EmptyMatch tok) = - let msg = - Pr.indentN 2 . Pr.callout "😶" $ - Pr.lines - [ Pr.wrap - ( "I expected some patterns after a " - <> style ErrorSite "match" - <> "/" - <> style ErrorSite "with" - <> " or cases but I didn't find any." - ), - "", - tokenAsErrorSite s tok - ] - in (msg, [rangeForToken tok]) go (Parser.EmptyWatch tok) = let msg = Pr.lines @@ -1799,8 +1792,6 @@ renderParseErrors s = \case annotatedAsErrorSite s tok ] in (msg, maybeToList $ rangeForAnnotated tok) - go (Parser.UnknownAbilityConstructor tok _referents) = (unknownConstructor "ability" tok, [rangeForToken tok]) - go (Parser.UnknownDataConstructor tok _referents) = (unknownConstructor "data" tok, [rangeForToken tok]) go (Parser.UnknownId tok referents references) = let msg = Pr.lines @@ -1863,24 +1854,14 @@ renderParseErrors s = \case <> structuralVsUniqueDocsLink ] in (msg, rangeForToken <$> [void keyword, void name]) - - unknownConstructor :: - String -> L.Token (HashQualified Name) -> Pretty ColorText - unknownConstructor ctorType tok = - Pr.lines - [ (Pr.wrap . mconcat) - [ "I don't know about any ", - fromString ctorType, - " constructor named ", - Pr.group - ( stylePretty ErrorSite (prettyHashQualified0 (L.payload tok)) - <> "." - ), - "Maybe make sure it's correctly spelled and that you've imported it:" - ], - "", - tokenAsErrorSite s tok - ] + go (Parser.TypeNotAllowed tok) = + let msg = + Pr.lines + [ Pr.wrap "I expected to see a term here, but instead it’s a type:", + "", + tokenAsErrorSite s $ HQ.toText <$> tok + ] + in (msg, [rangeForToken tok]) annotatedAsErrorSite :: (Annotated a) => String -> a -> Pretty ColorText @@ -1962,11 +1943,11 @@ intLiteralSyntaxTip term expectedType = case (term, expectedType) of -- | Pretty prints resolution failure annotations, including a table of disambiguation -- suggestions. prettyResolutionFailures :: - forall v a. - (Annotated a, Var v, Ord a) => + forall a. + (Annotated a, Ord a) => -- | src String -> - [Names.ResolutionFailure v a] -> + [Names.ResolutionFailure a] -> Pretty ColorText prettyResolutionFailures s allFailures = Pr.callout "❓" $ @@ -1981,32 +1962,39 @@ prettyResolutionFailures s allFailures = where -- Collapses identical failures which may have multiple annotations into a single failure. -- uniqueFailures - ambiguitiesToTable :: [Names.ResolutionFailure v a] -> Pretty ColorText + ambiguitiesToTable :: [Names.ResolutionFailure a] -> Pretty ColorText ambiguitiesToTable failures = - let pairs :: ([(v, Maybe (NESet String))]) + let pairs :: ([(HQ.HashQualified Name, Maybe (NESet String))]) pairs = nubOrd . fmap toAmbiguityPair $ failures spacerRow = ("", "") in Pr.column2Header "Symbol" "Suggestions" $ spacerRow : (intercalateMap [spacerRow] prettyRow pairs) - toAmbiguityPair :: Names.ResolutionFailure v annotation -> (v, Maybe (NESet String)) + toAmbiguityPair :: Names.ResolutionFailure annotation -> (HQ.HashQualified Name, Maybe (NESet String)) toAmbiguityPair = \case - (Names.TermResolutionFailure v _ (Names.Ambiguous names refs)) -> do + (Names.TermResolutionFailure name _ (Names.Ambiguous names refs localNames)) -> do let ppe = ppeFromNames names - in (v, Just $ NES.map (showTermRef ppe) refs) - (Names.TypeResolutionFailure v _ (Names.Ambiguous names refs)) -> do + in ( name, + Just $ + NES.unsafeFromSet + (Set.map (showTermRef ppe) refs <> Set.map (Text.unpack . Name.toText) localNames) + ) + (Names.TypeResolutionFailure name _ (Names.Ambiguous names refs localNames)) -> do let ppe = ppeFromNames names - in (v, Just $ NES.map (showTypeRef ppe) refs) - (Names.TermResolutionFailure v _ Names.NotFound) -> (v, Nothing) - (Names.TypeResolutionFailure v _ Names.NotFound) -> (v, Nothing) + in ( name, + Just $ + NES.unsafeFromSet (Set.map (showTypeRef ppe) refs <> Set.map (Text.unpack . Name.toText) localNames) + ) + (Names.TermResolutionFailure name _ Names.NotFound) -> (name, Nothing) + (Names.TypeResolutionFailure name _ Names.NotFound) -> (name, Nothing) ppeFromNames :: Names.Names -> PPE.PrettyPrintEnv ppeFromNames names = PPE.makePPE (PPE.hqNamer PPE.todoHashLength names) PPE.dontSuffixify - prettyRow :: (v, Maybe (NESet String)) -> [(Pretty ColorText, Pretty ColorText)] - prettyRow (v, mSet) = case mSet of - Nothing -> [(prettyVar v, Pr.hiBlack "No matches")] - Just suggestions -> zip ([prettyVar v] ++ repeat "") (Pr.string <$> toList suggestions) + prettyRow :: (HQ.HashQualified Name, Maybe (NESet String)) -> [(Pretty ColorText, Pretty ColorText)] + prettyRow (name, mSet) = case mSet of + Nothing -> [(prettyHashQualified0 name, Pr.hiBlack "No matches")] + Just suggestions -> zip ([prettyHashQualified0 name] ++ repeat "") (Pr.string <$> toList suggestions) useExamples :: Pretty ColorText useExamples = diff --git a/parser-typechecker/src/Unison/Project/Util.hs b/parser-typechecker/src/Unison/Project/Util.hs deleted file mode 100644 index 2848a07564..0000000000 --- a/parser-typechecker/src/Unison/Project/Util.hs +++ /dev/null @@ -1,158 +0,0 @@ -module Unison.Project.Util - ( projectPath, - projectBranchesPath, - projectBranchPath, - projectBranchSegment, - projectPathPrism, - projectBranchPathPrism, - projectContextFromPath, - pattern UUIDNameSegment, - ProjectContext (..), - pattern ProjectsNameSegment, - pattern BranchesNameSegment, - ) -where - -import Control.Lens -import Data.Text qualified as Text -import Data.UUID (UUID) -import Data.UUID qualified as UUID -import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..)) -import Unison.Codebase.Path qualified as Path -import Unison.NameSegment.Internal (NameSegment (NameSegment)) -import Unison.NameSegment.Internal qualified as NameSegment -import Unison.Project (ProjectAndBranch (..)) - --- | Get the path that a project is stored at. Users aren't supposed to go here. --- --- >>> projectPath "ABCD" --- .__projects._ABCD -projectPath :: ProjectId -> Path.Absolute -projectPath projectId = - review projectPathPrism projectId - --- | Get the path that a project's branches are stored at. Users aren't supposed to go here. --- --- >>> projectBranchesPath "ABCD" --- .__projects._ABCD.branches -projectBranchesPath :: ProjectId -> Path.Absolute -projectBranchesPath projectId = - snoc (projectPath projectId) BranchesNameSegment - --- | Get the path that a branch is stored at. Users aren't supposed to go here. --- --- >>> projectBranchPath ProjectAndBranch { project = "ABCD", branch = "DEFG" } --- .__projects._ABCD.branches._DEFG -projectBranchPath :: ProjectAndBranch ProjectId ProjectBranchId -> Path.Absolute -projectBranchPath projectAndBranch = - review projectBranchPathPrism (projectAndBranch, Path.empty) - --- | Get the name segment that a branch is stored at. --- --- >>> projectBranchSegment "DEFG" --- "_DEFG" -projectBranchSegment :: ProjectBranchId -> NameSegment -projectBranchSegment (ProjectBranchId branchId) = - UUIDNameSegment branchId - -pattern UUIDNameSegment :: UUID -> NameSegment -pattern UUIDNameSegment uuid <- - ( NameSegment.toUnescapedText -> - (Text.uncons -> Just ('_', UUID.fromText . Text.map (\c -> if c == '_' then '-' else c) -> Just uuid)) - ) - where - UUIDNameSegment uuid = - NameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid))) - --- | The prism between paths like --- --- @ --- .__projects._XX_XX --- @ --- --- and the project id --- --- @ --- XX-XX --- @ -projectPathPrism :: Prism' Path.Absolute ProjectId -projectPathPrism = - prism' toPath toId - where - toPath :: ProjectId -> Path.Absolute - toPath projectId = - Path.Absolute (Path.fromList [ProjectsNameSegment, UUIDNameSegment (unProjectId projectId)]) - - toId :: Path.Absolute -> Maybe ProjectId - toId path = - case Path.toList (Path.unabsolute path) of - [ProjectsNameSegment, UUIDNameSegment projectId] -> Just (ProjectId projectId) - _ -> Nothing - --- | The prism between paths like --- --- @ --- .__projects._XX_XX.branches._YY_YY.foo.bar --- @ --- --- and the @(project id, branch id, path)@ triple --- --- @ --- (XX-XX, YY-YY, foo.bar) --- @ -projectBranchPathPrism :: Prism' Path.Absolute (ProjectAndBranch ProjectId ProjectBranchId, Path.Path) -projectBranchPathPrism = - prism' toPath toIds - where - toPath :: (ProjectAndBranch ProjectId ProjectBranchId, Path.Path) -> Path.Absolute - toPath (ProjectAndBranch {project = projectId, branch = branchId}, restPath) = - Path.Absolute $ - Path.fromList - ( [ ProjectsNameSegment, - UUIDNameSegment (unProjectId projectId), - BranchesNameSegment, - UUIDNameSegment (unProjectBranchId branchId) - ] - ++ Path.toList restPath - ) - - toIds :: Path.Absolute -> Maybe (ProjectAndBranch ProjectId ProjectBranchId, Path.Path) - toIds path = - case Path.toList (Path.unabsolute path) of - ProjectsNameSegment : UUIDNameSegment projectId : BranchesNameSegment : UUIDNameSegment branchId : restPath -> - Just (ProjectAndBranch {project = ProjectId projectId, branch = ProjectBranchId branchId}, Path.fromList restPath) - _ -> Nothing - --- | The project information about the current path. --- NOTE: if the user has cd'd into the project storage area but NOT into a branch, (where they shouldn't ever --- be), this will result in a LooseCodePath. -data ProjectContext - = LooseCodePath Path.Absolute - | ProjectBranchPath ProjectId ProjectBranchId Path.Path {- path from branch root -} - deriving stock (Eq, Show) - -projectContextFromPath :: Path.Absolute -> ProjectContext -projectContextFromPath path = - case path ^? projectBranchPathPrism of - Just (ProjectAndBranch {project = projectId, branch = branchId}, restPath) -> - ProjectBranchPath projectId branchId restPath - Nothing -> - LooseCodePath path - -pattern ProjectsNameSegment :: NameSegment -pattern ProjectsNameSegment <- - ((== projectsNameSegment) -> True) - where - ProjectsNameSegment = projectsNameSegment - -pattern BranchesNameSegment :: NameSegment -pattern BranchesNameSegment <- - ((== branchesNameSegment) -> True) - where - BranchesNameSegment = branchesNameSegment - -projectsNameSegment :: NameSegment -projectsNameSegment = NameSegment "__projects" - -branchesNameSegment :: NameSegment -branchesNameSegment = NameSegment "branches" diff --git a/parser-typechecker/src/Unison/Result.hs b/parser-typechecker/src/Unison/Result.hs index 2c1a75662e..1c542c524f 100644 --- a/parser-typechecker/src/Unison/Result.hs +++ b/parser-typechecker/src/Unison/Result.hs @@ -18,7 +18,7 @@ type ResultT notes f = MaybeT (WriterT notes f) data Note v loc = Parsing (Parser.Err v) - | NameResolutionFailures [Names.ResolutionFailure v loc] + | NameResolutionFailures [Names.ResolutionFailure loc] | UnknownSymbol v loc | TypeError (Context.ErrorNote v loc) | TypeInfo (Context.InfoNote v loc) @@ -39,7 +39,7 @@ pattern Result notes may = MaybeT (WriterT (Identity (may, notes))) {-# COMPLETE Result #-} -makeResult :: Applicative m => notes -> Maybe a -> ResultT notes m a +makeResult :: (Applicative m) => notes -> Maybe a -> ResultT notes m a makeResult notes value = MaybeT (WriterT (pure (value, notes))) diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs deleted file mode 100644 index 9b77728f60..0000000000 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ /dev/null @@ -1,2322 +0,0 @@ -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Runtime.ANF - ( minimizeCyclesOrCrash, - pattern TVar, - pattern TLit, - pattern TBLit, - pattern TApp, - pattern TApv, - pattern TCom, - pattern TCon, - pattern TKon, - pattern TReq, - pattern TPrm, - pattern TFOp, - pattern THnd, - pattern TLet, - pattern TLetD, - pattern TFrc, - pattern TLets, - pattern TName, - pattern TBind, - pattern TBinds, - pattern TShift, - pattern TMatch, - CompileExn (..), - internalBug, - Mem (..), - Lit (..), - Direction (..), - SuperNormal (..), - SuperGroup (..), - POp (..), - FOp, - close, - saturate, - float, - floatGroup, - lamLift, - lamLiftGroup, - litRef, - inlineAlias, - addDefaultCases, - ANormalF (.., AApv, ACom, ACon, AKon, AReq, APrm, AFOp), - ANormal, - RTag, - CTag, - Tag (..), - GroupRef (..), - Value (..), - Cont (..), - BLit (..), - packTags, - unpackTags, - maskTags, - ANFM, - Branched (.., MatchDataCover), - Func (..), - SGEqv (..), - equivocate, - superNormalize, - anfTerm, - valueTermLinks, - valueLinks, - groupTermLinks, - foldGroupLinks, - overGroupLinks, - traverseGroupLinks, - normalLinks, - prettyGroup, - prettySuperNormal, - prettyANF, - ) -where - -import Control.Exception (throw) -import Control.Lens (snoc, unsnoc) -import Control.Monad.Reader (ReaderT (..), ask, local) -import Control.Monad.State (MonadState (..), State, gets, modify, runState) -import Data.Bifoldable (Bifoldable (..)) -import Data.Bitraversable (Bitraversable (..)) -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) -import Data.Functor.Compose (Compose (..)) -import Data.List hiding (and, or) -import Data.Map qualified as Map -import Data.Primitive qualified as PA -import Data.Set qualified as Set -import Data.Text qualified as Data.Text -import GHC.Stack (CallStack, callStack) -import Unison.ABT qualified as ABT -import Unison.ABT.Normalized qualified as ABTN -import Unison.Blank (nameb) -import Unison.Builtin.Decls qualified as Ty -import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) -import Unison.Hashing.V2.Convert (hashTermComponentsWithoutTypes) -import Unison.Pattern (SeqOp (..)) -import Unison.Pattern qualified as P -import Unison.Prelude -import Unison.Reference (Id, Reference, Reference' (Builtin, DerivedId)) -import Unison.Referent (Referent, pattern Con, pattern Ref) -import Unison.Symbol (Symbol) -import Unison.Term hiding (List, Ref, Text, float, fresh, resolve) -import Unison.Type qualified as Ty -import Unison.Typechecker.Components (minimize') -import Unison.Util.Bytes (Bytes) -import Unison.Util.EnumContainers as EC -import Unison.Util.Pretty qualified as Pretty -import Unison.Util.Text qualified as Util.Text -import Unison.Var (Var, typed) -import Unison.Var qualified as Var -import Prelude hiding (abs, and, or, seq) -import Prelude qualified - --- For internal errors -data CompileExn = CE CallStack (Pretty.Pretty Pretty.ColorText) - deriving (Show) - -instance Exception CompileExn - -internalBug :: (HasCallStack) => String -> a -internalBug = throw . CE callStack . Pretty.lit . fromString - -closure :: (Var v) => Map v (Set v, Set v) -> Map v (Set v) -closure m0 = trace (snd <$> m0) - where - refs = fst <$> m0 - - expand acc fvs rvs = - fvs <> foldMap (\r -> Map.findWithDefault mempty r acc) rvs - - trace acc - | acc == acc' = acc - | otherwise = trace acc' - where - acc' = Map.intersectionWith (expand acc) acc refs - -expandRec :: - (Var v, Monoid a) => - Set v -> - [(v, Term v a)] -> - [(v, Term v a)] -expandRec keep vbs = mkSub <$> fvl - where - mkSub (v, fvs) = (v, apps' (var mempty v) (var mempty <$> fvs)) - - fvl = - Map.toList - . fmap (Set.toList) - . closure - $ Set.partition (`Set.member` keep) - . ABT.freeVars - <$> Map.fromList vbs - -expandSimple :: - (Var v, Monoid a) => - Set v -> - (v, Term v a) -> - (v, Term v a) -expandSimple keep (v, bnd) = (v, apps' (var a v) evs) - where - a = ABT.annotation bnd - fvs = ABT.freeVars bnd - evs = map (var a) . Set.toList $ Set.difference fvs keep - -abstract :: (Var v) => Set v -> Term v a -> Term v a -abstract keep bnd = lam' a evs bnd - where - a = ABT.annotation bnd - fvs = ABT.freeVars bnd - evs = Set.toList $ Set.difference fvs keep - -enclose :: - (Var v, Monoid a) => - Set v -> - (Set v -> Term v a -> Term v a) -> - Term v a -> - Maybe (Term v a) -enclose keep rec (LetRecNamedTop' top vbs bd) = - Just $ letRec' top lvbs lbd - where - xpnd = expandRec keep' vbs - keep' = Set.union keep . Set.fromList . map fst $ vbs - lvbs = - vbs - <&> \(v, trm) -> - (v, ABT.annotation trm, (rec keep' . abstract keep' . ABT.substs xpnd) trm) - lbd = rec keep' . ABT.substs xpnd $ bd --- will be lifted, so keep this variable -enclose keep rec (Let1NamedTop' top v b@(unAnn -> LamsNamed' vs bd) e) = - Just . let1' top [(v, lamb)] . rec (Set.insert v keep) $ - ABT.subst v av e - where - (_, av) = expandSimple keep (v, b) - keep' = Set.difference keep $ Set.fromList vs - fvs = ABT.freeVars b - evs = Set.toList $ Set.difference fvs keep - a = ABT.annotation b - lbody = rec keep' bd - annotate tm - | Ann' _ ty <- b = ann a tm ty - | otherwise = tm - lamb = lam' a evs (annotate $ lam' a vs lbody) -enclose keep rec t@(unLamsAnnot -> Just (vs0, mty, vs1, body)) = - Just $ if null evs then lamb else apps' lamb $ map (var a) evs - where - -- remove shadowed variables - keep' = Set.difference keep $ Set.fromList (vs0 ++ vs1) - fvs = ABT.freeVars t - evs = Set.toList $ Set.difference fvs keep - a = ABT.annotation t - lbody = rec keep' body - annotate tm - | Just ty <- mty = ann a tm ty - | otherwise = tm - lamb = lam' a (evs ++ vs0) . annotate . lam' a vs1 $ lbody -enclose keep rec t@(Handle' h body) - | isStructured body = - Just . handle (ABT.annotation t) (rec keep h) $ apps' lamb args - where - fvs = ABT.freeVars body - evs = Set.toList $ Set.difference fvs keep - a = ABT.annotation body - lbody = rec keep body - fv = Var.freshIn fvs $ typed Var.Eta - args - | null evs = [constructor a (ConstructorReference Ty.unitRef 0)] - | otherwise = var a <$> evs - lamb - | null evs = lam' a [fv] lbody - | otherwise = lam' a evs lbody -enclose keep rec t@(Match' s0 cs0) = Just $ match a s cs - where - a = ABT.annotation t - s = rec keep s0 - cs = encloseCase a keep rec <$> cs0 -enclose _ _ _ = Nothing - -encloseCase :: - (Var v, Monoid a) => - a -> - Set v -> - (Set v -> Term v a -> Term v a) -> - MatchCase a (Term v a) -> - MatchCase a (Term v a) -encloseCase a keep rec0 (MatchCase pats guard body) = - MatchCase pats (rec <$> guard) (rec body) - where - rec (ABT.AbsN' vs bd) = - ABT.absChain' ((,) a <$> vs) $ - rec0 (keep `Set.difference` Set.fromList vs) bd - -newtype Prefix v x = Pfx (Map v [v]) deriving (Show) - -instance Functor (Prefix v) where - fmap _ (Pfx m) = Pfx m - -instance (Ord v) => Applicative (Prefix v) where - pure _ = Pfx Map.empty - Pfx ml <*> Pfx mr = Pfx $ Map.unionWith common ml mr - -common :: (Eq v) => [v] -> [v] -> [v] -common (u : us) (v : vs) - | u == v = u : common us vs -common _ _ = [] - -splitPfx :: v -> [Term v a] -> (Prefix v x, [Term v a]) -splitPfx v = first (Pfx . Map.singleton v) . split - where - split (Var' u : as) = first (u :) $ split as - split rest = ([], rest) - --- Finds the common variable prefixes that function variables are --- applied to, so that they can be reduced. -prefix :: (Ord v) => Term v a -> Prefix v (Term v a) -prefix = ABT.visit \case - Apps' (Var' u) as -> case splitPfx u as of - (pf, rest) -> Just $ traverse prefix rest *> pf - Var' u -> Just . Pfx $ Map.singleton u [] - _ -> Nothing - -appPfx :: (Ord v) => Prefix v a -> v -> [v] -> [v] -appPfx (Pfx m) v = maybe (const []) common $ Map.lookup v m - --- Rewrites a term by dropping the first n arguments to every --- application of `v`. This just assumes such a thing makes sense, as --- in `beta`, where we've calculated how many arguments to drop by --- looking at every occurrence of `v`. -dropPrefix :: (Ord v) => (Semigroup a) => v -> Int -> Term v a -> Term v a -dropPrefix _ 0 = id -dropPrefix v n = ABT.visitPure rw - where - rw (Apps' f@(Var' u) as) - | v == u = Just (apps' (var (ABT.annotation f) u) (drop n as)) - rw _ = Nothing - -dropPrefixes :: - (Ord v) => (Semigroup a) => Map v Int -> Term v a -> Term v a -dropPrefixes m = ABT.visitPure rw - where - rw (Apps' f@(Var' u) as) - | Just n <- Map.lookup u m = - Just (apps' (var (ABT.annotation f) u) (drop n as)) - rw _ = Nothing - --- Performs opposite transformations to those in enclose. Named after --- the lambda case, which is beta reduction. -beta :: (Var v) => (Monoid a) => (Term v a -> Term v a) -> Term v a -> Maybe (Term v a) -beta rec (LetRecNamedTop' top (fmap (fmap rec) -> vbs) (rec -> bd)) = - Just $ letRec' top lvbs lbd - where - -- Avoid completely reducing a lambda expression, because recursive - -- lets must be guarded. - args (v, LamsNamed' vs Ann' {}) = (v, vs) - args (v, LamsNamed' vs _) = (v, init vs) - args (v, _) = (v, []) - - Pfx m0 = traverse_ (prefix . snd) vbs *> prefix bd - - f ls rs = case common ls rs of - [] -> Nothing - vs -> Just vs - - m = Map.map length $ Map.differenceWith f (Map.fromList $ map args vbs) m0 - lvbs = - vbs <&> \(v, b0) -> (v,ABT.annotation b0,) $ case b0 of - LamsNamed' vs b - | Just n <- Map.lookup v m -> - lam' (ABT.annotation b0) (drop n vs) (dropPrefixes m b) - -- shouldn't happen - b -> dropPrefixes m b - - lbd = dropPrefixes m bd -beta rec (Let1NamedTop' top v l@(LamsNamed' vs bd) (rec -> e)) - | n > 0 = Just $ let1' top [(v, lamb)] (dropPrefix v n e) - | otherwise = Nothing - where - lamb = lam' al (drop n vs) (bd) - al = ABT.annotation l - -- Calculate a maximum number of arguments to drop. - -- Enclosing doesn't create let-bound lambdas, so we - -- should never reduce a lambda to a non-lambda, as that - -- could affect evaluation order. - m - | Ann' _ _ <- bd = length vs - | otherwise = length vs - 1 - n = min m . length $ appPfx (prefix e) v vs -beta rec (Apps' l@(LamsNamed' vs body) as) - | n <- matchVars 0 vs as, - n > 0 = - Just $ apps' (lam' al (drop n vs) (rec body)) (drop n as) - | otherwise = Nothing - where - al = ABT.annotation l - matchVars !n (u : us) (Var' v : as) | u == v = matchVars (1 + n) us as - matchVars n _ _ = n -beta _ _ = Nothing - -isStructured :: (Var v) => Term v a -> Bool -isStructured (Var' _) = False -isStructured (Lam' _) = False -isStructured (Nat' _) = False -isStructured (Int' _) = False -isStructured (Float' _) = False -isStructured (Text' _) = False -isStructured (Char' _) = False -isStructured (Constructor' _) = False -isStructured (Apps' Constructor' {} args) = any isStructured args -isStructured (If' b t f) = - isStructured b || isStructured t || isStructured f -isStructured (And' l r) = isStructured l || isStructured r -isStructured (Or' l r) = isStructured l || isStructured r -isStructured _ = True - -close :: (Var v, Monoid a) => Set v -> Term v a -> Term v a -close keep tm = ABT.visitPure (enclose keep close) tm - --- Attempts to undo what was done in `close`. Useful for decompiling. -open :: (Var v, Monoid a) => Term v a -> Term v a -open x = ABT.visitPure (beta open) x - -type FloatM v a r = State (Set v, [(v, Term v a)], [(v, Term v a)]) r - -freshFloat :: (Var v) => Set v -> v -> v -freshFloat avoid (Var.freshIn avoid -> v0) = - case Var.typeOf v0 of - Var.User nm - | v <- typed (Var.User $ nm <> w), - v `Set.notMember` avoid -> - v - | otherwise -> - freshFloat (Set.insert v0 avoid) v0 - _ -> v0 - where - w = Data.Text.pack . show $ Var.freshId v0 - -groupFloater :: - (Var v, Monoid a) => - (Term v a -> FloatM v a (Term v a)) -> - [(v, Term v a)] -> - FloatM v a (Map v v) -groupFloater rec vbs = do - cvs <- gets (\(vs, _, _) -> vs) - let shadows = - [ (v, freshFloat cvs v) - | (v, _) <- vbs, - Set.member v cvs - ] - shadowMap = Map.fromList shadows - rn v = Map.findWithDefault v v shadowMap - shvs = Set.fromList $ map (rn . fst) vbs - modify $ \(cvs, ctx, dcmp) -> (cvs <> shvs, ctx, dcmp) - fvbs <- traverse (\(v, b) -> (,) (rn v) <$> rec' (ABT.renames shadowMap b)) vbs - let dvbs = fmap (\(v, b) -> (rn v, deannotate b)) vbs - modify $ \(vs, ctx, dcmp) -> (vs, ctx ++ fvbs, dcmp <> dvbs) - pure shadowMap - where - rec' b - | Just (vs0, mty, vs1, bd) <- unLamsAnnot b = - lam' a vs0 . maybe id (flip $ ann a) mty . lam' a vs1 <$> rec bd - where - a = ABT.annotation b - rec' b = rec b - -letFloater :: - (Var v, Monoid a) => - (Term v a -> FloatM v a (Term v a)) -> - [(v, Term v a)] -> - Term v a -> - FloatM v a (Term v a) -letFloater rec vbs e = do - shadowMap <- groupFloater rec vbs - pure $ ABT.renames shadowMap e - -lamFloater :: - (Var v, Monoid a) => - Bool -> - Term v a -> - Maybe v -> - a -> - [v] -> - Term v a -> - FloatM v a v -lamFloater closed tm mv a vs bd = - state $ \trip@(cvs, ctx, dcmp) -> case find p ctx of - Just (v, _) -> (v, trip) - Nothing -> - let v = ABT.freshIn cvs $ fromMaybe (typed Var.Float) mv - in ( v, - ( Set.insert v cvs, - ctx <> [(v, lam' a vs bd)], - floatDecomp closed v tm dcmp - ) - ) - where - tgt = unannotate (lam' a vs bd) - p (_, flam) = unannotate flam == tgt - -floatDecomp :: - Bool -> v -> Term v a -> [(v, Term v a)] -> [(v, Term v a)] -floatDecomp True v b dcmp = (v, b) : dcmp -floatDecomp False _ _ dcmp = dcmp - -floater :: - (Var v, Monoid a) => - Bool -> - (Term v a -> FloatM v a (Term v a)) -> - Term v a -> - Maybe (FloatM v a (Term v a)) -floater top rec tm0@(Ann' tm ty) = - (fmap . fmap) (\tm -> ann a tm ty) (floater top rec tm) - where - a = ABT.annotation tm0 -floater top rec (LetRecNamed' vbs e) = - Just $ - letFloater rec vbs e >>= \case - lm@(LamsNamed' vs bd) | top -> lam' a vs <$> rec bd - where - a = ABT.annotation lm - tm -> rec tm -floater _ rec (Let1Named' v b e) - | Just (vs0, _, vs1, bd) <- unLamsAnnot b = - Just $ - rec bd - >>= lamFloater True b (Just v) a (vs0 ++ vs1) - >>= \lv -> rec $ ABT.renames (Map.singleton v lv) e - where - a = ABT.annotation b -floater top rec tm@(LamsNamed' vs bd) - | top = Just $ lam' a vs <$> rec bd - | otherwise = Just $ do - bd <- rec bd - lv <- lamFloater True tm Nothing a vs bd - pure $ var a lv - where - a = ABT.annotation tm -floater _ _ _ = Nothing - -postFloat :: - (Var v) => - (Monoid a) => - Map v Reference -> - (Set v, [(v, Term v a)], [(v, Term v a)]) -> - ( [(v, Term v a)], - [(v, Id)], - [(Reference, Term v a)], - [(Reference, Term v a)] - ) -postFloat orig (_, bs, dcmp) = - ( subs, - subvs, - fmap (first DerivedId) tops, - dcmp >>= \(v, tm) -> - let stm = open $ ABT.substs dsubs tm - in (subm Map.! v, stm) : [(r, stm) | Just r <- [Map.lookup v orig]] - ) - where - m = - fmap (fmap deannotate) - . hashTermComponentsWithoutTypes - . Map.fromList - $ bs - trips = Map.toList m - f (v, (id, tm)) = ((v, id), (v, idtm), (id, tm)) - where - idtm = ref (ABT.annotation tm) (DerivedId id) - (subvs, subs, tops) = unzip3 $ map f trips - subm = fmap DerivedId (Map.fromList subvs) - dsubs = Map.toList $ Map.map (ref mempty) orig <> Map.fromList subs - -float :: - (Var v) => - (Monoid a) => - Map v Reference -> - Term v a -> - (Term v a, Map Reference Reference, [(Reference, Term v a)], [(Reference, Term v a)]) -float orig tm = case runState go0 (Set.empty, [], []) of - (bd, st) -> case postFloat orig st of - (subs, subvs, tops, dcmp) -> - ( letRec' True [] . ABT.substs subs . deannotate $ bd, - Map.fromList . mapMaybe f $ subvs, - tops, - dcmp - ) - where - f (v, i) = (,DerivedId i) <$> Map.lookup v orig - go0 = fromMaybe (go tm) (floater True go tm) - go = ABT.visit $ floater False go - -floatGroup :: - (Var v) => - (Monoid a) => - Map v Reference -> - [(v, Term v a)] -> - ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)]) -floatGroup orig grp = case runState go0 (Set.empty, [], []) of - (_, st) -> case postFloat orig st of - (_, subvs, tops, dcmp) -> (subvs, tops, dcmp) - where - go = ABT.visit $ floater False go - go0 = groupFloater go grp - -unAnn :: Term v a -> Term v a -unAnn (Ann' tm _) = tm -unAnn tm = tm - -unLamsAnnot :: Term v a -> Maybe ([v], Maybe (Ty.Type v a), [v], Term v a) -unLamsAnnot tm0 - | null vs0, null vs1 = Nothing - | otherwise = Just (vs0, mty, vs1, bd) - where - (vs0, bd0) - | LamsNamed' vs bd <- tm0 = (vs, bd) - | otherwise = ([], tm0) - (mty, bd1) - | Ann' bd ty <- bd0 = (Just ty, bd) - | otherwise = (Nothing, bd0) - (vs1, bd) - | LamsNamed' vs bd <- bd1 = (vs, bd) - | otherwise = ([], bd1) - -deannotate :: (Var v) => Term v a -> Term v a -deannotate = ABT.visitPure $ \case - Ann' c _ -> Just $ deannotate c - _ -> Nothing - -lamLift :: - (Var v) => - (Monoid a) => - Map v Reference -> - Term v a -> - (Term v a, Map Reference Reference, [(Reference, Term v a)], [(Reference, Term v a)]) -lamLift orig = float orig . close Set.empty - -lamLiftGroup :: - (Var v) => - (Monoid a) => - Map v Reference -> - [(v, Term v a)] -> - ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)]) -lamLiftGroup orig gr = floatGroup orig . (fmap . fmap) (close keep) $ gr - where - keep = Set.fromList $ map fst gr - -saturate :: - (Var v, Monoid a) => - Map ConstructorReference Int -> - Term v a -> - Term v a -saturate dat = ABT.visitPure $ \case - Apps' f@(Constructor' r) args -> sat r f args - Apps' f@(Request' r) args -> sat r f args - f@(Constructor' r) -> sat r f [] - f@(Request' r) -> sat r f [] - _ -> Nothing - where - frsh avoid _ = - let v = Var.freshIn avoid $ typed Var.Eta - in (Set.insert v avoid, v) - sat r f args = case Map.lookup r dat of - Just n - | m < n, - vs <- snd $ mapAccumL frsh fvs [1 .. n - m], - nargs <- var mempty <$> vs -> - Just . lam' mempty vs . apps' f $ args' ++ nargs - | m > n, - (sargs, eargs) <- splitAt n args', - sv <- Var.freshIn fvs $ typed Var.Eta -> - Just - . let1' False [(sv, apps' f sargs)] - $ apps' (var mempty sv) eargs - _ -> Just (apps' f args') - where - m = length args - fvs = foldMap freeVars args - args' = saturate dat <$> args - -addDefaultCases :: (Var v) => (Monoid a) => Text -> Term v a -> Term v a -addDefaultCases = ABT.visitPure . defaultCaseVisitor - -defaultCaseVisitor :: - (Var v) => (Monoid a) => Text -> Term v a -> Maybe (Term v a) -defaultCaseVisitor func m@(Match' scrut cases) - | scrut <- addDefaultCases func scrut, - cases <- fmap (addDefaultCases func) <$> cases = - Just $ match a scrut (cases ++ [dflt]) - where - a = ABT.annotation m - v = Var.freshIn mempty $ typed Var.Blank - txt = "pattern match failure in function `" <> func <> "`" - msg = text a txt - bu = ref a (Builtin "bug") - dflt = - MatchCase (P.Var a) Nothing - . ABT.abs' a v - $ apps bu [(a, Ty.tupleTerm [msg, var a v])] -defaultCaseVisitor _ _ = Nothing - -inlineAlias :: (Var v) => (Monoid a) => Term v a -> Term v a -inlineAlias = ABT.visitPure $ \case - Let1Named' v b@(Var' _) e -> Just . inlineAlias $ ABT.subst v b e - _ -> Nothing - -minimizeCyclesOrCrash :: (Var v) => Term v a -> Term v a -minimizeCyclesOrCrash t = case minimize' t of - Right t -> t - Left e -> - internalBug $ - "tried to minimize let rec with duplicate definitions: " - ++ show (fst <$> toList e) - -data Mem = UN | BX deriving (Eq, Ord, Show, Enum) - --- Context entries with evaluation strategy -data CTE v s - = ST (Direction Word16) [v] [Mem] s - | LZ v (Either Reference v) [v] - deriving (Show) - -pattern ST1 :: Direction Word16 -> v -> Mem -> s -> CTE v s -pattern ST1 d v m s = ST d [v] [m] s - -data ANormalF v e - = ALet (Direction Word16) [Mem] e e - | AName (Either Reference v) [v] e - | ALit Lit - | ABLit Lit -- direct boxed literal - | AMatch v (Branched e) - | AShift Reference e - | AHnd [Reference] v e - | AApp (Func v) [v] - | AFrc v - | AVar v - deriving (Show, Eq) - --- Types representing components that will go into the runtime tag of --- a data type value. RTags correspond to references, while CTags --- correspond to constructors. -newtype RTag = RTag Word64 - deriving stock (Eq, Ord, Show, Read) - deriving newtype (EC.EnumKey) - -newtype CTag = CTag Word16 - deriving stock (Eq, Ord, Show, Read) - deriving newtype (EC.EnumKey) - -class Tag t where rawTag :: t -> Word64 - -instance Tag RTag where rawTag (RTag w) = w - -instance Tag CTag where rawTag (CTag w) = fromIntegral w - -packTags :: RTag -> CTag -> Word64 -packTags (RTag rt) (CTag ct) = ri .|. ci - where - ri = rt `shiftL` 16 - ci = fromIntegral ct - -unpackTags :: Word64 -> (RTag, CTag) -unpackTags w = (RTag $ w `shiftR` 16, CTag . fromIntegral $ w .&. 0xFFFF) - --- Masks a packed tag to extract just the constructor tag portion -maskTags :: Word64 -> Word64 -maskTags w = w .&. 0xFFFF - -ensureRTag :: (Ord n, Show n, Num n) => String -> n -> r -> r -ensureRTag s n x - | n > 0xFFFFFFFFFFFF = - internalBug $ s ++ "@RTag: too large: " ++ show n - | otherwise = x - -ensureCTag :: (Ord n, Show n, Num n) => String -> n -> r -> r -ensureCTag s n x - | n > 0xFFFF = - internalBug $ s ++ "@CTag: too large: " ++ show n - | otherwise = x - -instance Enum RTag where - toEnum i = ensureRTag "toEnum" i . RTag $ toEnum i - fromEnum (RTag w) = fromEnum w - -instance Enum CTag where - toEnum i = ensureCTag "toEnum" i . CTag $ toEnum i - fromEnum (CTag w) = fromEnum w - -instance Num RTag where - fromInteger i = ensureRTag "fromInteger" i . RTag $ fromInteger i - (+) = internalBug "RTag: +" - (*) = internalBug "RTag: *" - abs = internalBug "RTag: abs" - signum = internalBug "RTag: signum" - negate = internalBug "RTag: negate" - -instance Num CTag where - fromInteger i = ensureCTag "fromInteger" i . CTag $ fromInteger i - (+) = internalBug "CTag: +" - (*) = internalBug "CTag: *" - abs = internalBug "CTag: abs" - signum = internalBug "CTag: signum" - negate = internalBug "CTag: negate" - -instance Functor (ANormalF v) where - fmap _ (AVar v) = AVar v - fmap _ (ALit l) = ALit l - fmap _ (ABLit l) = ABLit l - fmap f (ALet d m bn bo) = ALet d m (f bn) (f bo) - fmap f (AName n as bo) = AName n as $ f bo - fmap f (AMatch v br) = AMatch v $ f <$> br - fmap f (AHnd rs h e) = AHnd rs h $ f e - fmap f (AShift i e) = AShift i $ f e - fmap _ (AFrc v) = AFrc v - fmap _ (AApp f args) = AApp f args - -instance Bifunctor ANormalF where - bimap f _ (AVar v) = AVar (f v) - bimap _ _ (ALit l) = ALit l - bimap _ _ (ABLit l) = ABLit l - bimap _ g (ALet d m bn bo) = ALet d m (g bn) (g bo) - bimap f g (AName n as bo) = AName (f <$> n) (f <$> as) $ g bo - bimap f g (AMatch v br) = AMatch (f v) $ fmap g br - bimap f g (AHnd rs v e) = AHnd rs (f v) $ g e - bimap _ g (AShift i e) = AShift i $ g e - bimap f _ (AFrc v) = AFrc (f v) - bimap f _ (AApp fu args) = AApp (fmap f fu) $ fmap f args - -instance Bifoldable ANormalF where - bifoldMap f _ (AVar v) = f v - bifoldMap _ _ (ALit _) = mempty - bifoldMap _ _ (ABLit _) = mempty - bifoldMap _ g (ALet _ _ b e) = g b <> g e - bifoldMap f g (AName n as e) = foldMap f n <> foldMap f as <> g e - bifoldMap f g (AMatch v br) = f v <> foldMap g br - bifoldMap f g (AHnd _ h e) = f h <> g e - bifoldMap _ g (AShift _ e) = g e - bifoldMap f _ (AFrc v) = f v - bifoldMap f _ (AApp func args) = foldMap f func <> foldMap f args - -instance ABTN.Align ANormalF where - align f _ (AVar u) (AVar v) = Just $ AVar <$> f u v - align _ _ (ALit l) (ALit r) - | l == r = Just $ pure (ALit l) - align _ _ (ABLit l) (ABLit r) - | l == r = Just $ pure (ABLit l) - align _ g (ALet dl ccl bl el) (ALet dr ccr br er) - | dl == dr, - ccl == ccr = - Just $ ALet dl ccl <$> g bl br <*> g el er - align f g (AName hl asl el) (AName hr asr er) - | length asl == length asr, - Just hs <- alignEither f hl hr = - Just $ - AName - <$> hs - <*> traverse (uncurry f) (zip asl asr) - <*> g el er - align f g (AMatch vl bsl) (AMatch vr bsr) - | Just bss <- alignBranch g bsl bsr = - Just $ AMatch <$> f vl vr <*> bss - align f g (AHnd rl hl bl) (AHnd rr hr br) - | rl == rr = Just $ AHnd rl <$> f hl hr <*> g bl br - align _ g (AShift rl bl) (AShift rr br) - | rl == rr = Just $ AShift rl <$> g bl br - align f _ (AFrc u) (AFrc v) = Just $ AFrc <$> f u v - align f _ (AApp hl asl) (AApp hr asr) - | Just hs <- alignFunc f hl hr, - length asl == length asr = - Just $ AApp <$> hs <*> traverse (uncurry f) (zip asl asr) - align _ _ _ _ = Nothing - -alignEither :: - (Applicative f) => - (l -> r -> f s) -> - Either Reference l -> - Either Reference r -> - Maybe (f (Either Reference s)) -alignEither _ (Left rl) (Left rr) | rl == rr = Just . pure $ Left rl -alignEither f (Right u) (Right v) = Just $ Right <$> f u v -alignEither _ _ _ = Nothing - -alignMaybe :: - (Applicative f) => - (l -> r -> f s) -> - Maybe l -> - Maybe r -> - Maybe (f (Maybe s)) -alignMaybe f (Just l) (Just r) = Just $ Just <$> f l r -alignMaybe _ Nothing Nothing = Just (pure Nothing) -alignMaybe _ _ _ = Nothing - -alignFunc :: - (Applicative f) => - (vl -> vr -> f vs) -> - Func vl -> - Func vr -> - Maybe (f (Func vs)) -alignFunc f (FVar u) (FVar v) = Just $ FVar <$> f u v -alignFunc _ (FComb rl) (FComb rr) | rl == rr = Just . pure $ FComb rl -alignFunc f (FCont u) (FCont v) = Just $ FCont <$> f u v -alignFunc _ (FCon rl tl) (FCon rr tr) - | rl == rr, tl == tr = Just . pure $ FCon rl tl -alignFunc _ (FReq rl tl) (FReq rr tr) - | rl == rr, tl == tr = Just . pure $ FReq rl tl -alignFunc _ (FPrim ol) (FPrim or) - | ol == or = Just . pure $ FPrim ol -alignFunc _ _ _ = Nothing - -alignBranch :: - (Applicative f) => - (el -> er -> f es) -> - Branched el -> - Branched er -> - Maybe (f (Branched es)) -alignBranch _ MatchEmpty MatchEmpty = Just $ pure MatchEmpty -alignBranch f (MatchIntegral bl dl) (MatchIntegral br dr) - | keysSet bl == keysSet br, - Just ds <- alignMaybe f dl dr = - Just $ - MatchIntegral - <$> interverse f bl br - <*> ds -alignBranch f (MatchText bl dl) (MatchText br dr) - | Map.keysSet bl == Map.keysSet br, - Just ds <- alignMaybe f dl dr = - Just $ - MatchText - <$> traverse id (Map.intersectionWith f bl br) - <*> ds -alignBranch f (MatchRequest bl pl) (MatchRequest br pr) - | Map.keysSet bl == Map.keysSet br, - all p (Map.keysSet bl) = - Just $ - MatchRequest - <$> traverse id (Map.intersectionWith (interverse (alignCCs f)) bl br) - <*> f pl pr - where - p r = keysSet hsl == keysSet hsr && all q (keys hsl) - where - hsl = bl Map.! r - hsr = br Map.! r - q t = fst (hsl ! t) == fst (hsr ! t) -alignBranch f (MatchData rfl bl dl) (MatchData rfr br dr) - | rfl == rfr, - keysSet bl == keysSet br, - all (\t -> fst (bl ! t) == fst (br ! t)) (keys bl), - Just ds <- alignMaybe f dl dr = - Just $ MatchData rfl <$> interverse (alignCCs f) bl br <*> ds -alignBranch f (MatchSum bl) (MatchSum br) - | keysSet bl == keysSet br, - all (\w -> fst (bl ! w) == fst (br ! w)) (keys bl) = - Just $ MatchSum <$> interverse (alignCCs f) bl br -alignBranch f (MatchNumeric rl bl dl) (MatchNumeric rr br dr) - | rl == rr, - keysSet bl == keysSet br, - Just ds <- alignMaybe f dl dr = - Just $ - MatchNumeric rl - <$> interverse f bl br - <*> ds -alignBranch _ _ _ = Nothing - -alignCCs :: (Functor f) => (l -> r -> f s) -> (a, l) -> (a, r) -> f (a, s) -alignCCs f (ccs, l) (_, r) = (,) ccs <$> f l r - -matchLit :: Term v a -> Maybe Lit -matchLit (Int' i) = Just $ I i -matchLit (Nat' n) = Just $ N n -matchLit (Float' f) = Just $ F f -matchLit (Text' t) = Just $ T (Util.Text.fromText t) -matchLit (Char' c) = Just $ C c -matchLit _ = Nothing - -pattern TLet :: - (ABT.Var v) => - Direction Word16 -> - v -> - Mem -> - ABTN.Term ANormalF v -> - ABTN.Term ANormalF v -> - ABTN.Term ANormalF v -pattern TLet d v m bn bo = ABTN.TTm (ALet d [m] bn (ABTN.TAbs v bo)) - -pattern TLetD :: - (ABT.Var v) => - v -> - Mem -> - ABTN.Term ANormalF v -> - ABTN.Term ANormalF v -> - ABTN.Term ANormalF v -pattern TLetD v m bn bo = ABTN.TTm (ALet Direct [m] bn (ABTN.TAbs v bo)) - -pattern TLets :: - (ABT.Var v) => - Direction Word16 -> - [v] -> - [Mem] -> - ABTN.Term ANormalF v -> - ABTN.Term ANormalF v -> - ABTN.Term ANormalF v -pattern TLets d vs ms bn bo = ABTN.TTm (ALet d ms bn (ABTN.TAbss vs bo)) - -pattern TName :: - (ABT.Var v) => - v -> - Either Reference v -> - [v] -> - ABTN.Term ANormalF v -> - ABTN.Term ANormalF v -pattern TName v f as bo = ABTN.TTm (AName f as (ABTN.TAbs v bo)) - -pattern Lit' :: Lit -> Term v a -pattern Lit' l <- (matchLit -> Just l) - -pattern TLit :: - (ABT.Var v) => - Lit -> - ABTN.Term ANormalF v -pattern TLit l = ABTN.TTm (ALit l) - -pattern TBLit :: - (ABT.Var v) => - Lit -> - ABTN.Term ANormalF v -pattern TBLit l = ABTN.TTm (ABLit l) - -pattern TApp :: - (ABT.Var v) => - Func v -> - [v] -> - ABTN.Term ANormalF v -pattern TApp f args = ABTN.TTm (AApp f args) - -pattern AApv :: v -> [v] -> ANormalF v e -pattern AApv v args = AApp (FVar v) args - -pattern TApv :: - (ABT.Var v) => - v -> - [v] -> - ABTN.Term ANormalF v -pattern TApv v args = TApp (FVar v) args - -pattern ACom :: Reference -> [v] -> ANormalF v e -pattern ACom r args = AApp (FComb r) args - -pattern TCom :: - (ABT.Var v) => - Reference -> - [v] -> - ABTN.Term ANormalF v -pattern TCom r args = TApp (FComb r) args - -pattern ACon :: Reference -> CTag -> [v] -> ANormalF v e -pattern ACon r t args = AApp (FCon r t) args - -pattern TCon :: - (ABT.Var v) => - Reference -> - CTag -> - [v] -> - ABTN.Term ANormalF v -pattern TCon r t args = TApp (FCon r t) args - -pattern AKon :: v -> [v] -> ANormalF v e -pattern AKon v args = AApp (FCont v) args - -pattern TKon :: - (ABT.Var v) => - v -> - [v] -> - ABTN.Term ANormalF v -pattern TKon v args = TApp (FCont v) args - -pattern AReq :: Reference -> CTag -> [v] -> ANormalF v e -pattern AReq r t args = AApp (FReq r t) args - -pattern TReq :: - (ABT.Var v) => - Reference -> - CTag -> - [v] -> - ABTN.Term ANormalF v -pattern TReq r t args = TApp (FReq r t) args - -pattern APrm :: POp -> [v] -> ANormalF v e -pattern APrm p args = AApp (FPrim (Left p)) args - -pattern TPrm :: - (ABT.Var v) => - POp -> - [v] -> - ABTN.Term ANormalF v -pattern TPrm p args = TApp (FPrim (Left p)) args - -pattern AFOp :: FOp -> [v] -> ANormalF v e -pattern AFOp p args = AApp (FPrim (Right p)) args - -pattern TFOp :: - (ABT.Var v) => - FOp -> - [v] -> - ABTN.Term ANormalF v -pattern TFOp p args = TApp (FPrim (Right p)) args - -pattern THnd :: - (ABT.Var v) => - [Reference] -> - v -> - ABTN.Term ANormalF v -> - ABTN.Term ANormalF v -pattern THnd rs h b = ABTN.TTm (AHnd rs h b) - -pattern TShift :: - (ABT.Var v) => - Reference -> - v -> - ABTN.Term ANormalF v -> - ABTN.Term ANormalF v -pattern TShift i v e = ABTN.TTm (AShift i (ABTN.TAbs v e)) - -pattern TMatch :: - (ABT.Var v) => - v -> - Branched (ABTN.Term ANormalF v) -> - ABTN.Term ANormalF v -pattern TMatch v cs = ABTN.TTm (AMatch v cs) - -pattern TFrc :: (ABT.Var v) => v -> ABTN.Term ANormalF v -pattern TFrc v = ABTN.TTm (AFrc v) - -pattern TVar :: (ABT.Var v) => v -> ABTN.Term ANormalF v -pattern TVar v = ABTN.TTm (AVar v) - -{-# COMPLETE TLet, TName, TVar, TApp, TFrc, TLit, THnd, TShift, TMatch #-} - -{-# COMPLETE - TLet, - TName, - TVar, - TFrc, - TApv, - TCom, - TCon, - TKon, - TReq, - TPrm, - TFOp, - TLit, - THnd, - TShift, - TMatch - #-} - -bind :: (Var v) => Cte v -> ANormal v -> ANormal v -bind (ST d us ms bu) = TLets d us ms bu -bind (LZ u f as) = TName u f as - -unbind :: (Var v) => ANormal v -> Maybe (Cte v, ANormal v) -unbind (TLets d us ms bu bd) = Just (ST d us ms bu, bd) -unbind (TName u f as bd) = Just (LZ u f as, bd) -unbind _ = Nothing - -unbinds :: (Var v) => ANormal v -> ([Cte v], ANormal v) -unbinds (TLets d us ms bu (unbinds -> (ctx, bd))) = - (ST d us ms bu : ctx, bd) -unbinds (TName u f as (unbinds -> (ctx, bd))) = (LZ u f as : ctx, bd) -unbinds tm = ([], tm) - -pattern TBind :: - (Var v) => - Cte v -> - ANormal v -> - ANormal v -pattern TBind bn bd <- - (unbind -> Just (bn, bd)) - where - TBind bn bd = bind bn bd - -pattern TBinds :: (Var v) => [Cte v] -> ANormal v -> ANormal v -pattern TBinds ctx bd <- - (unbinds -> (ctx, bd)) - where - TBinds ctx bd = foldr bind bd ctx - -{-# COMPLETE TBinds #-} - -data SeqEnd = SLeft | SRight - deriving (Eq, Ord, Enum, Show) - --- Note: MatchNumeric is a new form for matching directly on boxed --- numeric data. This leaves MatchIntegral around so that builtins can --- continue to use it. But interchanged code can be free of unboxed --- details. -data Branched e - = MatchIntegral (EnumMap Word64 e) (Maybe e) - | MatchText (Map.Map Util.Text.Text e) (Maybe e) - | MatchRequest (Map Reference (EnumMap CTag ([Mem], e))) e - | MatchEmpty - | MatchData Reference (EnumMap CTag ([Mem], e)) (Maybe e) - | MatchSum (EnumMap Word64 ([Mem], e)) - | MatchNumeric Reference (EnumMap Word64 e) (Maybe e) - deriving (Show, Eq, Functor, Foldable, Traversable) - --- Data cases expected to cover all constructors -pattern MatchDataCover :: Reference -> EnumMap CTag ([Mem], e) -> Branched e -pattern MatchDataCover r m = MatchData r m Nothing - -data BranchAccum v - = AccumEmpty - | AccumIntegral - Reference - (Maybe (ANormal v)) - (EnumMap Word64 (ANormal v)) - | AccumText - (Maybe (ANormal v)) - (Map.Map Util.Text.Text (ANormal v)) - | AccumDefault (ANormal v) - | AccumPure (ANormal v) - | AccumRequest - (Map Reference (EnumMap CTag ([Mem], ANormal v))) - (Maybe (ANormal v)) - | AccumData - Reference - (Maybe (ANormal v)) - (EnumMap CTag ([Mem], ANormal v)) - | AccumSeqEmpty (ANormal v) - | AccumSeqView - SeqEnd - (Maybe (ANormal v)) -- empty - (ANormal v) -- cons/snoc - | AccumSeqSplit - SeqEnd - Int -- split at - (Maybe (ANormal v)) -- default - (ANormal v) -- split - -instance Semigroup (BranchAccum v) where - AccumEmpty <> r = r - l <> AccumEmpty = l - AccumIntegral rl dl cl <> AccumIntegral rr dr cr - | rl == rr = AccumIntegral rl (dl <|> dr) $ cl <> cr - AccumText dl cl <> AccumText dr cr = - AccumText (dl <|> dr) (cl <> cr) - AccumData rl dl cl <> AccumData rr dr cr - | rl == rr = AccumData rl (dl <|> dr) (cl <> cr) - AccumDefault dl <> AccumIntegral r _ cr = - AccumIntegral r (Just dl) cr - AccumDefault dl <> AccumText _ cr = - AccumText (Just dl) cr - AccumDefault dl <> AccumData rr _ cr = - AccumData rr (Just dl) cr - AccumIntegral r dl cl <> AccumDefault dr = - AccumIntegral r (dl <|> Just dr) cl - AccumText dl cl <> AccumDefault dr = - AccumText (dl <|> Just dr) cl - AccumData rl dl cl <> AccumDefault dr = - AccumData rl (dl <|> Just dr) cl - l@(AccumPure _) <> AccumPure _ = l - AccumPure dl <> AccumRequest hr _ = AccumRequest hr (Just dl) - AccumRequest hl dl <> AccumPure dr = - AccumRequest hl (dl <|> Just dr) - AccumRequest hl dl <> AccumRequest hr dr = - AccumRequest hm $ dl <|> dr - where - hm = Map.unionWith (<>) hl hr - l@(AccumSeqEmpty _) <> AccumSeqEmpty _ = l - AccumSeqEmpty eml <> AccumSeqView er _ cnr = - AccumSeqView er (Just eml) cnr - AccumSeqView el eml cnl <> AccumSeqEmpty emr = - AccumSeqView el (eml <|> Just emr) cnl - AccumSeqView el eml cnl <> AccumSeqView er emr _ - | el /= er = - internalBug "AccumSeqView: trying to merge views of opposite ends" - | otherwise = AccumSeqView el (eml <|> emr) cnl - AccumSeqView _ _ _ <> AccumDefault _ = - internalBug "seq views may not have defaults" - AccumDefault _ <> AccumSeqView _ _ _ = - internalBug "seq views may not have defaults" - AccumSeqSplit el nl dl bl <> AccumSeqSplit er nr dr _ - | el /= er = - internalBug - "AccumSeqSplit: trying to merge splits at opposite ends" - | nl /= nr = - internalBug - "AccumSeqSplit: trying to merge splits at different positions" - | otherwise = - AccumSeqSplit el nl (dl <|> dr) bl - AccumDefault dl <> AccumSeqSplit er nr _ br = - AccumSeqSplit er nr (Just dl) br - AccumSeqSplit el nl dl bl <> AccumDefault dr = - AccumSeqSplit el nl (dl <|> Just dr) bl - _ <> _ = internalBug $ "cannot merge data cases for different types" - -instance Monoid (BranchAccum e) where - mempty = AccumEmpty - --- Foreign operation, indexed by words -type FOp = Word64 - -data Func v - = -- variable - FVar v - | -- top-level combinator - FComb !Reference - | -- continuation jump - FCont v - | -- data constructor - FCon !Reference !CTag - | -- ability request - FReq !Reference !CTag - | -- prim op - FPrim (Either POp FOp) - deriving (Show, Eq, Functor, Foldable, Traversable) - -data Lit - = I Int64 - | N Word64 - | F Double - | T Util.Text.Text - | C Char - | LM Referent - | LY Reference - deriving (Show, Eq) - -litRef :: Lit -> Reference -litRef (I _) = Ty.intRef -litRef (N _) = Ty.natRef -litRef (F _) = Ty.floatRef -litRef (T _) = Ty.textRef -litRef (C _) = Ty.charRef -litRef (LM _) = Ty.termLinkRef -litRef (LY _) = Ty.typeLinkRef - --- Note: Enum/Bounded instances should only be used for things like --- getting a list of all ops. Using auto-generated numberings for --- serialization, for instance, could cause observable changes to --- formats that we want to control and version. -data POp - = -- Int - ADDI - | SUBI - | MULI - | DIVI -- +,-,*,/ - | SGNI - | NEGI - | MODI -- sgn,neg,mod - | POWI - | SHLI - | SHRI -- pow,shiftl,shiftr - | INCI - | DECI - | LEQI - | EQLI -- inc,dec,<=,== - -- Nat - | ADDN - | SUBN - | MULN - | DIVN -- +,-,*,/ - | MODN - | TZRO - | LZRO - | POPC -- mod,trailing/leadingZeros,popCount - | POWN - | SHLN - | SHRN -- pow,shiftl,shiftr - | ANDN - | IORN - | XORN - | COMN -- and,or,xor,complement - | INCN - | DECN - | LEQN - | EQLN -- inc,dec,<=,== - -- Float - | ADDF - | SUBF - | MULF - | DIVF -- +,-,*,/ - | MINF - | MAXF - | LEQF - | EQLF -- min,max,<=,== - | POWF - | EXPF - | SQRT - | LOGF -- pow,exp,sqrt,log - | LOGB -- logBase - | ABSF - | CEIL - | FLOR - | TRNF -- abs,ceil,floor,truncate - | RNDF -- round - -- Trig - | COSF - | ACOS - | COSH - | ACSH -- cos,acos,cosh,acosh - | SINF - | ASIN - | SINH - | ASNH -- sin,asin,sinh,asinh - | TANF - | ATAN - | TANH - | ATNH -- tan,atan,tanh,atanh - | ATN2 -- atan2 - -- Text - | CATT - | TAKT - | DRPT - | SIZT -- ++,take,drop,size - | IXOT -- indexOf - | UCNS - | USNC - | EQLT - | LEQT -- uncons,unsnoc,==,<= - | PAKT - | UPKT -- pack,unpack - -- Sequence - | CATS - | TAKS - | DRPS - | SIZS -- ++,take,drop,size - | CONS - | SNOC - | IDXS - | BLDS -- cons,snoc,at,build - | VWLS - | VWRS - | SPLL - | SPLR -- viewl,viewr,splitl,splitr - -- Bytes - | PAKB - | UPKB - | TAKB - | DRPB -- pack,unpack,take,drop - | IXOB -- indexOf - | IDXB - | SIZB - | FLTB - | CATB -- index,size,flatten,append - -- Conversion - | ITOF - | NTOF - | ITOT - | NTOT - | TTOI - | TTON - | TTOF - | FTOT - | -- Concurrency - FORK - | -- Universal operations - EQLU - | CMPU - | EROR - | -- Code - MISS - | CACH - | LKUP - | LOAD -- isMissing,cache_,lookup,load - | CVLD - | SDBX -- validate, sandbox - | VALU - | TLTT -- value, Term.Link.toText - -- Debug - | PRNT - | INFO - | TRCE - | DBTX - | -- STM - ATOM - | TFRC -- try force - | SDBL -- sandbox link list - | SDBV -- sandbox check for Values - deriving (Show, Eq, Ord, Enum, Bounded) - -type ANormal = ABTN.Term ANormalF - -type Cte v = CTE v (ANormal v) - -type Ctx v = Directed () [Cte v] - -data Direction a = Indirect a | Direct - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) - -directed :: (Foldable f) => f (Cte v) -> Directed () (f (Cte v)) -directed x = (foldMap f x, x) - where - f (ST d _ _ _) = () <$ d - f _ = Direct - -instance (Semigroup a) => Semigroup (Direction a) where - Indirect l <> Indirect r = Indirect $ l <> r - Direct <> r = r - l <> Direct = l - -instance (Semigroup a) => Monoid (Direction a) where - mempty = Direct - -type Directed a = (,) (Direction a) - -type DNormal v = Directed () (ANormal v) - --- Should be a completely closed term -data SuperNormal v = Lambda {conventions :: [Mem], bound :: ANormal v} - deriving (Show, Eq) - -data SuperGroup v = Rec - { group :: [(v, SuperNormal v)], - entry :: SuperNormal v - } - deriving (Show) - -instance (Var v) => Eq (SuperGroup v) where - g0 == g1 | Left _ <- equivocate g0 g1 = False | otherwise = True - --- Failure modes for SuperGroup alpha equivalence test -data SGEqv v - = -- mismatch number of definitions in group - NumDefns (SuperGroup v) (SuperGroup v) - | -- mismatched SuperNormal calling conventions - DefnConventions (SuperNormal v) (SuperNormal v) - | -- mismatched subterms in corresponding definition - Subterms (ANormal v) (ANormal v) - --- Checks if two SuperGroups are equivalent up to renaming. The rest --- of the structure must match on the nose. If the two groups are not --- equivalent, an example of conflicting structure is returned. -equivocate :: - (Var v) => - SuperGroup v -> - SuperGroup v -> - Either (SGEqv v) () -equivocate g0@(Rec bs0 e0) g1@(Rec bs1 e1) - | length bs0 == length bs1 = - traverse_ eqvSN (zip ns0 ns1) *> eqvSN (e0, e1) - | otherwise = Left $ NumDefns g0 g1 - where - (vs0, ns0) = unzip bs0 - (vs1, ns1) = unzip bs1 - vm = Map.fromList (zip vs1 vs0) - - promote (Left (l, r)) = Left $ Subterms l r - promote (Right v) = Right v - - eqvSN (Lambda ccs0 e0, Lambda ccs1 e1) - | ccs0 == ccs1 = promote $ ABTN.alpha vm e0 e1 - eqvSN (n0, n1) = Left $ DefnConventions n0 n1 - -type ANFM v = - ReaderT - (Set v) - (State (Word64, Word16, [(v, SuperNormal v)])) - -type ANFD v = Compose (ANFM v) (Directed ()) - -data GroupRef = GR Reference Word64 - deriving (Show) - -data Value - = Partial GroupRef [Word64] [Value] - | Data Reference Word64 [Word64] [Value] - | Cont [Word64] [Value] Cont - | BLit BLit - deriving (Show) - -data Cont - = KE - | Mark Word64 Word64 [Reference] (Map Reference Value) Cont - | Push Word64 Word64 Word64 Word64 GroupRef Cont - deriving (Show) - -data BLit - = Text Util.Text.Text - | List (Seq Value) - | TmLink Referent - | TyLink Reference - | Bytes Bytes - | Quote Value - | Code (SuperGroup Symbol) - | BArr PA.ByteArray - | Pos Word64 - | Neg Word64 - | Char Char - | Float Double - | Arr (PA.Array Value) - deriving (Show) - -groupVars :: ANFM v (Set v) -groupVars = ask - -bindLocal :: (Ord v) => [v] -> ANFM v r -> ANFM v r -bindLocal vs = local (Set.\\ Set.fromList vs) - -freshANF :: (Var v) => Word64 -> v -freshANF fr = Var.freshenId fr $ typed Var.ANFBlank - -fresh :: (Var v) => ANFM v v -fresh = state $ \(fr, bnd, cs) -> (freshANF fr, (fr + 1, bnd, cs)) - -contextualize :: (Var v) => DNormal v -> ANFM v (Ctx v, v) -contextualize (_, TVar cv) = do - gvs <- groupVars - if cv `Set.notMember` gvs - then pure (pure [], cv) - else do - bv <- fresh - d <- Indirect <$> binder - pure (directed [ST1 d bv BX $ TApv cv []], bv) -contextualize (d0, tm) = do - fv <- fresh - d <- bindDirection d0 - pure ((d0, [ST1 d fv BX tm]), fv) - -binder :: ANFM v Word16 -binder = state $ \(fr, bnd, cs) -> (bnd, (fr, bnd + 1, cs)) - -bindDirection :: Direction a -> ANFM v (Direction Word16) -bindDirection = traverse (const binder) - -record :: (Var v) => (v, SuperNormal v) -> ANFM v () -record p = modify $ \(fr, bnd, to) -> (fr, bnd, p : to) - -superNormalize :: (Var v) => Term v a -> SuperGroup v -superNormalize tm = Rec l c - where - (bs, e) - | LetRecNamed' bs e <- tm = (bs, e) - | otherwise = ([], tm) - grp = Set.fromList $ fst <$> bs - comp = traverse_ superBinding bs *> toSuperNormal e - subc = runReaderT comp grp - (c, (_, _, l)) = runState subc (0, 1, []) - -superBinding :: (Var v) => (v, Term v a) -> ANFM v () -superBinding (v, tm) = do - nf <- toSuperNormal tm - modify $ \(cvs, bnd, ctx) -> (cvs, bnd, (v, nf) : ctx) - -toSuperNormal :: (Var v) => Term v a -> ANFM v (SuperNormal v) -toSuperNormal tm = do - grp <- groupVars - if not . Set.null . (Set.\\ grp) $ freeVars tm - then internalBug $ "free variables in supercombinator: " ++ show tm - else - Lambda (BX <$ vs) . ABTN.TAbss vs . snd - <$> bindLocal vs (anfTerm body) - where - (vs, body) = fromMaybe ([], tm) $ unLams' tm - -anfTerm :: (Var v) => Term v a -> ANFM v (DNormal v) -anfTerm tm = f <$> anfBlock tm - where - -- f = uncurry (liftA2 TBinds) - f ((_, []), dtm) = dtm - f ((_, cx), (_, tm)) = (Indirect (), TBinds cx tm) - -floatableCtx :: (Var v) => Ctx v -> Bool -floatableCtx = all p . snd - where - p (LZ _ _ _) = True - p (ST _ _ _ tm) = q tm - q (TLit _) = True - q (TVar _) = True - q (TCon _ _ _) = True - q _ = False - -anfHandled :: (Var v) => Term v a -> ANFM v (Ctx v, DNormal v) -anfHandled body = - anfBlock body >>= \case - (ctx, (_, t@TCon {})) -> - fresh <&> \v -> - (ctx <> pure [ST1 Direct v BX t], pure $ TVar v) - (ctx, (_, t@(TLit l))) -> - fresh <&> \v -> - (ctx <> pure [ST1 Direct v cc t], pure $ TVar v) - where - cc = case l of T {} -> BX; LM {} -> BX; LY {} -> BX; _ -> UN - p -> pure p - -fls, tru :: (Var v) => ANormal v -fls = TCon Ty.booleanRef 0 [] -tru = TCon Ty.booleanRef 1 [] - --- Helper function for renaming a variable arising from a --- let v = u --- binding during ANF translation. Renames a variable in a --- context, and returns an indication of whether the varible --- was shadowed by one of the context bindings. -renameCtx :: (Var v) => v -> v -> Ctx v -> (Ctx v, Bool) -renameCtx v u (d, ctx) | (ctx, b) <- rn [] ctx = ((d, ctx), b) - where - swap w - | w == v = u - | otherwise = w - - rn acc [] = (reverse acc, False) - rn acc (ST d vs ccs b : es) - | any (== v) vs = (reverse acc ++ e : es, True) - | otherwise = rn (e : acc) es - where - e = ST d vs ccs $ ABTN.rename v u b - rn acc (LZ w f as : es) - | w == v = (reverse acc ++ e : es, True) - | otherwise = rn (e : acc) es - where - e = LZ w (swap <$> f) (swap <$> as) - -anfBlock :: (Var v) => Term v a -> ANFM v (Ctx v, DNormal v) -anfBlock (Var' v) = pure (mempty, pure $ TVar v) -anfBlock (If' c t f) = do - (cctx, cc) <- anfBlock c - (df, cf) <- anfTerm f - (dt, ct) <- anfTerm t - (cx, v) <- contextualize cc - let cases = - MatchData - (Builtin $ Data.Text.pack "Boolean") - (EC.mapSingleton 0 ([], cf)) - (Just ct) - pure (cctx <> cx, (Indirect () <> df <> dt, TMatch v cases)) -anfBlock (And' l r) = do - (lctx, vl) <- anfArg l - (d, tmr) <- anfTerm r - let tree = - TMatch vl . MatchDataCover Ty.booleanRef $ - mapFromList - [ (0, ([], fls)), - (1, ([], tmr)) - ] - pure (lctx, (Indirect () <> d, tree)) -anfBlock (Or' l r) = do - (lctx, vl) <- anfArg l - (d, tmr) <- anfTerm r - let tree = - TMatch vl . MatchDataCover Ty.booleanRef $ - mapFromList - [ (1, ([], tru)), - (0, ([], tmr)) - ] - pure (lctx, (Indirect () <> d, tree)) -anfBlock (Handle' h body) = - anfArg h >>= \(hctx, vh) -> - anfHandled body >>= \case - (ctx, (_, TCom f as)) | floatableCtx ctx -> do - v <- fresh - pure - ( hctx <> ctx <> pure [LZ v (Left f) as], - (Indirect (), TApp (FVar vh) [v]) - ) - (ctx, (_, TApv f as)) | floatableCtx ctx -> do - v <- fresh - pure - ( hctx <> ctx <> pure [LZ v (Right f) as], - (Indirect (), TApp (FVar vh) [v]) - ) - (ctx, (_, TVar v)) | floatableCtx ctx -> do - pure (hctx <> ctx, (Indirect (), TApp (FVar vh) [v])) - p@(_, _) -> - internalBug $ "handle body should be a simple call: " ++ show p -anfBlock (Match' scrut cas) = do - (sctx, sc) <- anfBlock scrut - (cx, v) <- contextualize sc - (d, brn) <- anfCases v cas - fmap (first ((Indirect () <> d) <>)) <$> case brn of - AccumDefault (TBinds (directed -> dctx) df) -> do - pure (sctx <> cx <> dctx, pure df) - AccumRequest _ Nothing -> - internalBug "anfBlock: AccumRequest without default" - AccumPure (ABTN.TAbss us bd) - | [u] <- us, - TBinds (directed -> bx) bd <- bd -> - case cx of - (_, []) -> do - d0 <- Indirect <$> binder - pure (sctx <> pure [ST1 d0 u BX (TFrc v)] <> bx, pure bd) - (d0, [ST1 d1 _ BX tm]) -> - pure (sctx <> (d0, [ST1 d1 u BX tm]) <> bx, pure bd) - _ -> internalBug "anfBlock|AccumPure: impossible" - | otherwise -> internalBug "pure handler with too many variables" - AccumRequest abr (Just df) -> do - (r, vs) <- do - r <- fresh - v <- fresh - gvs <- groupVars - let hfb = ABTN.TAbs v . TMatch v $ MatchRequest abr df - hfvs = Set.toList $ ABTN.freeVars hfb `Set.difference` gvs - record (r, Lambda (BX <$ hfvs ++ [v]) . ABTN.TAbss hfvs $ hfb) - pure (r, hfvs) - hv <- fresh - let (d, msc) - | (d, [ST1 _ _ BX tm]) <- cx = (d, tm) - | (_, [ST _ _ _ _]) <- cx = - internalBug "anfBlock: impossible" - | otherwise = (Indirect (), TFrc v) - pure - ( sctx <> pure [LZ hv (Right r) vs], - (d, THnd (Map.keys abr) hv msc) - ) - AccumText df cs -> - pure (sctx <> cx, pure . TMatch v $ MatchText cs df) - AccumIntegral r df cs -> - pure (sctx <> cx, pure $ TMatch v $ MatchNumeric r cs df) - AccumData r df cs -> - pure (sctx <> cx, pure . TMatch v $ MatchData r cs df) - AccumSeqEmpty _ -> - internalBug "anfBlock: non-exhaustive AccumSeqEmpty" - AccumSeqView en (Just em) bd -> do - r <- fresh - let op - | SLeft <- en = Builtin "List.viewl" - | otherwise = Builtin "List.viewr" - b <- binder - pure - ( sctx - <> cx - <> (Indirect (), [ST1 (Indirect b) r BX (TCom op [v])]), - pure . TMatch r $ - MatchDataCover - Ty.seqViewRef - ( EC.mapFromList - [ (fromIntegral Ty.seqViewEmpty, ([], em)), - (fromIntegral Ty.seqViewElem, ([BX, BX], bd)) - ] - ) - ) - AccumSeqView {} -> - internalBug "anfBlock: non-exhaustive AccumSeqView" - AccumSeqSplit en n mdf bd -> do - i <- fresh - r <- fresh - s <- fresh - b <- binder - let split = ST1 (Indirect b) r BX (TCom op [i, v]) - pure - ( sctx <> cx <> directed [lit i, split], - pure . TMatch r . MatchDataCover Ty.seqViewRef $ - mapFromList - [ (fromIntegral Ty.seqViewEmpty, ([], df s)), - (fromIntegral Ty.seqViewElem, ([BX, BX], bd)) - ] - ) - where - op - | SLeft <- en = Builtin "List.splitLeft" - | otherwise = Builtin "List.splitRight" - lit i = ST1 Direct i BX (TBLit . N $ fromIntegral n) - df n = - fromMaybe - ( TLet Direct n BX (TLit (T "pattern match failure")) $ - TPrm EROR [n, v] - ) - mdf - AccumEmpty -> pure (sctx <> cx, pure $ TMatch v MatchEmpty) -anfBlock (Let1Named' v b e) = - anfBlock b >>= \case - (bctx, (Direct, TVar u)) -> do - (ectx, ce) <- anfBlock e - (ectx, shaded) <- pure $ renameCtx v u ectx - ce <- pure $ if shaded then ce else ABTN.rename v u <$> ce - pure (bctx <> ectx, ce) - (bctx, (d0, cb)) -> bindLocal [v] $ do - (ectx, ce) <- anfBlock e - d <- bindDirection d0 - let octx = bctx <> directed [ST1 d v BX cb] <> ectx - pure (octx, ce) -anfBlock (Apps' (Blank' b) args) = do - nm <- fresh - (actx, cas) <- anfArgs args - pure - ( actx <> pure [ST1 Direct nm BX (TLit (T msg))], - pure $ TPrm EROR (nm : cas) - ) - where - msg = Util.Text.pack . fromMaybe "blank expression" $ nameb b -anfBlock (Apps' f args) = do - (fctx, (d, cf)) <- anfFunc f - (actx, cas) <- anfArgs args - pure (fctx <> actx, (d, TApp cf cas)) -anfBlock (Constructor' (ConstructorReference r t)) = - pure (mempty, pure $ TCon r (fromIntegral t) []) -anfBlock (Request' (ConstructorReference r t)) = - pure (mempty, (Indirect (), TReq r (fromIntegral t) [])) -anfBlock (Boolean' b) = - pure (mempty, pure $ TCon Ty.booleanRef (if b then 1 else 0) []) -anfBlock (Lit' l@(T _)) = - pure (mempty, pure $ TLit l) -anfBlock (Lit' l) = - pure (mempty, pure $ TBLit l) -anfBlock (Ref' r) = pure (mempty, (Indirect (), TCom r [])) -anfBlock (Blank' b) = do - nm <- fresh - ev <- fresh - pure - ( pure - [ ST1 Direct nm BX (TLit (T name)), - ST1 Direct ev BX (TLit (T $ Util.Text.pack msg)) - ], - pure $ TPrm EROR [nm, ev] - ) - where - name = "blank expression" - msg = fromMaybe "blank expression" $ nameb b -anfBlock (TermLink' r) = pure (mempty, pure . TLit $ LM r) -anfBlock (TypeLink' r) = pure (mempty, pure . TLit $ LY r) -anfBlock (List' as) = fmap (pure . TPrm BLDS) <$> anfArgs tms - where - tms = toList as -anfBlock t = internalBug $ "anf: unhandled term: " ++ show t - --- Note: this assumes that patterns have already been translated --- to a state in which every case matches a single layer of data, --- with no guards, and no variables ignored. This is not checked --- completely. -anfInitCase :: - (Var v) => - v -> - MatchCase p (Term v a) -> - ANFD v (BranchAccum v) -anfInitCase u (MatchCase p guard (ABT.AbsN' vs bd)) - | Just _ <- guard = internalBug "anfInitCase: unexpected guard" - | P.Unbound _ <- p, - [] <- vs = - AccumDefault <$> anfBody bd - | P.Var _ <- p, - [v] <- vs = - AccumDefault . ABTN.rename v u <$> anfBody bd - | P.Var _ <- p = - internalBug $ "vars: " ++ show (length vs) - | P.Int _ (fromIntegral -> i) <- p = - AccumIntegral Ty.intRef Nothing . EC.mapSingleton i <$> anfBody bd - | P.Nat _ i <- p = - AccumIntegral Ty.natRef Nothing . EC.mapSingleton i <$> anfBody bd - | P.Char _ c <- p, - w <- fromIntegral $ fromEnum c = - AccumIntegral Ty.charRef Nothing . EC.mapSingleton w <$> anfBody bd - | P.Boolean _ b <- p, - t <- if b then 1 else 0 = - AccumData Ty.booleanRef Nothing - . EC.mapSingleton t - . ([],) - <$> anfBody bd - | P.Text _ t <- p, - [] <- vs = - AccumText Nothing . Map.singleton (Util.Text.fromText t) <$> anfBody bd - | P.Constructor _ (ConstructorReference r t) ps <- p = do - (,) <$> expandBindings ps vs <*> anfBody bd <&> \(us, bd) -> - AccumData r Nothing - . EC.mapSingleton (fromIntegral t) - . (BX <$ us,) - . ABTN.TAbss us - $ bd - | P.EffectPure _ q <- p = - (,) <$> expandBindings [q] vs <*> anfBody bd <&> \(us, bd) -> - AccumPure $ ABTN.TAbss us bd - | P.EffectBind _ (ConstructorReference r t) ps pk <- p = do - (,,) - <$> expandBindings (snoc ps pk) vs - <*> Compose (pure <$> fresh) - <*> anfBody bd - <&> \(exp, kf, bd) -> - let (us, uk) = - maybe (internalBug "anfInitCase: unsnoc impossible") id $ - unsnoc exp - jn = Builtin "jumpCont" - in flip AccumRequest Nothing - . Map.singleton r - . EC.mapSingleton (fromIntegral t) - . (BX <$ us,) - . ABTN.TAbss us - . TShift r kf - . TName uk (Left jn) [kf] - $ bd - | P.SequenceLiteral _ [] <- p = - AccumSeqEmpty <$> anfBody bd - | P.SequenceOp _ l op r <- p, - Concat <- op, - P.SequenceLiteral p ll <- l = do - AccumSeqSplit SLeft (length ll) Nothing - <$> (ABTN.TAbss <$> expandBindings [P.Var p, r] vs <*> anfBody bd) - | P.SequenceOp _ l op r <- p, - Concat <- op, - P.SequenceLiteral p rl <- r = - AccumSeqSplit SLeft (length rl) Nothing - <$> (ABTN.TAbss <$> expandBindings [l, P.Var p] vs <*> anfBody bd) - | P.SequenceOp _ l op r <- p, - dir <- case op of Cons -> SLeft; _ -> SRight = - AccumSeqView dir Nothing - <$> (ABTN.TAbss <$> expandBindings [l, r] vs <*> anfBody bd) - where - anfBody tm = Compose . bindLocal vs $ anfTerm tm -anfInitCase _ (MatchCase p _ _) = - internalBug $ "anfInitCase: unexpected pattern: " ++ show p - -valueTermLinks :: Value -> [Reference] -valueTermLinks = Set.toList . valueLinks f - where - f False r = Set.singleton r - f _ _ = Set.empty - -valueLinks :: (Monoid a) => (Bool -> Reference -> a) -> Value -> a -valueLinks f (Partial (GR cr _) _ bs) = - f False cr <> foldMap (valueLinks f) bs -valueLinks f (Data dr _ _ bs) = - f True dr <> foldMap (valueLinks f) bs -valueLinks f (Cont _ bs k) = - foldMap (valueLinks f) bs <> contLinks f k -valueLinks f (BLit l) = blitLinks f l - -contLinks :: (Monoid a) => (Bool -> Reference -> a) -> Cont -> a -contLinks f (Push _ _ _ _ (GR cr _) k) = - f False cr <> contLinks f k -contLinks f (Mark _ _ ps de k) = - foldMap (f True) ps - <> Map.foldMapWithKey (\k c -> f True k <> valueLinks f c) de - <> contLinks f k -contLinks _ KE = mempty - -blitLinks :: (Monoid a) => (Bool -> Reference -> a) -> BLit -> a -blitLinks f (List s) = foldMap (valueLinks f) s -blitLinks _ _ = mempty - -groupTermLinks :: Var v => SuperGroup v -> [Reference] -groupTermLinks = Set.toList . foldGroupLinks f - where - f False r = Set.singleton r - f _ _ = Set.empty - -overGroupLinks :: - (Var v) => - (Bool -> Reference -> Reference) -> - SuperGroup v -> - SuperGroup v -overGroupLinks f = - runIdentity . traverseGroupLinks (\b -> Identity . f b) - -traverseGroupLinks :: - (Applicative f, Var v) => - (Bool -> Reference -> f Reference) -> - SuperGroup v -> - f (SuperGroup v) -traverseGroupLinks f (Rec bs e) = - Rec <$> (traverse . traverse) (normalLinks f) bs <*> normalLinks f e - -foldGroupLinks :: - (Monoid r, Var v) => - (Bool -> Reference -> r) -> - SuperGroup v -> - r -foldGroupLinks f = getConst . traverseGroupLinks (\b -> Const . f b) - -normalLinks :: - (Applicative f, Var v) => - (Bool -> Reference -> f Reference) -> - SuperNormal v -> - f (SuperNormal v) -normalLinks f (Lambda ccs e) = Lambda ccs <$> anfLinks f e - -anfLinks :: - (Applicative f, Var v) => - (Bool -> Reference -> f Reference) -> - ANormal v -> - f (ANormal v) -anfLinks f (ABTN.Term _ (ABTN.Abs v e)) = - ABTN.TAbs v <$> anfLinks f e -anfLinks f (ABTN.Term _ (ABTN.Tm e)) = - ABTN.TTm <$> anfFLinks f (anfLinks f) e - -anfFLinks :: - (Applicative f) => - (Bool -> Reference -> f Reference) -> - (e -> f e) -> - ANormalF v e -> - f (ANormalF v e) -anfFLinks _ g (ALet d ccs b e) = ALet d ccs <$> g b <*> g e -anfFLinks f g (AName er vs e) = - flip AName vs <$> bitraverse (f False) pure er <*> g e -anfFLinks f g (AMatch v bs) = - AMatch v <$> branchLinks (f True) g bs -anfFLinks f g (AShift r e) = - AShift <$> f True r <*> g e -anfFLinks f g (AHnd rs v e) = - flip AHnd v <$> traverse (f True) rs <*> g e -anfFLinks f _ (AApp fu vs) = flip AApp vs <$> funcLinks f fu -anfFLinks f _ (ALit l) = ALit <$> litLinks f l -anfFLinks _ _ v = pure v - -litLinks :: - (Applicative f) => - (Bool -> Reference -> f Reference) -> - Lit -> - f Lit -litLinks f (LY r) = LY <$> f True r -litLinks f (LM (Con (ConstructorReference r i) t)) = - LM . flip Con t . flip ConstructorReference i <$> f True r -litLinks f (LM (Ref r)) = LM . Ref <$> f False r -litLinks _ v = pure v - -branchLinks :: - (Applicative f) => - (Reference -> f Reference) -> - (e -> f e) -> - Branched e -> - f (Branched e) -branchLinks f g (MatchRequest m e) = - MatchRequest . Map.fromList - <$> traverse (bitraverse f $ (traverse . traverse) g) (Map.toList m) - <*> g e -branchLinks f g (MatchData r m e) = - MatchData <$> f r <*> (traverse . traverse) g m <*> traverse g e -branchLinks _ g (MatchText m e) = - MatchText <$> traverse g m <*> traverse g e -branchLinks _ g (MatchIntegral m e) = - MatchIntegral <$> traverse g m <*> traverse g e -branchLinks _ g (MatchNumeric r m e) = - MatchNumeric r <$> traverse g m <*> traverse g e -branchLinks _ g (MatchSum m) = - MatchSum <$> (traverse . traverse) g m -branchLinks _ _ MatchEmpty = pure MatchEmpty - -funcLinks :: - (Applicative f) => - (Bool -> Reference -> f Reference) -> - Func v -> - f (Func v) -funcLinks f (FComb r) = FComb <$> f False r -funcLinks f (FCon r t) = flip FCon t <$> f True r -funcLinks f (FReq r t) = flip FReq t <$> f True r -funcLinks _ ff = pure ff - -expandBindings' :: - (Var v) => - Word64 -> - [P.Pattern p] -> - [v] -> - Either String (Word64, [v]) -expandBindings' fr [] [] = Right (fr, []) -expandBindings' fr (P.Unbound _ : ps) vs = - fmap (u :) <$> expandBindings' (fr + 1) ps vs - where - u = freshANF fr -expandBindings' fr (P.Var _ : ps) (v : vs) = - fmap (v :) <$> expandBindings' fr ps vs -expandBindings' _ [] (_ : _) = - Left "expandBindings': more bindings than expected" -expandBindings' _ (_ : _) [] = - Left "expandBindings': more patterns than expected" -expandBindings' _ _ _ = - Left $ "expandBindings': unexpected pattern" - -expandBindings :: (Var v) => [P.Pattern p] -> [v] -> ANFD v [v] -expandBindings ps vs = - Compose . state $ \(fr, bnd, co) -> case expandBindings' fr ps vs of - Left err -> internalBug $ err ++ " " ++ show (ps, vs) - Right (fr, l) -> (pure l, (fr, bnd, co)) - -anfCases :: - (Var v) => - v -> - [MatchCase p (Term v a)] -> - ANFM v (Directed () (BranchAccum v)) -anfCases u = getCompose . fmap fold . traverse (anfInitCase u) - -anfFunc :: (Var v) => Term v a -> ANFM v (Ctx v, Directed () (Func v)) -anfFunc (Var' v) = pure (mempty, (Indirect (), FVar v)) -anfFunc (Ref' r) = pure (mempty, (Indirect (), FComb r)) -anfFunc (Constructor' (ConstructorReference r t)) = pure (mempty, (Direct, FCon r $ fromIntegral t)) -anfFunc (Request' (ConstructorReference r t)) = pure (mempty, (Indirect (), FReq r $ fromIntegral t)) -anfFunc tm = do - (fctx, ctm) <- anfBlock tm - (cx, v) <- contextualize ctm - pure (fctx <> cx, (Indirect (), FVar v)) - -anfArg :: (Var v) => Term v a -> ANFM v (Ctx v, v) -anfArg tm = do - (ctx, ctm) <- anfBlock tm - (cx, v) <- contextualize ctm - pure (ctx <> cx, v) - -anfArgs :: (Var v) => [Term v a] -> ANFM v (Ctx v, [v]) -anfArgs tms = first fold . unzip <$> traverse anfArg tms - -indent :: Int -> ShowS -indent ind = showString (replicate (ind * 2) ' ') - -prettyGroup :: (Var v) => String -> SuperGroup v -> ShowS -prettyGroup s (Rec grp ent) = - showString ("let rec[" ++ s ++ "]\n") - . foldr f id grp - . showString "entry" - . prettySuperNormal 1 ent - where - f (v, sn) r = - indent 1 - . pvar v - . prettySuperNormal 2 sn - . showString "\n" - . r - -pvar :: (Var v) => v -> ShowS -pvar v = showString . Data.Text.unpack $ Var.name v - -prettyVars :: (Var v) => [v] -> ShowS -prettyVars = - foldr (\v r -> showString " " . pvar v . r) id - -prettyLVars :: (Var v) => [Mem] -> [v] -> ShowS -prettyLVars [] [] = showString " " -prettyLVars (c : cs) (v : vs) = - showString " " - . showParen True (pvar v . showString ":" . shows c) - . prettyLVars cs vs -prettyLVars [] (_ : _) = internalBug "more variables than conventions" -prettyLVars (_ : _) [] = internalBug "more conventions than variables" - -prettyRBind :: (Var v) => [v] -> ShowS -prettyRBind [] = showString "()" -prettyRBind [v] = pvar v -prettyRBind (v : vs) = - showParen True $ - pvar v . foldr (\v r -> shows v . showString "," . r) id vs - -prettySuperNormal :: (Var v) => Int -> SuperNormal v -> ShowS -prettySuperNormal ind (Lambda ccs (ABTN.TAbss vs tm)) = - prettyLVars ccs vs - . showString "=" - . prettyANF False (ind + 1) tm - -reqSpace :: (Var v) => Bool -> ANormal v -> Bool -reqSpace _ TLets {} = True -reqSpace _ TName {} = True -reqSpace b _ = b - -prettyANF :: (Var v) => Bool -> Int -> ANormal v -> ShowS -prettyANF m ind tm = - prettySpace (reqSpace m tm) ind . case tm of - TLets _ vs _ bn bo -> - prettyRBind vs - . showString " =" - . prettyANF False (ind + 1) bn - . prettyANF True ind bo - TName v f vs bo -> - prettyRBind [v] - . showString " := " - . prettyLZF f - . prettyVars vs - . prettyANF True ind bo - TLit l -> shows l - TFrc v -> showString "!" . pvar v - TVar v -> pvar v - TApp f vs -> prettyFunc f . prettyVars vs - TMatch v bs -> - showString "match " - . pvar v - . showString " with" - . prettyBranches (ind + 1) bs - TShift r v bo -> - showString "shift[" - . shows r - . showString "]" - . prettyVars [v] - . showString "." - . prettyANF False (ind + 1) bo - THnd rs v bo -> - showString "handle" - . prettyRefs rs - . prettyANF False (ind + 1) bo - . showString " with " - . pvar v - _ -> shows tm - -prettySpace :: Bool -> Int -> ShowS -prettySpace False _ = showString " " -prettySpace True ind = showString "\n" . indent ind - -prettyLZF :: (Var v) => Either Reference v -> ShowS -prettyLZF (Left w) = showString "ENV(" . shows w . showString ") " -prettyLZF (Right v) = pvar v . showString " " - -prettyRefs :: [Reference] -> ShowS -prettyRefs [] = showString "{}" -prettyRefs (r : rs) = - showString "{" - . shows r - . foldr (\t r -> shows t . showString "," . r) id rs - . showString "}" - -prettyFunc :: (Var v) => Func v -> ShowS -prettyFunc (FVar v) = pvar v . showString " " -prettyFunc (FCont v) = pvar v . showString " " -prettyFunc (FComb w) = showString "ENV(" . shows w . showString ")" -prettyFunc (FCon r t) = - showString "CON(" - . shows r - . showString "," - . shows t - . showString ")" -prettyFunc (FReq r t) = - showString "REQ(" - . shows r - . showString "," - . shows t - . showString ")" -prettyFunc (FPrim op) = either shows shows op . showString " " - -prettyBranches :: (Var v) => Int -> Branched (ANormal v) -> ShowS -prettyBranches ind bs = case bs of - MatchEmpty -> showString "{}" - MatchIntegral bs df -> - maybe id (\e -> prettyCase ind (showString "_") e id) df - . foldr (uncurry $ prettyCase ind . shows) id (mapToList bs) - MatchText bs df -> - maybe id (\e -> prettyCase ind (showString "_") e id) df - . foldr (uncurry $ prettyCase ind . shows) id (Map.toList bs) - MatchData _ bs df -> - maybe id (\e -> prettyCase ind (showString "_") e id) df - . foldr - (uncurry $ prettyCase ind . shows) - id - (mapToList $ snd <$> bs) - MatchRequest bs df -> - foldr - ( \(r, m) s -> - foldr - (\(c, e) -> prettyCase ind (prettyReq r c) e) - s - (mapToList $ snd <$> m) - ) - (prettyCase ind (prettyReq (0 :: Int) (0 :: Int)) df id) - (Map.toList bs) - MatchSum bs -> - foldr - (uncurry $ prettyCase ind . shows) - id - (mapToList $ snd <$> bs) - MatchNumeric _ bs df -> - maybe id (\e -> prettyCase ind (showString "_") e id) df - . foldr (uncurry $ prettyCase ind . shows) id (mapToList bs) - -- _ -> error "prettyBranches: todo" - where - -- prettyReq :: Reference -> CTag -> ShowS - prettyReq r c = - showString "REQ(" - . shows r - . showString "," - . shows c - . showString ")" - -prettyCase :: (Var v) => Int -> ShowS -> ANormal v -> ShowS -> ShowS -prettyCase ind sc (ABTN.TAbss vs e) r = - showString "\n" - . indent ind - . sc - . prettyVars vs - . showString " ->" - . prettyANF False (ind + 1) e - . r diff --git a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs deleted file mode 100644 index b4e04d40cc..0000000000 --- a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs +++ /dev/null @@ -1,993 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} - -module Unison.Runtime.ANF.Serialize where - -import Control.Monad -import Data.ByteString (ByteString) -import Data.ByteString.Lazy qualified as L -import Data.Bytes.Get hiding (getBytes) -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Bytes.VarInt -import Data.Foldable (traverse_) -import Data.Functor ((<&>)) -import Data.Map as Map (Map, fromList, lookup) -import Data.Maybe (mapMaybe) -import Data.Sequence qualified as Seq -import Data.Serialize.Put (runPutLazy) -import Data.Text (Text) -import Data.Word (Word16, Word32, Word64) -import GHC.Stack -import Unison.ABT.Normalized (Term (..)) -import Unison.Reference (Reference, Reference' (Builtin), pattern Derived) -import Unison.Runtime.ANF as ANF hiding (Tag) -import Unison.Runtime.Array qualified as PA -import Unison.Runtime.Exception -import Unison.Runtime.Serialize -import Unison.Util.EnumContainers qualified as EC -import Unison.Util.Text qualified as Util.Text -import Unison.Var (Type (ANFBlank), Var (..)) -import Prelude hiding (getChar, putChar) - -type Version = Word32 - -data TmTag - = VarT - | ForceT - | AppT - | HandleT - | ShiftT - | MatchT - | LitT - | NameRefT - | NameVarT - | LetDirT - | LetIndT - | BxLitT - -data FnTag - = FVarT - | FCombT - | FContT - | FConT - | FReqT - | FPrimT - | FForeignT - -data MtTag - = MIntT - | MTextT - | MReqT - | MEmptyT - | MDataT - | MSumT - | MNumT - -data LtTag - = IT - | NT - | FT - | TT - | CT - | LMT - | LYT - -data BLTag - = TextT - | ListT - | TmLinkT - | TyLinkT - | BytesT - | QuoteT - | CodeT - | BArrT - | PosT - | NegT - | CharT - | FloatT - | ArrT - -data VaTag = PartialT | DataT | ContT | BLitT - -data CoTag = KET | MarkT | PushT - -instance Tag TmTag where - tag2word = \case - VarT -> 1 - ForceT -> 2 - AppT -> 3 - HandleT -> 4 - ShiftT -> 5 - MatchT -> 6 - LitT -> 7 - NameRefT -> 8 - NameVarT -> 9 - LetDirT -> 10 - LetIndT -> 11 - BxLitT -> 12 - word2tag = \case - 1 -> pure VarT - 2 -> pure ForceT - 3 -> pure AppT - 4 -> pure HandleT - 5 -> pure ShiftT - 6 -> pure MatchT - 7 -> pure LitT - 8 -> pure NameRefT - 9 -> pure NameVarT - 10 -> pure LetDirT - 11 -> pure LetIndT - 12 -> pure BxLitT - n -> unknownTag "TmTag" n - -instance Tag FnTag where - tag2word = \case - FVarT -> 0 - FCombT -> 1 - FContT -> 2 - FConT -> 3 - FReqT -> 4 - FPrimT -> 5 - FForeignT -> 6 - - word2tag = \case - 0 -> pure FVarT - 1 -> pure FCombT - 2 -> pure FContT - 3 -> pure FConT - 4 -> pure FReqT - 5 -> pure FPrimT - 6 -> pure FForeignT - n -> unknownTag "FnTag" n - -instance Tag MtTag where - tag2word = \case - MIntT -> 0 - MTextT -> 1 - MReqT -> 2 - MEmptyT -> 3 - MDataT -> 4 - MSumT -> 5 - MNumT -> 6 - - word2tag = \case - 0 -> pure MIntT - 1 -> pure MTextT - 2 -> pure MReqT - 3 -> pure MEmptyT - 4 -> pure MDataT - 5 -> pure MSumT - 6 -> pure MNumT - n -> unknownTag "MtTag" n - -instance Tag LtTag where - tag2word = \case - IT -> 0 - NT -> 1 - FT -> 2 - TT -> 3 - CT -> 4 - LMT -> 5 - LYT -> 6 - - word2tag = \case - 0 -> pure IT - 1 -> pure NT - 2 -> pure FT - 3 -> pure TT - 4 -> pure CT - 5 -> pure LMT - 6 -> pure LYT - n -> unknownTag "LtTag" n - -instance Tag BLTag where - tag2word = \case - TextT -> 0 - ListT -> 1 - TmLinkT -> 2 - TyLinkT -> 3 - BytesT -> 4 - QuoteT -> 5 - CodeT -> 6 - BArrT -> 7 - PosT -> 8 - NegT -> 9 - CharT -> 10 - FloatT -> 11 - ArrT -> 12 - - word2tag = \case - 0 -> pure TextT - 1 -> pure ListT - 2 -> pure TmLinkT - 3 -> pure TyLinkT - 4 -> pure BytesT - 5 -> pure QuoteT - 6 -> pure CodeT - 7 -> pure BArrT - 8 -> pure PosT - 9 -> pure NegT - 10 -> pure CharT - 11 -> pure FloatT - 12 -> pure ArrT - t -> unknownTag "BLTag" t - -instance Tag VaTag where - tag2word = \case - PartialT -> 0 - DataT -> 1 - ContT -> 2 - BLitT -> 3 - - word2tag = \case - 0 -> pure PartialT - 1 -> pure DataT - 2 -> pure ContT - 3 -> pure BLitT - t -> unknownTag "VaTag" t - -instance Tag CoTag where - tag2word = \case - KET -> 0 - MarkT -> 1 - PushT -> 2 - word2tag = \case - 0 -> pure KET - 1 -> pure MarkT - 2 -> pure PushT - t -> unknownTag "CoTag" t - -index :: (Eq v) => [v] -> v -> Maybe Word64 -index ctx u = go 0 ctx - where - go !_ [] = Nothing - go n (v : vs) - | v == u = Just n - | otherwise = go (n + 1) vs - -deindex :: (HasCallStack) => [v] -> Word64 -> v -deindex [] _ = exn "deindex: bad index" -deindex (v : vs) n - | n == 0 = v - | otherwise = deindex vs (n - 1) - -pushCtx :: [v] -> [v] -> [v] -pushCtx us vs = reverse us ++ vs - -putIndex :: (MonadPut m) => Word64 -> m () -putIndex = serialize . VarInt - -getIndex :: (MonadGet m) => m Word64 -getIndex = unVarInt <$> deserialize - -putVar :: (MonadPut m) => (Eq v) => [v] -> v -> m () -putVar ctx v - | Just i <- index ctx v = putIndex i - | otherwise = exn "putVar: variable not in context" - -getVar :: (MonadGet m) => [v] -> m v -getVar ctx = deindex ctx <$> getIndex - -putArgs :: (MonadPut m) => (Eq v) => [v] -> [v] -> m () -putArgs ctx is = putFoldable (putVar ctx) is - -getArgs :: (MonadGet m) => [v] -> m [v] -getArgs ctx = getList (getVar ctx) - -putCCs :: (MonadPut m) => [Mem] -> m () -putCCs ccs = putLength n *> traverse_ putCC ccs - where - n = length ccs - putCC UN = putWord8 0 - putCC BX = putWord8 1 - -getCCs :: (MonadGet m) => m [Mem] -getCCs = - getList $ - getWord8 <&> \case - 0 -> UN - 1 -> BX - _ -> exn "getCCs: bad calling convention" - --- Serializes a `SuperGroup`. --- --- The Reference map allows certain term references to be switched out --- for a given 64 bit word. This is used when re-hashing intermediate --- code. For actual serialization, the empty map should be used, so --- that the process is reversible. The purpose of this is merely to --- strip out (mutual/)self-references when producing a byte sequence --- to recompute a hash of a connected component of intermediate --- definitons, since it is infeasible to --- --- The EnumMap associates 'foreign' operations with a textual name --- that is used as the serialized representation. Since they are --- generated somewhat dynamically, it is not easy to associate them --- with a fixed numbering like we can with POps. -putGroup :: - (MonadPut m) => - (Var v) => - Map Reference Word64 -> - EC.EnumMap FOp Text -> - SuperGroup v -> - m () -putGroup refrep fops (Rec bs e) = - putLength n - *> traverse_ (putComb refrep fops ctx) cs - *> putComb refrep fops ctx e - where - n = length us - (us, cs) = unzip bs - ctx = pushCtx us [] - -getGroup :: (MonadGet m) => (Var v) => m (SuperGroup v) -getGroup = do - l <- getLength - let n = fromIntegral l - vs = getFresh <$> take l [0 ..] - ctx = pushCtx vs [] - cs <- replicateM l (getComb ctx n) - Rec (zip vs cs) <$> getComb ctx n - -putComb :: - (MonadPut m) => - (Var v) => - Map Reference Word64 -> - EC.EnumMap FOp Text -> - [v] -> - SuperNormal v -> - m () -putComb refrep fops ctx (Lambda ccs (TAbss us e)) = - putCCs ccs *> putNormal refrep fops (pushCtx us ctx) e - -getFresh :: (Var v) => Word64 -> v -getFresh n = freshenId n $ typed ANFBlank - -getComb :: (MonadGet m) => (Var v) => [v] -> Word64 -> m (SuperNormal v) -getComb ctx frsh0 = do - ccs <- getCCs - let us = zipWith (\_ -> getFresh) ccs [frsh0 ..] - frsh = frsh0 + fromIntegral (length ccs) - Lambda ccs . TAbss us <$> getNormal (pushCtx us ctx) frsh - -putNormal :: - (MonadPut m) => - (Var v) => - Map Reference Word64 -> - EC.EnumMap FOp Text -> - [v] -> - ANormal v -> - m () -putNormal refrep fops ctx tm = case tm of - TVar v -> putTag VarT *> putVar ctx v - TFrc v -> putTag ForceT *> putVar ctx v - TApp f as -> putTag AppT *> putFunc refrep fops ctx f *> putArgs ctx as - THnd rs h e -> - putTag HandleT - *> putRefs rs - *> putVar ctx h - *> putNormal refrep fops ctx e - TShift r v e -> - putTag ShiftT *> putReference r *> putNormal refrep fops (v : ctx) e - TMatch v bs -> - putTag MatchT - *> putVar ctx v - *> putBranches refrep fops ctx bs - TLit l -> putTag LitT *> putLit l - TBLit l -> putTag BxLitT *> putLit l - TName v (Left r) as e -> - putTag NameRefT - *> pr - *> putArgs ctx as - *> putNormal refrep fops (v : ctx) e - where - pr - | Just w <- Map.lookup r refrep = putWord64be w - | otherwise = putReference r - TName v (Right u) as e -> - putTag NameVarT - *> putVar ctx u - *> putArgs ctx as - *> putNormal refrep fops (v : ctx) e - TLets Direct us ccs l e -> - putTag LetDirT - *> putCCs ccs - *> putNormal refrep fops ctx l - *> putNormal refrep fops (pushCtx us ctx) e - TLets (Indirect w) us ccs l e -> - putTag LetIndT - *> putWord16be w - *> putCCs ccs - *> putNormal refrep fops ctx l - *> putNormal refrep fops (pushCtx us ctx) e - _ -> exn "putNormal: malformed term" - -getNormal :: (MonadGet m) => (Var v) => [v] -> Word64 -> m (ANormal v) -getNormal ctx frsh0 = - getTag >>= \case - VarT -> TVar <$> getVar ctx - ForceT -> TFrc <$> getVar ctx - AppT -> TApp <$> getFunc ctx <*> getArgs ctx - HandleT -> THnd <$> getRefs <*> getVar ctx <*> getNormal ctx frsh0 - ShiftT -> - flip TShift v <$> getReference <*> getNormal (v : ctx) (frsh0 + 1) - where - v = getFresh frsh0 - MatchT -> TMatch <$> getVar ctx <*> getBranches ctx frsh0 - LitT -> TLit <$> getLit - BxLitT -> TBLit <$> getLit - NameRefT -> - TName v . Left - <$> getReference - <*> getArgs ctx - <*> getNormal (v : ctx) (frsh0 + 1) - where - v = getFresh frsh0 - NameVarT -> - TName v . Right - <$> getVar ctx - <*> getArgs ctx - <*> getNormal (v : ctx) (frsh0 + 1) - where - v = getFresh frsh0 - LetDirT -> do - ccs <- getCCs - let l = length ccs - frsh = frsh0 + fromIntegral l - us = getFresh <$> take l [frsh0 ..] - TLets Direct us ccs - <$> getNormal ctx frsh0 - <*> getNormal (pushCtx us ctx) frsh - LetIndT -> do - w <- getWord16be - ccs <- getCCs - let l = length ccs - frsh = frsh0 + fromIntegral l - us = getFresh <$> take l [frsh0 ..] - TLets (Indirect w) us ccs - <$> getNormal ctx frsh0 - <*> getNormal (pushCtx us ctx) frsh - -putFunc :: - (MonadPut m) => - (Var v) => - Map Reference Word64 -> - EC.EnumMap FOp Text -> - [v] -> - Func v -> - m () -putFunc refrep fops ctx f = case f of - FVar v -> putTag FVarT *> putVar ctx v - FComb r - | Just w <- Map.lookup r refrep -> putTag FCombT *> putWord64be w - | otherwise -> putTag FCombT *> putReference r - FCont v -> putTag FContT *> putVar ctx v - FCon r c -> putTag FConT *> putReference r *> putCTag c - FReq r c -> putTag FReqT *> putReference r *> putCTag c - FPrim (Left p) -> putTag FPrimT *> putPOp p - FPrim (Right f) - | Just nm <- EC.lookup f fops -> - putTag FForeignT *> putText nm - | otherwise -> - exn $ "putFunc: could not serialize foreign operation: " ++ show f - -getFunc :: (MonadGet m) => (Var v) => [v] -> m (Func v) -getFunc ctx = - getTag >>= \case - FVarT -> FVar <$> getVar ctx - FCombT -> FComb <$> getReference - FContT -> FCont <$> getVar ctx - FConT -> FCon <$> getReference <*> getCTag - FReqT -> FReq <$> getReference <*> getCTag - FPrimT -> FPrim . Left <$> getPOp - FForeignT -> exn "getFunc: can't deserialize a foreign func" - -putPOp :: (MonadPut m) => POp -> m () -putPOp op - | Just w <- Map.lookup op pop2word = putWord16be w - | otherwise = exn $ "putPOp: unknown POp: " ++ show op - -getPOp :: (MonadGet m) => m POp -getPOp = - getWord16be >>= \w -> case Map.lookup w word2pop of - Just op -> pure op - Nothing -> exn "getPOp: unknown enum code" - -pOpCode :: POp -> Word16 -pOpCode op = case op of - ADDI -> 0 - SUBI -> 1 - MULI -> 2 - DIVI -> 3 - SGNI -> 4 - NEGI -> 5 - MODI -> 6 - POWI -> 7 - SHLI -> 8 - SHRI -> 9 - INCI -> 10 - DECI -> 11 - LEQI -> 12 - EQLI -> 13 - ADDN -> 14 - SUBN -> 15 - MULN -> 16 - DIVN -> 17 - MODN -> 18 - TZRO -> 19 - LZRO -> 20 - POWN -> 21 - SHLN -> 22 - SHRN -> 23 - ANDN -> 24 - IORN -> 25 - XORN -> 26 - COMN -> 27 - INCN -> 28 - DECN -> 29 - LEQN -> 30 - EQLN -> 31 - ADDF -> 32 - SUBF -> 33 - MULF -> 34 - DIVF -> 35 - MINF -> 36 - MAXF -> 37 - LEQF -> 38 - EQLF -> 39 - POWF -> 40 - EXPF -> 41 - SQRT -> 42 - LOGF -> 43 - LOGB -> 44 - ABSF -> 45 - CEIL -> 46 - FLOR -> 47 - TRNF -> 48 - RNDF -> 49 - COSF -> 50 - ACOS -> 51 - COSH -> 52 - ACSH -> 53 - SINF -> 54 - ASIN -> 55 - SINH -> 56 - ASNH -> 57 - TANF -> 58 - ATAN -> 59 - TANH -> 60 - ATNH -> 61 - ATN2 -> 62 - CATT -> 63 - TAKT -> 64 - DRPT -> 65 - SIZT -> 66 - UCNS -> 67 - USNC -> 68 - EQLT -> 69 - LEQT -> 70 - PAKT -> 71 - UPKT -> 72 - CATS -> 73 - TAKS -> 74 - DRPS -> 75 - SIZS -> 76 - CONS -> 77 - SNOC -> 78 - IDXS -> 79 - BLDS -> 80 - VWLS -> 81 - VWRS -> 82 - SPLL -> 83 - SPLR -> 84 - PAKB -> 85 - UPKB -> 86 - TAKB -> 87 - DRPB -> 88 - IDXB -> 89 - SIZB -> 90 - FLTB -> 91 - CATB -> 92 - ITOF -> 93 - NTOF -> 94 - ITOT -> 95 - NTOT -> 96 - TTOI -> 97 - TTON -> 98 - TTOF -> 99 - FTOT -> 100 - FORK -> 101 - EQLU -> 102 - CMPU -> 103 - EROR -> 104 - PRNT -> 105 - INFO -> 106 - POPC -> 107 - MISS -> 108 - CACH -> 109 - LKUP -> 110 - LOAD -> 111 - CVLD -> 112 - SDBX -> 113 - VALU -> 114 - TLTT -> 115 - TRCE -> 116 - ATOM -> 117 - TFRC -> 118 - DBTX -> 119 - IXOT -> 120 - IXOB -> 121 - SDBL -> 122 - SDBV -> 123 - -pOpAssoc :: [(POp, Word16)] -pOpAssoc = map (\op -> (op, pOpCode op)) [minBound .. maxBound] - -pop2word :: Map POp Word16 -pop2word = fromList pOpAssoc - -word2pop :: Map Word16 POp -word2pop = fromList $ swap <$> pOpAssoc - where - swap (x, y) = (y, x) - -putLit :: (MonadPut m) => Lit -> m () -putLit (I i) = putTag IT *> putInt i -putLit (N n) = putTag NT *> putNat n -putLit (F f) = putTag FT *> putFloat f -putLit (T t) = putTag TT *> putText (Util.Text.toText t) -putLit (C c) = putTag CT *> putChar c -putLit (LM r) = putTag LMT *> putReferent r -putLit (LY r) = putTag LYT *> putReference r - -getLit :: (MonadGet m) => m Lit -getLit = - getTag >>= \case - IT -> I <$> getInt - NT -> N <$> getNat - FT -> F <$> getFloat - TT -> T . Util.Text.fromText <$> getText - CT -> C <$> getChar - LMT -> LM <$> getReferent - LYT -> LY <$> getReference - -putBLit :: (MonadPut m) => BLit -> m () -putBLit (Text t) = putTag TextT *> putText (Util.Text.toText t) -putBLit (List s) = putTag ListT *> putFoldable putValue s -putBLit (TmLink r) = putTag TmLinkT *> putReferent r -putBLit (TyLink r) = putTag TyLinkT *> putReference r -putBLit (Bytes b) = putTag BytesT *> putBytes b -putBLit (Quote v) = putTag QuoteT *> putValue v -putBLit (Code g) = putTag CodeT *> putGroup mempty mempty g -putBLit (BArr a) = putTag BArrT *> putByteArray a -putBLit (Pos n) = putTag PosT *> putPositive n -putBLit (Neg n) = putTag NegT *> putPositive n -putBLit (Char c) = putTag CharT *> putChar c -putBLit (Float d) = putTag FloatT *> putFloat d -putBLit (Arr a) = putTag ArrT *> putFoldable putValue a - -getBLit :: (MonadGet m) => Version -> m BLit -getBLit v = - getTag >>= \case - TextT -> Text . Util.Text.fromText <$> getText - ListT -> List . Seq.fromList <$> getList (getValue v) - TmLinkT -> TmLink <$> getReferent - TyLinkT -> TyLink <$> getReference - BytesT -> Bytes <$> getBytes - QuoteT -> Quote <$> getValue v - CodeT -> Code <$> getGroup - BArrT -> BArr <$> getByteArray - PosT -> Pos <$> getPositive - NegT -> Neg <$> getPositive - CharT -> Char <$> getChar - FloatT -> Float <$> getFloat - ArrT -> Arr . PA.fromList <$> getList (getValue v) - -putRefs :: (MonadPut m) => [Reference] -> m () -putRefs rs = putFoldable putReference rs - -getRefs :: (MonadGet m) => m [Reference] -getRefs = getList getReference - -putBranches :: - (MonadPut m) => - (Var v) => - Map Reference Word64 -> - EC.EnumMap FOp Text -> - [v] -> - Branched (ANormal v) -> - m () -putBranches refrep fops ctx bs = case bs of - MatchEmpty -> putTag MEmptyT - MatchIntegral m df -> do - putTag MIntT - putEnumMap putWord64be (putNormal refrep fops ctx) m - putMaybe df $ putNormal refrep fops ctx - MatchText m df -> do - putTag MTextT - putMap (putText . Util.Text.toText) (putNormal refrep fops ctx) m - putMaybe df $ putNormal refrep fops ctx - MatchRequest m (TAbs v df) -> do - putTag MReqT - putMap putReference (putEnumMap putCTag (putCase refrep fops ctx)) m - putNormal refrep fops (v : ctx) df - MatchData r m df -> do - putTag MDataT - putReference r - putEnumMap putCTag (putCase refrep fops ctx) m - putMaybe df $ putNormal refrep fops ctx - MatchSum m -> do - putTag MSumT - putEnumMap putWord64be (putCase refrep fops ctx) m - MatchNumeric r m df -> do - putTag MNumT - putReference r - putEnumMap putWord64be (putNormal refrep fops ctx) m - putMaybe df $ putNormal refrep fops ctx - _ -> exn "putBranches: malformed intermediate term" - -getBranches :: - (MonadGet m) => (Var v) => [v] -> Word64 -> m (Branched (ANormal v)) -getBranches ctx frsh0 = - getTag >>= \case - MEmptyT -> pure MatchEmpty - MIntT -> - MatchIntegral - <$> getEnumMap getWord64be (getNormal ctx frsh0) - <*> getMaybe (getNormal ctx frsh0) - MTextT -> - MatchText - <$> getMap (Util.Text.fromText <$> getText) (getNormal ctx frsh0) - <*> getMaybe (getNormal ctx frsh0) - MReqT -> - MatchRequest - <$> getMap getReference (getEnumMap getCTag (getCase ctx frsh0)) - <*> (TAbs v <$> getNormal (v : ctx) (frsh0 + 1)) - where - v = getFresh frsh0 - MDataT -> - MatchData - <$> getReference - <*> getEnumMap getCTag (getCase ctx frsh0) - <*> getMaybe (getNormal ctx frsh0) - MSumT -> MatchSum <$> getEnumMap getWord64be (getCase ctx frsh0) - MNumT -> - MatchNumeric - <$> getReference - <*> getEnumMap getWord64be (getNormal ctx frsh0) - <*> getMaybe (getNormal ctx frsh0) - -putCase :: - (MonadPut m) => - (Var v) => - Map Reference Word64 -> - EC.EnumMap FOp Text -> - [v] -> - ([Mem], ANormal v) -> - m () -putCase refrep fops ctx (ccs, (TAbss us e)) = - putCCs ccs *> putNormal refrep fops (pushCtx us ctx) e - -getCase :: (MonadGet m) => (Var v) => [v] -> Word64 -> m ([Mem], ANormal v) -getCase ctx frsh0 = do - ccs <- getCCs - let l = length ccs - frsh = frsh0 + fromIntegral l - us = getFresh <$> take l [frsh0 ..] - (,) ccs . TAbss us <$> getNormal (pushCtx us ctx) frsh - -putCTag :: (MonadPut m) => CTag -> m () -putCTag c = serialize (VarInt $ fromEnum c) - -getCTag :: (MonadGet m) => m CTag -getCTag = toEnum . unVarInt <$> deserialize - -putGroupRef :: (MonadPut m) => GroupRef -> m () -putGroupRef (GR r i) = - putReference r *> putWord64be i - -getGroupRef :: (MonadGet m) => m GroupRef -getGroupRef = GR <$> getReference <*> getWord64be - --- Notes --- --- Starting with version 4 of the value format, it is expected that --- unboxed data does not actually occur in the values being sent. For --- most values this was not a problem: --- --- - Partial applications had no way of directly including unboxed --- values, because they all result from surface level unison --- applications --- - Unboxed values in Data only occurred to represent certain --- builtin types. Those have been replaced by BLits. --- --- However, some work was required to make sure no unboxed data ended --- up in Cont. The runtime has been modified to avoid using the --- unboxed stack in generated code, so now only builtins use it, --- effectively. Since continuations are never captured inside builtins --- (and even if we wanted to do that, we could arrange for a clean --- unboxed stack), this is no longer a problem, either. --- --- So, unboxed data is completely absent from the format. We are now --- exchanging unison surface values, effectively. -putValue :: (MonadPut m) => Value -> m () -putValue (Partial gr [] vs) = - putTag PartialT - *> putGroupRef gr - *> putFoldable putValue vs -putValue Partial {} = - exn "putValue: Partial with unboxed values no longer supported" -putValue (Data r t [] vs) = - putTag DataT - *> putReference r - *> putWord64be t - *> putFoldable putValue vs -putValue Data {} = - exn "putValue: Data with unboxed contents no longer supported" -putValue (Cont [] bs k) = - putTag ContT - *> putFoldable putValue bs - *> putCont k -putValue Cont {} = - exn "putValue: Cont with unboxed stack no longer supported" -putValue (BLit l) = - putTag BLitT *> putBLit l - -getValue :: (MonadGet m) => Version -> m Value -getValue v = - getTag >>= \case - PartialT - | v < 4 -> - Partial <$> getGroupRef <*> getList getWord64be <*> getList (getValue v) - | otherwise -> - flip Partial [] <$> getGroupRef <*> getList (getValue v) - DataT - | v < 4 -> - Data - <$> getReference - <*> getWord64be - <*> getList getWord64be - <*> getList (getValue v) - | otherwise -> - (\r t -> Data r t []) - <$> getReference - <*> getWord64be - <*> getList (getValue v) - ContT - | v < 4 -> - Cont <$> getList getWord64be <*> getList (getValue v) <*> getCont v - | otherwise -> Cont [] <$> getList (getValue v) <*> getCont v - BLitT -> BLit <$> getBLit v - -putCont :: (MonadPut m) => Cont -> m () -putCont KE = putTag KET -putCont (Mark 0 ba rs ds k) = - putTag MarkT - *> putWord64be ba - *> putFoldable putReference rs - *> putMap putReference putValue ds - *> putCont k -putCont Mark {} = - exn "putCont: Mark with unboxed args no longer supported" -putCont (Push 0 j 0 n gr k) = - putTag PushT - *> putWord64be j - *> putWord64be n - *> putGroupRef gr - *> putCont k -putCont Push {} = - exn "putCont: Push with unboxed information no longer supported" - -getCont :: (MonadGet m) => Version -> m Cont -getCont v = - getTag >>= \case - KET -> pure KE - MarkT - | v < 4 -> - Mark - <$> getWord64be - <*> getWord64be - <*> getList getReference - <*> getMap getReference (getValue v) - <*> getCont v - | otherwise -> - Mark 0 - <$> getWord64be - <*> getList getReference - <*> getMap getReference (getValue v) - <*> getCont v - PushT - | v < 4 -> - Push - <$> getWord64be - <*> getWord64be - <*> getWord64be - <*> getWord64be - <*> getGroupRef - <*> getCont v - | otherwise -> - (\j n -> Push 0 j 0 n) - <$> getWord64be - <*> getWord64be - <*> getGroupRef - <*> getCont v - -deserializeGroup :: (Var v) => ByteString -> Either String (SuperGroup v) -deserializeGroup bs = runGetS (getVersion *> getGroup) bs - where - getVersion = - getWord32be >>= \case - 1 -> pure () - 2 -> pure () - n -> fail $ "deserializeGroup: unknown version: " ++ show n - -serializeGroup :: - (Var v) => EC.EnumMap FOp Text -> SuperGroup v -> ByteString -serializeGroup fops sg = runPutS (putVersion *> putGroup mempty fops sg) - where - putVersion = putWord32be codeVersion - --- | Serializes a `SuperGroup` for rehashing. --- --- Expected as arguments are some code, and the `Reference` that --- refers to it. In particular, if the code refers to itself by --- reference, or if the code is part of a mututally-recursive set of --- definitions (which have a common hash), the reference used as part --- of that (mutual) recursion must be supplied. --- --- Using that reference, we find all references in the code to that --- connected component. In the resulting byte string, those references --- are instead replaced by positions in a listing of the connected --- component. This means that the byte string is independent of the --- hash used for the self reference. Only the order matters (which is --- determined by the `Reference`). Then the bytes can be re-hashed to --- establish a new hash for the connected component. This operation --- should be idempotent as long as the indexing is preserved. --- --- Supplying a `Builtin` reference is not supported. Such code --- shouldn't be subject to rehashing. -serializeGroupForRehash :: - Var v => - EC.EnumMap FOp Text -> - Reference -> - SuperGroup v -> - L.ByteString -serializeGroupForRehash _ (Builtin _) _ = - error "serializeForRehash: builtin reference" -serializeGroupForRehash fops (Derived h _) sg = - runPutLazy $ putGroup refrep fops sg - where - f r@(Derived h' i) | h == h' = Just (r, i) - f _ = Nothing - refrep = Map.fromList . mapMaybe f $ groupTermLinks sg - -getVersionedValue :: MonadGet m => m Value -getVersionedValue = getVersion >>= getValue - where - getVersion = - getWord32be >>= \case - n - | n < 1 -> fail $ "deserializeValue: unknown version: " ++ show n - | n < 3 -> fail $ "deserializeValue: unsupported version: " ++ show n - | n <= 4 -> pure n - | otherwise -> fail $ "deserializeValue: unknown version: " ++ show n - -deserializeValue :: ByteString -> Either String Value -deserializeValue bs = runGetS getVersionedValue bs - -serializeValue :: Value -> ByteString -serializeValue v = runPutS (putVersion *> putValue v) - where - putVersion = putWord32be valueVersion - -serializeValueLazy :: Value -> L.ByteString -serializeValueLazy v = runPutLazy (putVersion *> putValue v) - where - putVersion = putWord32be valueVersion - -valueVersion :: Word32 -valueVersion = 4 - -codeVersion :: Word32 -codeVersion = 2 diff --git a/parser-typechecker/src/Unison/Runtime/Array.hs b/parser-typechecker/src/Unison/Runtime/Array.hs deleted file mode 100644 index 2faa68903a..0000000000 --- a/parser-typechecker/src/Unison/Runtime/Array.hs +++ /dev/null @@ -1,384 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE StandaloneKindSignatures #-} - --- This module wraps the operations in the primitive package so that --- bounds checks can be toggled on during the build for debugging --- purposes. It exports the entire API for the three array types --- needed, and adds wrappers for the operations that are unchecked in --- the base library. --- --- Checking is toggled using the `arraychecks` flag. -module Unison.Runtime.Array - ( module EPA, - byteArrayToList, - readArray, - writeArray, - copyArray, - copyMutableArray, - cloneMutableArray, - readByteArray, - writeByteArray, - indexByteArray, - copyByteArray, - copyMutableByteArray, - moveByteArray, - readPrimArray, - writePrimArray, - indexPrimArray, - ) -where - -import Control.Monad.Primitive -import Data.Kind (Constraint) -import Data.Primitive.Array as EPA hiding - ( cloneMutableArray, - copyArray, - copyMutableArray, - readArray, - writeArray, - ) -import Data.Primitive.Array qualified as PA -import Data.Primitive.ByteArray as EPA hiding - ( copyByteArray, - copyMutableByteArray, - indexByteArray, - moveByteArray, - readByteArray, - writeByteArray, - ) -import Data.Primitive.ByteArray qualified as PA -import Data.Primitive.PrimArray as EPA hiding - ( indexPrimArray, - readPrimArray, - writePrimArray, - ) -import Data.Primitive.PrimArray qualified as PA -import Data.Primitive.Types -import Data.Word (Word8) -import GHC.Exts (toList) - -#ifdef ARRAY_CHECK -import GHC.Stack - -type CheckCtx :: Constraint -type CheckCtx = HasCallStack - -type MA = MutableArray -type MBA = MutableByteArray -type A = Array -type BA = ByteArray - --- check index mutable array -checkIMArray - :: CheckCtx - => String - -> (MA s a -> Int -> r) - -> MA s a -> Int -> r -checkIMArray name f arr i - | i < 0 || sizeofMutableArray arr <= i - = error $ name ++ " unsafe check out of bounds: " ++ show i - | otherwise = f arr i -{-# inline checkIMArray #-} - --- check copy array -checkCArray - :: CheckCtx - => String - -> (MA s a -> Int -> A a -> Int -> Int -> r) - -> MA s a -> Int -> A a -> Int -> Int -> r -checkCArray name f dst d src s l - | d < 0 - || s < 0 - || sizeofMutableArray dst < d + l - || sizeofArray src < s + l - = error $ name ++ " unsafe check out of bounds: " ++ show (d, s, l) - | otherwise = f dst d src s l -{-# inline checkCArray #-} - --- check copy mutable array -checkCMArray - :: CheckCtx - => String - -> (MA s a -> Int -> MA s a -> Int -> Int -> r) - -> MA s a -> Int -> MA s a -> Int -> Int -> r -checkCMArray name f dst d src s l - | d < 0 - || s < 0 - || sizeofMutableArray dst < d + l - || sizeofMutableArray src < s + l - = error $ name ++ " unsafe check out of bounds: " ++ show (d, s, l) - | otherwise = f dst d src s l -{-# inline checkCMArray #-} - --- check range mutable array -checkRMArray - :: CheckCtx - => String - -> (MA s a -> Int -> Int -> r) - -> MA s a -> Int -> Int -> r -checkRMArray name f arr o l - | o < 0 || sizeofMutableArray arr < o+l - = error $ name ++ "unsafe check out of bounds: " ++ show (o, l) - | otherwise = f arr o l -{-# inline checkRMArray #-} - --- check index byte array -checkIBArray - :: CheckCtx - => Prim a - => String - -> a - -> (ByteArray -> Int -> r) - -> ByteArray -> Int -> r -checkIBArray name a f arr i - | i < 0 || sizeofByteArray arr `quot` sizeOf a <= i - = error $ name ++ " unsafe check out of bounds: " ++ show i - | otherwise = f arr i -{-# inline checkIBArray #-} - --- check index mutable byte array -checkIMBArray - :: CheckCtx - => Prim a - => String - -> a - -> (MutableByteArray s -> Int -> r) - -> MutableByteArray s -> Int -> r -checkIMBArray name a f arr i - | i < 0 || sizeofMutableByteArray arr `quot` sizeOf a <= i - = error $ name ++ " unsafe check out of bounds: " ++ show i - | otherwise = f arr i -{-# inline checkIMBArray #-} - --- check copy byte array -checkCBArray - :: CheckCtx - => String - -> (MBA s -> Int -> BA -> Int -> Int -> r) - -> MBA s -> Int -> BA -> Int -> Int -> r -checkCBArray name f dst d src s l - | d < 0 - || s < 0 - || sizeofMutableByteArray dst < d + l - || sizeofByteArray src < s + l - = error $ name ++ " unsafe check out of bounds: " ++ show (d, s, l) - | otherwise = f dst d src s l -{-# inline checkCBArray #-} - --- check copy mutable byte array -checkCMBArray - :: CheckCtx - => String - -> (MBA s -> Int -> MBA s -> Int -> Int -> r) - -> MBA s -> Int -> MBA s -> Int -> Int -> r -checkCMBArray name f dst d src s l - | d < 0 - || s < 0 - || sizeofMutableByteArray dst < d + l - || sizeofMutableByteArray src < s + l - = error $ name ++ " unsafe check out of bounds: " ++ show (d, s, l) - | otherwise = f dst d src s l -{-# inline checkCMBArray #-} - --- check index prim array -checkIPArray - :: CheckCtx - => Prim a - => String - -> (PrimArray a -> Int -> r) - -> PrimArray a -> Int -> r -checkIPArray name f arr i - | i < 0 || sizeofPrimArray arr <= i - = error $ name ++ " unsafe check out of bounds: " ++ show i - | otherwise = f arr i -{-# inline checkIPArray #-} - --- check index mutable prim array -checkIMPArray - :: CheckCtx - => Prim a - => String - -> (MutablePrimArray s a -> Int -> r) - -> MutablePrimArray s a -> Int -> r -checkIMPArray name f arr i - | i < 0 || sizeofMutablePrimArray arr <= i - = error $ name ++ " unsafe check out of bounds: " ++ show i - | otherwise = f arr i -{-# inline checkIMPArray #-} - -#else -type CheckCtx :: Constraint -type CheckCtx = () - -checkIMArray, checkIMPArray, checkIPArray :: String -> r -> r -checkCArray, checkCMArray, checkRMArray :: String -> r -> r -checkIMArray _ = id -checkIMPArray _ = id -checkCArray _ = id -checkCMArray _ = id -checkRMArray _ = id -checkIPArray _ = id - -checkIBArray, checkIMBArray :: String -> a -> r -> r -checkCBArray, checkCMBArray :: String -> r -> r -checkIBArray _ _ = id -checkIMBArray _ _ = id -checkCBArray _ = id -checkCMBArray _ = id -#endif - -readArray :: - (CheckCtx) => - (PrimMonad m) => - MutableArray (PrimState m) a -> - Int -> - m a -readArray = checkIMArray "readArray" PA.readArray -{-# INLINE readArray #-} - -writeArray :: - (CheckCtx) => - (PrimMonad m) => - MutableArray (PrimState m) a -> - Int -> - a -> - m () -writeArray = checkIMArray "writeArray" PA.writeArray -{-# INLINE writeArray #-} - -copyArray :: - (CheckCtx) => - (PrimMonad m) => - MutableArray (PrimState m) a -> - Int -> - Array a -> - Int -> - Int -> - m () -copyArray = checkCArray "copyArray" PA.copyArray -{-# INLINE copyArray #-} - -cloneMutableArray :: - (CheckCtx) => - (PrimMonad m) => - MutableArray (PrimState m) a -> - Int -> - Int -> - m (MutableArray (PrimState m) a) -cloneMutableArray = checkRMArray "cloneMutableArray" PA.cloneMutableArray -{-# INLINE cloneMutableArray #-} - -copyMutableArray :: - (CheckCtx) => - (PrimMonad m) => - MutableArray (PrimState m) a -> - Int -> - MutableArray (PrimState m) a -> - Int -> - Int -> - m () -copyMutableArray = checkCMArray "copyMutableArray" PA.copyMutableArray -{-# INLINE copyMutableArray #-} - -readByteArray :: - forall a m. - (CheckCtx) => - (PrimMonad m) => - (Prim a) => - MutableByteArray (PrimState m) -> - Int -> - m a -readByteArray = checkIMBArray @a "readByteArray" undefined PA.readByteArray -{-# INLINE readByteArray #-} - -writeByteArray :: - forall a m. - (CheckCtx) => - (PrimMonad m) => - (Prim a) => - MutableByteArray (PrimState m) -> - Int -> - a -> - m () -writeByteArray = checkIMBArray @a "writeByteArray" undefined PA.writeByteArray -{-# INLINE writeByteArray #-} - -indexByteArray :: - forall a. - (CheckCtx) => - (Prim a) => - ByteArray -> - Int -> - a -indexByteArray = checkIBArray @a "indexByteArray" undefined PA.indexByteArray -{-# INLINE indexByteArray #-} - -copyByteArray :: - (CheckCtx) => - (PrimMonad m) => - MutableByteArray (PrimState m) -> - Int -> - ByteArray -> - Int -> - Int -> - m () -copyByteArray = checkCBArray "copyByteArray" PA.copyByteArray -{-# INLINE copyByteArray #-} - -copyMutableByteArray :: - (CheckCtx) => - (PrimMonad m) => - MutableByteArray (PrimState m) -> - Int -> - MutableByteArray (PrimState m) -> - Int -> - Int -> - m () -copyMutableByteArray = checkCMBArray "copyMutableByteArray" PA.copyMutableByteArray -{-# INLINE copyMutableByteArray #-} - -moveByteArray :: - (CheckCtx) => - (PrimMonad m) => - MutableByteArray (PrimState m) -> - Int -> - MutableByteArray (PrimState m) -> - Int -> - Int -> - m () -moveByteArray = checkCMBArray "moveByteArray" PA.moveByteArray -{-# INLINE moveByteArray #-} - -readPrimArray :: - (CheckCtx) => - (PrimMonad m) => - (Prim a) => - MutablePrimArray (PrimState m) a -> - Int -> - m a -readPrimArray = checkIMPArray "readPrimArray" PA.readPrimArray -{-# INLINE readPrimArray #-} - -writePrimArray :: - (CheckCtx) => - (PrimMonad m) => - (Prim a) => - MutablePrimArray (PrimState m) a -> - Int -> - a -> - m () -writePrimArray = checkIMPArray "writePrimArray" PA.writePrimArray -{-# INLINE writePrimArray #-} - -indexPrimArray :: - (CheckCtx) => - (Prim a) => - PrimArray a -> - Int -> - a -indexPrimArray = checkIPArray "indexPrimArray" PA.indexPrimArray -{-# INLINE indexPrimArray #-} - -byteArrayToList :: ByteArray -> [Word8] -byteArrayToList = toList diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs deleted file mode 100644 index 3feb0d55e0..0000000000 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ /dev/null @@ -1,3671 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Unison.Runtime.Builtin - ( builtinLookup, - builtinTermNumbering, - builtinTypeNumbering, - builtinTermBackref, - builtinTypeBackref, - builtinForeigns, - sandboxedForeigns, - numberedTermLookup, - Sandbox (..), - baseSandboxInfo, - ) -where - -import Control.Concurrent (ThreadId) -import Control.Concurrent as SYS - ( killThread, - threadDelay, - ) -import Control.Concurrent.MVar as SYS -import Control.Concurrent.STM qualified as STM -import Control.DeepSeq (NFData) -import Control.Exception (evaluate) -import Control.Exception.Safe qualified as Exception -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Primitive qualified as PA -import Control.Monad.Reader (ReaderT (..), ask, runReaderT) -import Control.Monad.State.Strict (State, execState, modify) -import Crypto.Error (CryptoError (..), CryptoFailable (..)) -import Crypto.Hash qualified as Hash -import Crypto.MAC.HMAC qualified as HMAC -import Crypto.PubKey.Ed25519 qualified as Ed25519 -import Crypto.PubKey.RSA.PKCS15 qualified as RSA -import Crypto.Random (getRandomBytes) -import Data.Bits (shiftL, shiftR, (.|.)) -import Data.ByteArray qualified as BA -import Data.ByteString (hGet, hGetSome, hPut) -import Data.ByteString.Lazy qualified as L -import Data.Default (def) -import Data.Digest.Murmur64 (asWord64, hash64) -import Data.IORef as SYS - ( IORef, - newIORef, - readIORef, - writeIORef, - ) -import Data.IP (IP) -import Data.Map qualified as Map -import Data.PEM (PEM, pemContent, pemParseLBS) -import Data.Set (insert) -import Data.Set qualified as Set -import Data.Text qualified -import Data.Text.IO qualified as Text.IO -import Data.Time.Clock.POSIX as SYS - ( getPOSIXTime, - posixSecondsToUTCTime, - utcTimeToPOSIXSeconds, - ) -import Data.Time.LocalTime (TimeZone (..), getTimeZone) -import Data.X509 qualified as X -import Data.X509.CertificateStore qualified as X -import Data.X509.Memory qualified as X -import GHC.Conc qualified as STM -import GHC.IO (IO (IO)) -import Network.Simple.TCP as SYS - ( HostPreference (..), - bindSock, - closeSock, - connectSock, - listenSock, - recv, - send, - ) -import Network.Socket as SYS - ( PortNumber, - Socket, - accept, - socketPort, - ) -import Network.TLS as TLS -import Network.TLS.Extra.Cipher as Cipher -import Network.UDP as UDP - ( ClientSockAddr, - ListenSocket, - UDPSocket (..), - clientSocket, - close, - recv, - recvFrom, - send, - sendTo, - serverSocket, - stop, - ) -import System.Clock (Clock (..), getTime, nsec, sec) -import System.Directory as SYS - ( createDirectoryIfMissing, - doesDirectoryExist, - doesPathExist, - getCurrentDirectory, - getDirectoryContents, - getFileSize, - getModificationTime, - getTemporaryDirectory, - removeDirectoryRecursive, - removeFile, - renameDirectory, - renameFile, - setCurrentDirectory, - ) -import System.Environment as SYS - ( getArgs, - getEnv, - ) -import System.Exit as SYS (ExitCode (..)) -import System.FilePath (isPathSeparator) -import System.IO (Handle) -import System.IO as SYS - ( IOMode (..), - hClose, - hGetBuffering, - hGetChar, - hGetEcho, - hIsEOF, - hIsOpen, - hIsSeekable, - hReady, - hSeek, - hSetBuffering, - hSetEcho, - hTell, - openFile, - stderr, - stdin, - stdout, - ) -import System.IO.Temp (createTempDirectory) -import System.Process as SYS - ( getProcessExitCode, - proc, - runInteractiveProcess, - terminateProcess, - waitForProcess, - withCreateProcess, - ) -import System.X509 qualified as X -import Unison.ABT.Normalized hiding (TTm) -import Unison.Builtin qualified as Ty (builtinTypes) -import Unison.Builtin.Decls qualified as Ty -import Unison.Prelude hiding (Text, some) -import Unison.Reference -import Unison.Referent (Referent, pattern Ref) -import Unison.Runtime.ANF as ANF -import Unison.Runtime.ANF.Rehash (checkGroupHashes) -import Unison.Runtime.ANF.Serialize as ANF -import Unison.Runtime.Array qualified as PA -import Unison.Runtime.Crypto.Rsa as Rsa -import Unison.Runtime.Exception (die) -import Unison.Runtime.Foreign - ( Foreign (Wrap), - HashAlgorithm (..), - pattern Failure, - ) -import Unison.Runtime.Foreign qualified as F -import Unison.Runtime.Foreign.Function -import Unison.Runtime.Stack (Closure) -import Unison.Runtime.Stack qualified as Closure -import Unison.Symbol -import Unison.Type (charRef) -import Unison.Type qualified as Ty -import Unison.Util.Bytes qualified as Bytes -import Unison.Util.EnumContainers as EC -import Unison.Util.RefPromise - ( Promise, - Ticket, - casIORef, - newPromise, - peekTicket, - readForCAS, - readPromise, - tryReadPromise, - writePromise, - ) -import Unison.Util.Text (Text) -import Unison.Util.Text qualified as Util.Text -import Unison.Util.Text.Pattern qualified as TPat -import Unison.Var - -type Failure = F.Failure Closure - -freshes :: (Var v) => Int -> [v] -freshes = freshes' mempty - -freshes' :: (Var v) => Set v -> Int -> [v] -freshes' avoid0 = go avoid0 [] - where - go _ vs 0 = vs - go avoid vs n = - let v = freshIn avoid $ typed ANFBlank - in go (insert v avoid) (v : vs) (n - 1) - -class Fresh t where fresh :: t - -fresh1 :: (Var v) => v -fresh1 = head $ freshes 1 - -instance (Var v) => Fresh (v, v) where - fresh = (v1, v2) - where - [v1, v2] = freshes 2 - -instance (Var v) => Fresh (v, v, v) where - fresh = (v1, v2, v3) - where - [v1, v2, v3] = freshes 3 - -instance (Var v) => Fresh (v, v, v, v) where - fresh = (v1, v2, v3, v4) - where - [v1, v2, v3, v4] = freshes 4 - -instance (Var v) => Fresh (v, v, v, v, v) where - fresh = (v1, v2, v3, v4, v5) - where - [v1, v2, v3, v4, v5] = freshes 5 - -instance (Var v) => Fresh (v, v, v, v, v, v) where - fresh = (v1, v2, v3, v4, v5, v6) - where - [v1, v2, v3, v4, v5, v6] = freshes 6 - -instance (Var v) => Fresh (v, v, v, v, v, v, v) where - fresh = (v1, v2, v3, v4, v5, v6, v7) - where - [v1, v2, v3, v4, v5, v6, v7] = freshes 7 - -instance (Var v) => Fresh (v, v, v, v, v, v, v, v) where - fresh = (v1, v2, v3, v4, v5, v6, v7, v8) - where - [v1, v2, v3, v4, v5, v6, v7, v8] = freshes 8 - -instance (Var v) => Fresh (v, v, v, v, v, v, v, v, v) where - fresh = (v1, v2, v3, v4, v5, v6, v7, v8, v9) - where - [v1, v2, v3, v4, v5, v6, v7, v8, v9] = freshes 9 - -instance (Var v) => Fresh (v, v, v, v, v, v, v, v, v, v) where - fresh = (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) - where - [v1, v2, v3, v4, v5, v6, v7, v8, v9, v10] = freshes 10 - -instance (Var v) => Fresh (v, v, v, v, v, v, v, v, v, v, v) where - fresh = (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11) - where - [v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11] = freshes 11 - -instance (Var v) => Fresh (v, v, v, v, v, v, v, v, v, v, v, v, v) where - fresh = (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13) - where - [v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13] = freshes 13 - -instance (Var v) => Fresh (v, v, v, v, v, v, v, v, v, v, v, v, v, v) where - fresh = (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14) - where - [v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14] = freshes 14 - -fls, tru :: (Var v) => ANormal v -fls = TCon Ty.booleanRef 0 [] -tru = TCon Ty.booleanRef 1 [] - -none :: (Var v) => ANormal v -none = TCon Ty.optionalRef (fromIntegral Ty.noneId) [] - -some, left, right :: (Var v) => v -> ANormal v -some a = TCon Ty.optionalRef (fromIntegral Ty.someId) [a] -left x = TCon Ty.eitherRef (fromIntegral Ty.eitherLeftId) [x] -right x = TCon Ty.eitherRef (fromIntegral Ty.eitherRightId) [x] - -seqViewEmpty :: (Var v) => ANormal v -seqViewEmpty = TCon Ty.seqViewRef (fromIntegral Ty.seqViewEmpty) [] - -seqViewElem :: (Var v) => v -> v -> ANormal v -seqViewElem l r = TCon Ty.seqViewRef (fromIntegral Ty.seqViewElem) [l, r] - -boolift :: (Var v) => v -> ANormal v -boolift v = - TMatch v $ MatchIntegral (mapFromList [(0, fls), (1, tru)]) Nothing - -notlift :: (Var v) => v -> ANormal v -notlift v = - TMatch v $ MatchIntegral (mapFromList [(1, fls), (0, tru)]) Nothing - -unbox :: (Var v) => v -> Reference -> v -> ANormal v -> ANormal v -unbox v0 r v b = - TMatch v0 $ - MatchData r (mapSingleton 0 $ ([UN], TAbs v b)) Nothing - -unenum :: (Var v) => Int -> v -> Reference -> v -> ANormal v -> ANormal v -unenum n v0 r v nx = - TMatch v0 $ MatchData r cases Nothing - where - mkCase i = (toEnum i, ([], TLetD v UN (TLit . I $ fromIntegral i) nx)) - cases = mapFromList . fmap mkCase $ [0 .. n - 1] - -unop0 :: (Var v) => Int -> ([v] -> ANormal v) -> SuperNormal v -unop0 n f = - Lambda [BX] - . TAbss [x0] - $ f xs - where - xs@(x0 : _) = freshes (1 + n) - -binop0 :: (Var v) => Int -> ([v] -> ANormal v) -> SuperNormal v -binop0 n f = - Lambda [BX, BX] - . TAbss [x0, y0] - $ f xs - where - xs@(x0 : y0 : _) = freshes (2 + n) - -unop :: (Var v) => POp -> Reference -> SuperNormal v -unop pop rf = unop' pop rf rf - -unop' :: (Var v) => POp -> Reference -> Reference -> SuperNormal v -unop' pop rfi rfo = - unop0 2 $ \[x0, x, r] -> - unbox x0 rfi x - . TLetD r UN (TPrm pop [x]) - $ TCon rfo 0 [r] - -binop :: (Var v) => POp -> Reference -> SuperNormal v -binop pop rf = binop' pop rf rf rf - -binop' :: - (Var v) => - POp -> - Reference -> - Reference -> - Reference -> - SuperNormal v -binop' pop rfx rfy rfr = - binop0 3 $ \[x0, y0, x, y, r] -> - unbox x0 rfx x - . unbox y0 rfy y - . TLetD r UN (TPrm pop [x, y]) - $ TCon rfr 0 [r] - -cmpop :: (Var v) => POp -> Reference -> SuperNormal v -cmpop pop rf = - binop0 3 $ \[x0, y0, x, y, b] -> - unbox x0 rf x - . unbox y0 rf y - . TLetD b UN (TPrm pop [x, y]) - $ boolift b - -cmpopb :: (Var v) => POp -> Reference -> SuperNormal v -cmpopb pop rf = - binop0 3 $ \[x0, y0, x, y, b] -> - unbox x0 rf x - . unbox y0 rf y - . TLetD b UN (TPrm pop [y, x]) - $ boolift b - -cmpopn :: (Var v) => POp -> Reference -> SuperNormal v -cmpopn pop rf = - binop0 3 $ \[x0, y0, x, y, b] -> - unbox x0 rf x - . unbox y0 rf y - . TLetD b UN (TPrm pop [x, y]) - $ notlift b - -cmpopbn :: (Var v) => POp -> Reference -> SuperNormal v -cmpopbn pop rf = - binop0 3 $ \[x0, y0, x, y, b] -> - unbox x0 rf x - . unbox y0 rf y - . TLetD b UN (TPrm pop [y, x]) - $ notlift b - -addi, subi, muli, divi, modi, shli, shri, powi :: (Var v) => SuperNormal v -addi = binop ADDI Ty.intRef -subi = binop SUBI Ty.intRef -muli = binop MULI Ty.intRef -divi = binop DIVI Ty.intRef -modi = binop MODI Ty.intRef -shli = binop' SHLI Ty.intRef Ty.natRef Ty.intRef -shri = binop' SHRI Ty.intRef Ty.natRef Ty.intRef -powi = binop' POWI Ty.intRef Ty.natRef Ty.intRef - -addn, subn, muln, divn, modn, shln, shrn, pown :: (Var v) => SuperNormal v -addn = binop ADDN Ty.natRef -subn = binop' SUBN Ty.natRef Ty.natRef Ty.intRef -muln = binop MULN Ty.natRef -divn = binop DIVN Ty.natRef -modn = binop MODN Ty.natRef -shln = binop SHLN Ty.natRef -shrn = binop SHRN Ty.natRef -pown = binop POWN Ty.natRef - -eqi, eqn, lti, ltn, lei, len :: (Var v) => SuperNormal v -eqi = cmpop EQLI Ty.intRef -lti = cmpopbn LEQI Ty.intRef -lei = cmpop LEQI Ty.intRef -eqn = cmpop EQLN Ty.natRef -ltn = cmpopbn LEQN Ty.natRef -len = cmpop LEQN Ty.natRef - -gti, gtn, gei, gen :: (Var v) => SuperNormal v -gti = cmpopn LEQI Ty.intRef -gei = cmpopb LEQI Ty.intRef -gtn = cmpopn LEQN Ty.intRef -gen = cmpopb LEQN Ty.intRef - -inci, incn :: (Var v) => SuperNormal v -inci = unop INCI Ty.intRef -incn = unop INCN Ty.natRef - -sgni, negi :: (Var v) => SuperNormal v -sgni = unop SGNI Ty.intRef -negi = unop NEGI Ty.intRef - -lzeron, tzeron, lzeroi, tzeroi, popn, popi :: (Var v) => SuperNormal v -lzeron = unop LZRO Ty.natRef -tzeron = unop TZRO Ty.natRef -popn = unop POPC Ty.natRef -popi = unop' POPC Ty.intRef Ty.natRef -lzeroi = unop' LZRO Ty.intRef Ty.natRef -tzeroi = unop' TZRO Ty.intRef Ty.natRef - -andn, orn, xorn, compln, andi, ori, xori, compli :: (Var v) => SuperNormal v -andn = binop ANDN Ty.natRef -orn = binop IORN Ty.natRef -xorn = binop XORN Ty.natRef -compln = unop COMN Ty.natRef -andi = binop ANDN Ty.intRef -ori = binop IORN Ty.intRef -xori = binop XORN Ty.intRef -compli = unop COMN Ty.intRef - -addf, - subf, - mulf, - divf, - powf, - sqrtf, - logf, - logbf :: - (Var v) => SuperNormal v -addf = binop ADDF Ty.floatRef -subf = binop SUBF Ty.floatRef -mulf = binop MULF Ty.floatRef -divf = binop DIVF Ty.floatRef -powf = binop POWF Ty.floatRef -sqrtf = unop SQRT Ty.floatRef -logf = unop LOGF Ty.floatRef -logbf = binop LOGB Ty.floatRef - -expf, absf :: (Var v) => SuperNormal v -expf = unop EXPF Ty.floatRef -absf = unop ABSF Ty.floatRef - -cosf, sinf, tanf, acosf, asinf, atanf :: (Var v) => SuperNormal v -cosf = unop COSF Ty.floatRef -sinf = unop SINF Ty.floatRef -tanf = unop TANF Ty.floatRef -acosf = unop ACOS Ty.floatRef -asinf = unop ASIN Ty.floatRef -atanf = unop ATAN Ty.floatRef - -coshf, - sinhf, - tanhf, - acoshf, - asinhf, - atanhf, - atan2f :: - (Var v) => SuperNormal v -coshf = unop COSH Ty.floatRef -sinhf = unop SINH Ty.floatRef -tanhf = unop TANH Ty.floatRef -acoshf = unop ACSH Ty.floatRef -asinhf = unop ASNH Ty.floatRef -atanhf = unop ATNH Ty.floatRef -atan2f = binop ATN2 Ty.floatRef - -ltf, gtf, lef, gef, eqf, neqf :: (Var v) => SuperNormal v -ltf = cmpopbn LEQF Ty.floatRef -gtf = cmpopn LEQF Ty.floatRef -lef = cmpop LEQF Ty.floatRef -gef = cmpopb LEQF Ty.floatRef -eqf = cmpop EQLF Ty.floatRef -neqf = cmpopn EQLF Ty.floatRef - -minf, maxf :: (Var v) => SuperNormal v -minf = binop MINF Ty.floatRef -maxf = binop MAXF Ty.floatRef - -ceilf, floorf, truncf, roundf, i2f, n2f :: (Var v) => SuperNormal v -ceilf = unop' CEIL Ty.floatRef Ty.intRef -floorf = unop' FLOR Ty.floatRef Ty.intRef -truncf = unop' TRNF Ty.floatRef Ty.intRef -roundf = unop' RNDF Ty.floatRef Ty.intRef -i2f = unop' ITOF Ty.intRef Ty.floatRef -n2f = unop' NTOF Ty.natRef Ty.floatRef - -trni :: (Var v) => SuperNormal v -trni = unop0 3 $ \[x0, x, z, b] -> - unbox x0 Ty.intRef x - . TLetD z UN (TLit $ I 0) - . TLetD b UN (TPrm LEQI [x, z]) - . TMatch b - $ MatchIntegral - (mapSingleton 1 $ TCon Ty.natRef 0 [z]) - (Just $ TCon Ty.natRef 0 [x]) - -modular :: (Var v) => POp -> (Bool -> ANormal v) -> SuperNormal v -modular pop ret = - unop0 3 $ \[x0, x, m, t] -> - unbox x0 Ty.intRef x - . TLetD t UN (TLit $ I 2) - . TLetD m UN (TPrm pop [x, t]) - . TMatch m - $ MatchIntegral - (mapSingleton 1 $ ret True) - (Just $ ret False) - -evni, evnn, oddi, oddn :: (Var v) => SuperNormal v -evni = modular MODI (\b -> if b then fls else tru) -oddi = modular MODI (\b -> if b then tru else fls) -evnn = modular MODN (\b -> if b then fls else tru) -oddn = modular MODN (\b -> if b then tru else fls) - -dropn :: (Var v) => SuperNormal v -dropn = binop0 4 $ \[x0, y0, x, y, b, r] -> - unbox x0 Ty.natRef x - . unbox y0 Ty.natRef y - . TLetD b UN (TPrm LEQN [x, y]) - . TLet - (Indirect 1) - r - UN - ( TMatch b $ - MatchIntegral - (mapSingleton 1 $ TLit $ N 0) - (Just $ TPrm SUBN [x, y]) - ) - $ TCon Ty.natRef 0 [r] - -appendt, taket, dropt, indext, indexb, sizet, unconst, unsnoct :: (Var v) => SuperNormal v -appendt = binop0 0 $ \[x, y] -> TPrm CATT [x, y] -taket = binop0 1 $ \[x0, y, x] -> - unbox x0 Ty.natRef x $ - TPrm TAKT [x, y] -dropt = binop0 1 $ \[x0, y, x] -> - unbox x0 Ty.natRef x $ - TPrm DRPT [x, y] - -atb = binop0 4 $ \[n0, b, n, t, r0, r] -> - unbox n0 Ty.natRef n - . TLetD t UN (TPrm IDXB [n, b]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([], none)), - ( 1, - ( [UN], - TAbs r0 - . TLetD r BX (TCon Ty.natRef 0 [r0]) - $ some r - ) - ) - ] - -indext = binop0 3 $ \[x, y, t, r0, r] -> - TLetD t UN (TPrm IXOT [x, y]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([], none)), - ( 1, - ( [UN], - TAbs r0 - . TLetD r BX (TCon Ty.natRef 0 [r0]) - $ some r - ) - ) - ] - -indexb = binop0 3 $ \[x, y, t, i, r] -> - TLetD t UN (TPrm IXOB [x, y]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([], none)), - ( 1, - ( [UN], - TAbs i - . TLetD r BX (TCon Ty.natRef 0 [i]) - $ some r - ) - ) - ] - -sizet = unop0 1 $ \[x, r] -> - TLetD r UN (TPrm SIZT [x]) $ - TCon Ty.natRef 0 [r] - -unconst = unop0 7 $ \[x, t, c0, c, y, p, u, yp] -> - TLetD t UN (TPrm UCNS [x]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([], none)), - ( 1, - ( [UN, BX], - TAbss [c0, y] - . TLetD u BX (TCon Ty.unitRef 0 []) - . TLetD yp BX (TCon Ty.pairRef 0 [y, u]) - . TLetD c BX (TCon Ty.charRef 0 [c0]) - . TLetD p BX (TCon Ty.pairRef 0 [c, yp]) - $ some p - ) - ) - ] - -unsnoct = unop0 7 $ \[x, t, c0, c, y, p, u, cp] -> - TLetD t UN (TPrm USNC [x]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([], none)), - ( 1, - ( [BX, UN], - TAbss [y, c0] - . TLetD u BX (TCon Ty.unitRef 0 []) - . TLetD c BX (TCon Ty.charRef 0 [c0]) - . TLetD cp BX (TCon Ty.pairRef 0 [c, u]) - . TLetD p BX (TCon Ty.pairRef 0 [y, cp]) - $ some p - ) - ) - ] - -appends, conss, snocs :: (Var v) => SuperNormal v -appends = binop0 0 $ \[x, y] -> TPrm CATS [x, y] -conss = binop0 0 $ \[x, y] -> TPrm CONS [x, y] -snocs = binop0 0 $ \[x, y] -> TPrm SNOC [x, y] - -coerceType :: (Var v) => Reference -> Reference -> SuperNormal v -coerceType fromType toType = unop0 1 $ \[x, r] -> - unbox x fromType r $ - TCon toType 0 [r] - -takes, drops, sizes, ats, emptys :: (Var v) => SuperNormal v -takes = binop0 1 $ \[x0, y, x] -> - unbox x0 Ty.natRef x $ - TPrm TAKS [x, y] -drops = binop0 1 $ \[x0, y, x] -> - unbox x0 Ty.natRef x $ - TPrm DRPS [x, y] -sizes = unop0 1 $ \[x, r] -> - TLetD r UN (TPrm SIZS [x]) $ - TCon Ty.natRef 0 [r] -ats = binop0 3 $ \[x0, y, x, t, r] -> - unbox x0 Ty.natRef x - . TLetD t UN (TPrm IDXS [x, y]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([], none)), - (1, ([BX], TAbs r $ some r)) - ] -emptys = Lambda [] $ TPrm BLDS [] - -viewls, viewrs :: (Var v) => SuperNormal v -viewls = unop0 3 $ \[s, u, h, t] -> - TLetD u UN (TPrm VWLS [s]) - . TMatch u - . MatchSum - $ mapFromList - [ (0, ([], seqViewEmpty)), - (1, ([BX, BX], TAbss [h, t] $ seqViewElem h t)) - ] -viewrs = unop0 3 $ \[s, u, i, l] -> - TLetD u UN (TPrm VWRS [s]) - . TMatch u - . MatchSum - $ mapFromList - [ (0, ([], seqViewEmpty)), - (1, ([BX, BX], TAbss [i, l] $ seqViewElem i l)) - ] - -splitls, splitrs :: (Var v) => SuperNormal v -splitls = binop0 4 $ \[n0, s, n, t, l, r] -> - unbox n0 Ty.natRef n - . TLetD t UN (TPrm SPLL [n, s]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([], seqViewEmpty)), - (1, ([BX, BX], TAbss [l, r] $ seqViewElem l r)) - ] -splitrs = binop0 4 $ \[n0, s, n, t, l, r] -> - unbox n0 Ty.natRef n - . TLetD t UN (TPrm SPLR [n, s]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([], seqViewEmpty)), - (1, ([BX, BX], TAbss [l, r] $ seqViewElem l r)) - ] - -eqt, neqt, leqt, geqt, lesst, great :: SuperNormal Symbol -eqt = binop0 1 $ \[x, y, b] -> - TLetD b UN (TPrm EQLT [x, y]) $ - boolift b -neqt = binop0 1 $ \[x, y, b] -> - TLetD b UN (TPrm EQLT [x, y]) $ - notlift b -leqt = binop0 1 $ \[x, y, b] -> - TLetD b UN (TPrm LEQT [x, y]) $ - boolift b -geqt = binop0 1 $ \[x, y, b] -> - TLetD b UN (TPrm LEQT [y, x]) $ - boolift b -lesst = binop0 1 $ \[x, y, b] -> - TLetD b UN (TPrm LEQT [y, x]) $ - notlift b -great = binop0 1 $ \[x, y, b] -> - TLetD b UN (TPrm LEQT [x, y]) $ - notlift b - -packt, unpackt :: SuperNormal Symbol -packt = unop0 0 $ \[s] -> TPrm PAKT [s] -unpackt = unop0 0 $ \[t] -> TPrm UPKT [t] - -packb, unpackb, emptyb, appendb :: SuperNormal Symbol -packb = unop0 0 $ \[s] -> TPrm PAKB [s] -unpackb = unop0 0 $ \[b] -> TPrm UPKB [b] -emptyb = - Lambda [] - . TLetD es BX (TPrm BLDS []) - $ TPrm PAKB [es] - where - es = fresh1 -appendb = binop0 0 $ \[x, y] -> TPrm CATB [x, y] - -takeb, dropb, atb, sizeb, flattenb :: SuperNormal Symbol -takeb = binop0 1 $ \[n0, b, n] -> - unbox n0 Ty.natRef n $ - TPrm TAKB [n, b] -dropb = binop0 1 $ \[n0, b, n] -> - unbox n0 Ty.natRef n $ - TPrm DRPB [n, b] -sizeb = unop0 1 $ \[b, n] -> - TLetD n UN (TPrm SIZB [b]) $ - TCon Ty.natRef 0 [n] -flattenb = unop0 0 $ \[b] -> TPrm FLTB [b] - -i2t, n2t, f2t :: SuperNormal Symbol -i2t = unop0 1 $ \[n0, n] -> - unbox n0 Ty.intRef n $ - TPrm ITOT [n] -n2t = unop0 1 $ \[n0, n] -> - unbox n0 Ty.natRef n $ - TPrm NTOT [n] -f2t = unop0 1 $ \[f0, f] -> - unbox f0 Ty.floatRef f $ - TPrm FTOT [f] - -t2i, t2n, t2f :: SuperNormal Symbol -t2i = unop0 3 $ \[x, t, n0, n] -> - TLetD t UN (TPrm TTOI [x]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([], none)), - ( 1, - ( [UN], - TAbs n0 - . TLetD n BX (TCon Ty.intRef 0 [n0]) - $ some n - ) - ) - ] -t2n = unop0 3 $ \[x, t, n0, n] -> - TLetD t UN (TPrm TTON [x]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([], none)), - ( 1, - ( [UN], - TAbs n0 - . TLetD n BX (TCon Ty.natRef 0 [n0]) - $ some n - ) - ) - ] -t2f = unop0 3 $ \[x, t, f0, f] -> - TLetD t UN (TPrm TTOF [x]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([], none)), - ( 1, - ( [UN], - TAbs f0 - . TLetD f BX (TCon Ty.floatRef 0 [f0]) - $ some f - ) - ) - ] - -equ :: SuperNormal Symbol -equ = binop0 1 $ \[x, y, b] -> - TLetD b UN (TPrm EQLU [x, y]) $ - boolift b - -cmpu :: SuperNormal Symbol -cmpu = binop0 2 $ \[x, y, c, i] -> - TLetD c UN (TPrm CMPU [x, y]) - . TLetD i UN (TPrm DECI [c]) - $ TCon Ty.intRef 0 [i] - -ltu :: SuperNormal Symbol -ltu = binop0 1 $ \[x, y, c] -> - TLetD c UN (TPrm CMPU [x, y]) - . TMatch c - $ MatchIntegral - (mapFromList [(0, TCon Ty.booleanRef 1 [])]) - (Just $ TCon Ty.booleanRef 0 []) - -gtu :: SuperNormal Symbol -gtu = binop0 1 $ \[x, y, c] -> - TLetD c UN (TPrm CMPU [x, y]) - . TMatch c - $ MatchIntegral - (mapFromList [(2, TCon Ty.booleanRef 1 [])]) - (Just $ TCon Ty.booleanRef 0 []) - -geu :: SuperNormal Symbol -geu = binop0 1 $ \[x, y, c] -> - TLetD c UN (TPrm CMPU [x, y]) - . TMatch c - $ MatchIntegral - (mapFromList [(0, TCon Ty.booleanRef 0 [])]) - (Just $ TCon Ty.booleanRef 1 []) - -leu :: SuperNormal Symbol -leu = binop0 1 $ \[x, y, c] -> - TLetD c UN (TPrm CMPU [x, y]) - . TMatch c - $ MatchIntegral - (mapFromList [(2, TCon Ty.booleanRef 0 [])]) - (Just $ TCon Ty.booleanRef 1 []) - -notb :: SuperNormal Symbol -notb = unop0 0 $ \[b] -> - TMatch b . flip (MatchData Ty.booleanRef) Nothing $ - mapFromList [(0, ([], tru)), (1, ([], fls))] - -orb :: SuperNormal Symbol -orb = binop0 0 $ \[p, q] -> - TMatch p . flip (MatchData Ty.booleanRef) Nothing $ - mapFromList [(1, ([], tru)), (0, ([], TVar q))] - -andb :: SuperNormal Symbol -andb = binop0 0 $ \[p, q] -> - TMatch p . flip (MatchData Ty.booleanRef) Nothing $ - mapFromList [(0, ([], fls)), (1, ([], TVar q))] - --- unsafeCoerce, used for numeric types where conversion is a --- no-op on the representation. Ideally this will be inlined and --- eliminated so that no instruction is necessary. -cast :: Reference -> Reference -> SuperNormal Symbol -cast ri ro = - unop0 1 $ \[x0, x] -> - unbox x0 ri x $ - TCon ro 0 [x] - --- This version of unsafeCoerce is the identity function. It works --- only if the two types being coerced between are actually the same, --- because it keeps the same representation. It is not capable of --- e.g. correctly translating between two types with compatible bit --- representations, because tagging information will be retained. -poly'coerce :: SuperNormal Symbol -poly'coerce = unop0 0 $ \[x] -> TVar x - -jumpk :: SuperNormal Symbol -jumpk = binop0 0 $ \[k, a] -> TKon k [a] - -scope'run :: SuperNormal Symbol -scope'run = - unop0 1 $ \[e, un] -> - TLetD un BX (TCon Ty.unitRef 0 []) $ - TApp (FVar e) [un] - -fork'comp :: SuperNormal Symbol -fork'comp = - Lambda [BX] - . TAbs act - . TLetD unit BX (TCon Ty.unitRef 0 []) - . TName lz (Right act) [unit] - $ TPrm FORK [lz] - where - (act, unit, lz) = fresh - -try'eval :: SuperNormal Symbol -try'eval = - Lambda [BX] - . TAbs act - . TLetD unit BX (TCon Ty.unitRef 0 []) - . TName lz (Right act) [unit] - . TLetD ta UN (TPrm TFRC [lz]) - . TMatch ta - . MatchSum - $ mapFromList - [ exnCase lnk msg xtra any fail, - (1, ([BX], TAbs r (TVar r))) - ] - where - (act, unit, lz, ta, lnk, msg, xtra, any, fail, r) = fresh - -bug :: Util.Text.Text -> SuperNormal Symbol -bug name = - unop0 1 $ \[x, n] -> - TLetD n BX (TLit $ T name) $ - TPrm EROR [n, x] - -watch :: SuperNormal Symbol -watch = - binop0 0 $ \[t, v] -> - TLets Direct [] [] (TPrm PRNT [t]) $ - TVar v - -raise :: SuperNormal Symbol -raise = - unop0 3 $ \[r, f, n, k] -> - TMatch r - . flip MatchRequest (TAbs f $ TVar f) - . Map.singleton Ty.exceptionRef - $ mapSingleton - 0 - ( [BX], - TAbs f - . TShift Ty.exceptionRef k - . TLetD n BX (TLit $ T "builtin.raise") - $ TPrm EROR [n, f] - ) - -gen'trace :: SuperNormal Symbol -gen'trace = - binop0 0 $ \[t, v] -> - TLets Direct [] [] (TPrm TRCE [t, v]) $ - TCon Ty.unitRef 0 [] - -debug'text :: SuperNormal Symbol -debug'text = - unop0 3 $ \[c, r, t, e] -> - TLetD r UN (TPrm DBTX [c]) - . TMatch r - . MatchSum - $ mapFromList - [ (0, ([], none)), - (1, ([BX], TAbs t . TLetD e BX (left t) $ some e)), - (2, ([BX], TAbs t . TLetD e BX (right t) $ some e)) - ] - -code'missing :: SuperNormal Symbol -code'missing = - unop0 1 $ \[link, b] -> - TLetD b UN (TPrm MISS [link]) $ - boolift b - -code'cache :: SuperNormal Symbol -code'cache = unop0 0 $ \[new] -> TPrm CACH [new] - -code'lookup :: SuperNormal Symbol -code'lookup = - unop0 2 $ \[link, t, r] -> - TLetD t UN (TPrm LKUP [link]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([], none)), - (1, ([BX], TAbs r $ some r)) - ] - -code'validate :: SuperNormal Symbol -code'validate = - unop0 6 $ \[item, t, ref, msg, extra, any, fail] -> - TLetD t UN (TPrm CVLD [item]) - . TMatch t - . MatchSum - $ mapFromList - [ ( 1, - ([BX, BX, BX],) - . TAbss [ref, msg, extra] - . TLetD any BX (TCon Ty.anyRef 0 [extra]) - . TLetD fail BX (TCon Ty.failureRef 0 [ref, msg, any]) - $ some fail - ), - ( 0, - ([],) $ - none - ) - ] - -term'link'to'text :: SuperNormal Symbol -term'link'to'text = - unop0 0 $ \[link] -> TPrm TLTT [link] - -value'load :: SuperNormal Symbol -value'load = - unop0 2 $ \[vlu, t, r] -> - TLetD t UN (TPrm LOAD [vlu]) - . TMatch t - . MatchSum - $ mapFromList - [ (0, ([BX], TAbs r $ left r)), - (1, ([BX], TAbs r $ right r)) - ] - -value'create :: SuperNormal Symbol -value'create = unop0 0 $ \[x] -> TPrm VALU [x] - -check'sandbox :: SuperNormal Symbol -check'sandbox = - Lambda [BX, BX] - . TAbss [refs, val] - . TLetD b UN (TPrm SDBX [refs, val]) - $ boolift b - where - (refs, val, b) = fresh - -sandbox'links :: SuperNormal Symbol -sandbox'links = Lambda [BX] . TAbs ln $ TPrm SDBL [ln] - where - ln = fresh1 - -value'sandbox :: SuperNormal Symbol -value'sandbox = - Lambda [BX, BX] - . TAbss [refs, val] - $ TPrm SDBV [refs, val] - where - (refs, val) = fresh - -stm'atomic :: SuperNormal Symbol -stm'atomic = - Lambda [BX] - . TAbs act - . TLetD unit BX (TCon Ty.unitRef 0 []) - . TName lz (Right act) [unit] - $ TPrm ATOM [lz] - where - (act, unit, lz) = fresh - -type ForeignOp = FOp -> ([Mem], ANormal Symbol) - -standard'handle :: ForeignOp -standard'handle instr = - ([BX],) - . TAbss [h0] - . unenum 3 h0 Ty.stdHandleRef h - $ TFOp instr [h] - where - (h0, h) = fresh - -any'construct :: SuperNormal Symbol -any'construct = - unop0 0 $ \[v] -> - TCon Ty.anyRef 0 [v] - -any'extract :: SuperNormal Symbol -any'extract = - unop0 1 $ - \[v, v1] -> - TMatch v $ - MatchData Ty.anyRef (mapSingleton 0 $ ([BX], TAbs v1 (TVar v1))) Nothing - -seek'handle :: ForeignOp -seek'handle instr = - ([BX, BX, BX],) - . TAbss [arg1, arg2, arg3] - . unenum 3 arg2 Ty.seekModeRef seek - . unbox arg3 Ty.intRef nat - . TLetD result UN (TFOp instr [arg1, seek, nat]) - $ outIoFailUnit stack1 stack2 stack3 unit fail result - where - (arg1, arg2, arg3, seek, nat, stack1, stack2, stack3, unit, fail, result) = fresh - -no'buf, line'buf, block'buf, sblock'buf :: (Enum e) => e -no'buf = toEnum $ fromIntegral Ty.bufferModeNoBufferingId -line'buf = toEnum $ fromIntegral Ty.bufferModeLineBufferingId -block'buf = toEnum $ fromIntegral Ty.bufferModeBlockBufferingId -sblock'buf = toEnum $ fromIntegral Ty.bufferModeSizedBlockBufferingId - -infixr 0 --> - -(-->) :: a -> b -> (a, b) -x --> y = (x, y) - --- Box an unboxed value --- Takes the boxed variable, the unboxed variable, and the type of the value -box :: (Var v) => v -> v -> Reference -> Term ANormalF v -> Term ANormalF v -box b u ty = TLetD b BX (TCon ty 0 [u]) - -time'zone :: ForeignOp -time'zone instr = - ([BX],) - . TAbss [bsecs] - . unbox bsecs Ty.intRef secs - . TLets Direct [offset, summer, name] [UN, UN, BX] (TFOp instr [secs]) - . box bsummer summer Ty.natRef - . box boffset offset Ty.intRef - . TLetD un BX (TCon Ty.unitRef 0 []) - . TLetD p2 BX (TCon Ty.pairRef 0 [name, un]) - . TLetD p1 BX (TCon Ty.pairRef 0 [bsummer, p2]) - $ TCon Ty.pairRef 0 [boffset, p1] - where - (secs, bsecs, offset, boffset, summer, bsummer, name, un, p2, p1) = fresh - -start'process :: ForeignOp -start'process instr = - ([BX, BX],) - . TAbss [exe, args] - . TLets Direct [hin, hout, herr, hproc] [BX, BX, BX, BX] (TFOp instr [exe, args]) - . TLetD un BX (TCon Ty.unitRef 0 []) - . TLetD p3 BX (TCon Ty.pairRef 0 [hproc, un]) - . TLetD p2 BX (TCon Ty.pairRef 0 [herr, p3]) - . TLetD p1 BX (TCon Ty.pairRef 0 [hout, p2]) - $ TCon Ty.pairRef 0 [hin, p1] - where - (exe, args, hin, hout, herr, hproc, un, p3, p2, p1) = fresh - -set'buffering :: ForeignOp -set'buffering instr = - ([BX, BX],) - . TAbss [handle, bmode] - . TMatch bmode - . MatchDataCover Ty.bufferModeRef - $ mapFromList - [ no'buf --> [] --> k1 no'buf, - line'buf --> [] --> k1 line'buf, - block'buf --> [] --> k1 block'buf, - sblock'buf - --> [BX] - --> TAbs n - . TMatch n - . MatchDataCover Ty.bufferModeRef - $ mapFromList - [ 0 - --> [UN] - --> TAbs w - . TLetD tag UN (TLit (N sblock'buf)) - $ k2 [tag, w] - ] - ] - where - k1 num = - TLetD tag UN (TLit (N num)) $ - k2 [tag] - k2 args = - TLetD r UN (TFOp instr (handle : args)) $ - outIoFailUnit s1 s2 s3 u f r - (handle, bmode, tag, n, w, s1, s2, s3, u, f, r) = fresh - -get'buffering'output :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> v -> v -> ANormal v -get'buffering'output eitherResult stack1 stack2 stack3 resultTag anyVar failVar successVar = - TMatch eitherResult . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 anyVar failVar, - ( 1, - ([UN],) - . TAbs resultTag - . TMatch resultTag - . MatchSum - $ mapFromList - [ no'buf - --> [] - --> TLetD successVar BX (TCon Ty.bufferModeRef no'buf []) - $ right successVar, - line'buf - --> [] - --> TLetD successVar BX (TCon Ty.bufferModeRef line'buf []) - $ right successVar, - block'buf - --> [] - --> TLetD successVar BX (TCon Ty.bufferModeRef block'buf []) - $ right successVar, - sblock'buf - --> [UN] - --> TAbs stack1 - . TLetD stack2 BX (TCon Ty.natRef 0 [stack1]) - . TLetD successVar BX (TCon Ty.bufferModeRef sblock'buf [stack2]) - $ right successVar - ] - ) - ] - -get'buffering :: ForeignOp -get'buffering = - inBx arg1 eitherResult $ - get'buffering'output eitherResult n n2 n3 resultTag anyVar failVar successVar - where - (arg1, eitherResult, n, n2, n3, resultTag, anyVar, failVar, successVar) = fresh - -crypto'hash :: ForeignOp -crypto'hash instr = - ([BX, BX],) - . TAbss [alg, x] - . TLetD vl BX (TPrm VALU [x]) - $ TFOp instr [alg, vl] - where - (alg, x, vl) = fresh - -murmur'hash :: ForeignOp -murmur'hash instr = - ([BX],) - . TAbss [x] - . TLetD vl BX (TPrm VALU [x]) - . TLetD result UN (TFOp instr [vl]) - $ TCon Ty.natRef 0 [result] - where - (x, vl, result) = fresh - -crypto'hmac :: ForeignOp -crypto'hmac instr = - ([BX, BX, BX],) - . TAbss [alg, by, x] - . TLetD vl BX (TPrm VALU [x]) - $ TFOp instr [alg, by, vl] - where - (alg, by, x, vl) = fresh - --- Input Shape -- these will represent different argument lists a --- foreign might expect --- --- They will be named according to their shape: --- inBx : one boxed input arg --- inNat : one Nat input arg --- inBxBx : two boxed input args --- --- All of these functions will have take (at least) the same three arguments --- --- instr : the foreign instruction to call --- result : a variable containing the result of the foreign call --- cont : a term which will be evaluated when a result from the foreign call is on the stack --- - --- () -> ... -inUnit :: forall v. (Var v) => v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inUnit unit result cont instr = - ([BX], TAbs unit $ TLetD result UN (TFOp instr []) cont) - --- a -> ... -inBx :: forall v. (Var v) => v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBx arg result cont instr = - ([BX],) - . TAbs arg - $ TLetD result UN (TFOp instr [arg]) cont - --- Nat -> ... -inNat :: forall v. (Var v) => v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inNat arg nat result cont instr = - ([BX],) - . TAbs arg - . unbox arg Ty.natRef nat - $ TLetD result UN (TFOp instr [nat]) cont - --- Maybe a -> b -> ... -inMaybeBx :: forall v. (Var v) => v -> v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inMaybeBx arg1 arg2 arg3 mb result cont instr = - ([BX, BX],) - . TAbss [arg1, arg2] - . TMatch arg1 - . flip (MatchData Ty.optionalRef) Nothing - $ mapFromList - [ ( fromIntegral Ty.noneId, - ( [], - TLetD mb UN (TLit $ I 0) $ - TLetD result UN (TFOp instr [mb, arg2]) cont - ) - ), - (fromIntegral Ty.someId, ([BX], TAbs arg3 . TLetD mb UN (TLit $ I 1) $ TLetD result UN (TFOp instr [mb, arg3, arg2]) cont)) - ] - --- a -> b -> ... -inBxBx :: forall v. (Var v) => v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBxBx arg1 arg2 result cont instr = - ([BX, BX],) - . TAbss [arg1, arg2] - $ TLetD result UN (TFOp instr [arg1, arg2]) cont - --- a -> b -> c -> ... -inBxBxBx :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBxBxBx arg1 arg2 arg3 result cont instr = - ([BX, BX, BX],) - . TAbss [arg1, arg2, arg3] - $ TLetD result UN (TFOp instr [arg1, arg2, arg3]) cont - -set'echo :: ForeignOp -set'echo instr = - ([BX, BX],) - . TAbss [arg1, arg2] - . unenum 2 arg2 Ty.booleanRef bol - . TLetD result UN (TFOp instr [arg1, bol]) - $ outIoFailUnit stack1 stack2 stack3 unit fail result - where - (arg1, arg2, bol, stack1, stack2, stack3, unit, fail, result) = fresh - --- a -> Nat -> ... -inBxNat :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBxNat arg1 arg2 nat result cont instr = - ([BX, BX],) - . TAbss [arg1, arg2] - . unbox arg2 Ty.natRef nat - $ TLetD result UN (TFOp instr [arg1, nat]) cont - -inBxNatNat :: - (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBxNatNat arg1 arg2 arg3 nat1 nat2 result cont instr = - ([BX, BX, BX],) - . TAbss [arg1, arg2, arg3] - . unbox arg2 Ty.natRef nat1 - . unbox arg3 Ty.natRef nat2 - $ TLetD result UN (TFOp instr [arg1, nat1, nat2]) cont - -inBxNatBx :: (Var v) => v -> v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBxNatBx arg1 arg2 arg3 nat result cont instr = - ([BX, BX, BX],) - . TAbss [arg1, arg2, arg3] - . unbox arg2 Ty.natRef nat - $ TLetD result UN (TFOp instr [arg1, nat, arg3]) cont - --- a -> IOMode -> ... -inBxIomr :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBxIomr arg1 arg2 fm result cont instr = - ([BX, BX],) - . TAbss [arg1, arg2] - . unenum 4 arg2 Ty.fileModeRef fm - $ TLetD result UN (TFOp instr [arg1, fm]) cont - --- Output Shape -- these will represent different ways of translating --- the result of a foreign call to a Unison Term --- --- They will be named according to the output type --- outInt : a foreign function returning an Int --- outBool : a foreign function returning a boolean --- outIOFail : a function returning (Either Failure a) --- --- All of these functions will take a Var named result containing the --- result of the foreign call --- - -outMaybe :: forall v. (Var v) => v -> v -> ANormal v -outMaybe maybe result = - TMatch result . MatchSum $ - mapFromList - [ (0, ([], none)), - (1, ([BX], TAbs maybe $ some maybe)) - ] - -outMaybeNat :: (Var v) => v -> v -> v -> ANormal v -outMaybeNat tag result n = - TMatch tag . MatchSum $ - mapFromList - [ (0, ([], none)), - ( 1, - ( [UN], - TAbs result - . TLetD n BX (TCon Ty.natRef 0 [n]) - $ some n - ) - ) - ] - -outMaybeNTup :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> v -> ANormal v -outMaybeNTup a b n u bp p result = - TMatch result . MatchSum $ - mapFromList - [ (0, ([], none)), - ( 1, - ( [UN, BX], - TAbss [a, b] - . TLetD u BX (TCon Ty.unitRef 0 []) - . TLetD bp BX (TCon Ty.pairRef 0 [b, u]) - . TLetD n BX (TCon Ty.natRef 0 [a]) - . TLetD p BX (TCon Ty.pairRef 0 [n, bp]) - $ some p - ) - ) - ] - -outMaybeTup :: (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outMaybeTup a b u bp ap result = - TMatch result . MatchSum $ - mapFromList - [ (0, ([], none)), - ( 1, - ( [BX, BX], - TAbss [a, b] - . TLetD u BX (TCon Ty.unitRef 0 []) - . TLetD bp BX (TCon Ty.pairRef 0 [b, u]) - . TLetD ap BX (TCon Ty.pairRef 0 [a, bp]) - $ some ap - ) - ) - ] - --- Note: the Io part doesn't really do anything. There's no actual --- representation of `IO`. -outIoFail :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoFail stack1 stack2 stack3 any fail result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 any fail, - (1, ([BX], TAbs stack1 $ right stack1)) - ] - -outIoFailNat :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoFailNat stack1 stack2 stack3 fail extra result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 extra fail, - ( 1, - ([UN],) - . TAbs stack3 - . TLetD extra BX (TCon Ty.natRef 0 [stack3]) - $ right extra - ) - ] - -outIoFailChar :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoFailChar stack1 stack2 stack3 fail extra result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 extra fail, - ( 1, - ([UN],) - . TAbs stack3 - . TLetD extra BX (TCon Ty.charRef 0 [stack3]) - $ right extra - ) - ] - -failureCase :: - (Var v) => v -> v -> v -> v -> v -> (Word64, ([Mem], ANormal v)) -failureCase stack1 stack2 stack3 any fail = - (0,) - . ([BX, BX, BX],) - . TAbss [stack1, stack2, stack3] - . TLetD any BX (TCon Ty.anyRef 0 [stack3]) - . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2, any]) - $ left fail - -exnCase :: - (Var v) => v -> v -> v -> v -> v -> (Word64, ([Mem], ANormal v)) -exnCase stack1 stack2 stack3 any fail = - (0,) - . ([BX, BX, BX],) - . TAbss [stack1, stack2, stack3] - . TLetD any BX (TCon Ty.anyRef 0 [stack3]) - . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2, any]) - $ TReq Ty.exceptionRef 0 [fail] - -outIoExnNat :: - forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoExnNat stack1 stack2 stack3 any fail result = - TMatch result . MatchSum $ - mapFromList - [ exnCase stack1 stack2 stack3 any fail, - ( 1, - ([UN],) - . TAbs stack1 - $ TCon Ty.natRef 0 [stack1] - ) - ] - -outIoExnUnit :: - forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoExnUnit stack1 stack2 stack3 any fail result = - TMatch result . MatchSum $ - mapFromList - [ exnCase stack1 stack2 stack3 any fail, - (1, ([], TCon Ty.unitRef 0 [])) - ] - -outIoExnBox :: - (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoExnBox stack1 stack2 stack3 any fail result = - TMatch result . MatchSum $ - mapFromList - [ exnCase stack1 stack2 stack3 any fail, - (1, ([BX], TAbs stack1 $ TVar stack1)) - ] - -outIoExnEBoxBox :: - (Var v) => v -> v -> v -> v -> v -> v -> v -> v -> ANormal v -outIoExnEBoxBox stack1 stack2 stack3 any fail t0 t1 res = - TMatch t0 . MatchSum $ - mapFromList - [ exnCase stack1 stack2 stack3 any fail, - ( 1, - ([UN],) - . TAbs t1 - . TMatch t1 - . MatchSum - $ mapFromList - [ (0, ([BX], TAbs res $ left res)), - (1, ([BX], TAbs res $ right res)) - ] - ) - ] - -outIoFailBox :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoFailBox stack1 stack2 stack3 any fail result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 any fail, - ( 1, - ([BX],) - . TAbs stack1 - $ right stack1 - ) - ] - -outIoFailUnit :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoFailUnit stack1 stack2 stack3 extra fail result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 extra fail, - ( 1, - ([],) - . TLetD extra BX (TCon Ty.unitRef 0 []) - $ right extra - ) - ] - -outIoFailBool :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoFailBool stack1 stack2 stack3 extra fail result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 extra fail, - ( 1, - ([UN],) - . TAbs stack3 - . TLet (Indirect 1) extra BX (boolift stack3) - $ right extra - ) - ] - -outIoFailTup :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> v -> v -> ANormal v -outIoFailTup stack1 stack2 stack3 stack4 stack5 extra fail result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 extra fail, - ( 1, - ( [BX, BX], - TAbss [stack1, stack2] - . TLetD stack3 BX (TCon Ty.unitRef 0 []) - . TLetD stack4 BX (TCon Ty.pairRef 0 [stack2, stack3]) - . TLetD stack5 BX (TCon Ty.pairRef 0 [stack1, stack4]) - $ right stack5 - ) - ) - ] - -outIoFailG :: - (Var v) => - v -> - v -> - v -> - v -> - v -> - v -> - ((ANormal v -> ANormal v) -> ([Mem], ANormal v)) -> - ANormal v -outIoFailG stack1 stack2 stack3 fail result output k = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 output fail, - ( 1, - k $ \t -> - TLetD output BX t $ - right output - ) - ] - --- Input / Output glue --- --- These are pairings of input and output functions to handle a --- foreign call. The input function represents the numbers and types --- of the inputs to a forein call. The output function takes the --- result of the foreign call and turns it into a Unison type. --- - --- a -direct :: ForeignOp -direct instr = ([], TFOp instr []) - --- () -> a -unitDirect :: ForeignOp -unitDirect instr = ([BX],) . TAbs arg $ TFOp instr [] where arg = fresh1 - --- a -> b -boxDirect :: ForeignOp -boxDirect instr = - ([BX],) - . TAbs arg - $ TFOp instr [arg] - where - arg = fresh1 - --- () -> Either Failure Nat -unitToEFNat :: ForeignOp -unitToEFNat = - inUnit unit result $ - outIoFailNat stack1 stack2 stack3 fail nat result - where - (unit, stack1, stack2, stack3, fail, nat, result) = fresh - --- () -> Int -unitToInt :: ForeignOp -unitToInt = - inUnit unit result $ - TCon Ty.intRef 0 [result] - where - (unit, result) = fresh - --- () -> Either Failure a -unitToEFBox :: ForeignOp -unitToEFBox = - inUnit unit result $ - outIoFailBox stack1 stack2 stack3 any fail result - where - (unit, stack1, stack2, stack3, fail, any, result) = fresh - --- a -> Int -boxToInt :: ForeignOp -boxToInt = inBx arg result (TCon Ty.intRef 0 [result]) - where - (arg, result) = fresh - --- a -> Nat -boxToNat :: ForeignOp -boxToNat = inBx arg result (TCon Ty.natRef 0 [result]) - where - (arg, result) = fresh - -boxIomrToEFBox :: ForeignOp -boxIomrToEFBox = - inBxIomr arg1 arg2 enum result $ - outIoFailBox stack1 stack2 stack3 any fail result - where - (arg1, arg2, enum, stack1, stack2, stack3, any, fail, result) = fresh - --- a -> () -boxTo0 :: ForeignOp -boxTo0 = inBx arg result (TCon Ty.unitRef 0 []) - where - (arg, result) = fresh - --- a -> b ->{E} () -boxBoxTo0 :: ForeignOp -boxBoxTo0 instr = - ([BX, BX],) - . TAbss [arg1, arg2] - . TLets Direct [] [] (TFOp instr [arg1, arg2]) - $ TCon Ty.unitRef 0 [] - where - (arg1, arg2) = fresh - --- a -> b ->{E} Nat -boxBoxToNat :: ForeignOp -boxBoxToNat instr = - ([BX, BX],) - . TAbss [arg1, arg2] - . TLetD result UN (TFOp instr [arg1, arg2]) - $ TCon Ty.natRef 0 [result] - where - (arg1, arg2, result) = fresh - --- a -> b -> Option c - --- a -> Bool -boxToBool :: ForeignOp -boxToBool = - inBx arg result $ - boolift result - where - (arg, result) = fresh - --- a -> b -> Bool -boxBoxToBool :: ForeignOp -boxBoxToBool = - inBxBx arg1 arg2 result $ boolift result - where - (arg1, arg2, result) = fresh - --- a -> b -> c -> Bool -boxBoxBoxToBool :: ForeignOp -boxBoxBoxToBool = - inBxBxBx arg1 arg2 arg3 result $ boolift result - where - (arg1, arg2, arg3, result) = fresh - --- Nat -> c --- Works for an type that's packed into a word, just --- pass `wordDirect Ty.natRef`, `wordDirect Ty.floatRef` --- etc -wordDirect :: Reference -> ForeignOp -wordDirect wordType instr = - ([BX],) - . TAbss [b1] - . unbox b1 wordType ub1 - $ TFOp instr [ub1] - where - (b1, ub1) = fresh - --- Nat -> Bool -boxWordToBool :: Reference -> ForeignOp -boxWordToBool wordType instr = - ([BX, BX],) - . TAbss [b1, w1] - . unbox w1 wordType uw1 - $ TLetD result UN (TFOp instr [b1, uw1]) (boolift result) - where - (b1, w1, uw1, result) = fresh - --- Nat -> Nat -> c -wordWordDirect :: Reference -> Reference -> ForeignOp -wordWordDirect word1 word2 instr = - ([BX, BX],) - . TAbss [b1, b2] - . unbox b1 word1 ub1 - . unbox b2 word2 ub2 - $ TFOp instr [ub1, ub2] - where - (b1, b2, ub1, ub2) = fresh - --- Nat -> a -> c --- Works for an type that's packed into a word, just --- pass `wordBoxDirect Ty.natRef`, `wordBoxDirect Ty.floatRef` --- etc -wordBoxDirect :: Reference -> ForeignOp -wordBoxDirect wordType instr = - ([BX, BX],) - . TAbss [b1, b2] - . unbox b1 wordType ub1 - $ TFOp instr [ub1, b2] - where - (b1, b2, ub1) = fresh - --- a -> Nat -> c --- works for any second argument type that is packed into a word -boxWordDirect :: Reference -> ForeignOp -boxWordDirect wordType instr = - ([BX, BX],) - . TAbss [b1, b2] - . unbox b2 wordType ub2 - $ TFOp instr [b1, ub2] - where - (b1, b2, ub2) = fresh - --- a -> b -> c -boxBoxDirect :: ForeignOp -boxBoxDirect instr = - ([BX, BX],) - . TAbss [b1, b2] - $ TFOp instr [b1, b2] - where - (b1, b2) = fresh - --- a -> b -> c -> d -boxBoxBoxDirect :: ForeignOp -boxBoxBoxDirect instr = - ([BX, BX, BX],) - . TAbss [b1, b2, b3] - $ TFOp instr [b1, b2, b3] - where - (b1, b2, b3) = fresh - --- a -> Either Failure b -boxToEFBox :: ForeignOp -boxToEFBox = - inBx arg result $ - outIoFailBox stack1 stack2 stack3 any fail result - where - (arg, result, stack1, stack2, stack3, any, fail) = fresh - --- a -> Either Failure (b, c) -boxToEFTup :: ForeignOp -boxToEFTup = - inBx arg result $ - outIoFailTup stack1 stack2 stack3 stack4 stack5 extra fail result - where - (arg, result, stack1, stack2, stack3, stack4, stack5, extra, fail) = fresh - --- a -> Either Failure (Maybe b) -boxToEFMBox :: ForeignOp -boxToEFMBox = - inBx arg result - . outIoFailG stack1 stack2 stack3 fail result output - $ \k -> - ( [UN], - TAbs stack3 . TMatch stack3 . MatchSum $ - mapFromList - [ (0, ([], k $ none)), - (1, ([BX], TAbs stack4 . k $ some stack4)) - ] - ) - where - (arg, result, stack1, stack2, stack3, stack4, fail, output) = fresh - --- a -> Maybe b -boxToMaybeBox :: ForeignOp -boxToMaybeBox = - inBx arg result $ outMaybe maybe result - where - (arg, maybe, result) = fresh - --- a -> Maybe Nat -boxToMaybeNat :: ForeignOp -boxToMaybeNat = inBx arg tag $ outMaybeNat tag result n - where - (arg, tag, result, n) = fresh - --- a -> Maybe (Nat, b) -boxToMaybeNTup :: ForeignOp -boxToMaybeNTup = - inBx arg result $ outMaybeNTup a b c u bp p result - where - (arg, a, b, c, u, bp, p, result) = fresh - --- a -> b -> Maybe (c, d) -boxBoxToMaybeTup :: ForeignOp -boxBoxToMaybeTup = - inBxBx arg1 arg2 result $ outMaybeTup a b u bp ap result - where - (arg1, arg2, a, b, u, bp, ap, result) = fresh - --- a -> Either Failure Bool -boxToEFBool :: ForeignOp -boxToEFBool = - inBx arg result $ - outIoFailBool stack1 stack2 stack3 bool fail result - where - (arg, stack1, stack2, stack3, bool, fail, result) = fresh - --- a -> Either Failure Char -boxToEFChar :: ForeignOp -boxToEFChar = - inBx arg result $ - outIoFailChar stack1 stack2 stack3 bool fail result - where - (arg, stack1, stack2, stack3, bool, fail, result) = fresh - --- a -> b -> Either Failure Bool -boxBoxToEFBool :: ForeignOp -boxBoxToEFBool = - inBxBx arg1 arg2 result $ - outIoFailBool stack1 stack2 stack3 bool fail result - where - (arg1, arg2, stack1, stack2, stack3, bool, fail, result) = fresh - --- a -> b -> c -> Either Failure Bool -boxBoxBoxToEFBool :: ForeignOp -boxBoxBoxToEFBool = - inBxBxBx arg1 arg2 arg3 result $ - outIoFailBool stack1 stack2 stack3 bool fail result - where - (arg1, arg2, arg3, stack1, stack2, stack3, bool, fail, result) = fresh - --- a -> Either Failure () -boxToEF0 :: ForeignOp -boxToEF0 = - inBx arg result $ - outIoFailUnit stack1 stack2 stack3 unit fail result - where - (arg, result, stack1, stack2, stack3, unit, fail) = fresh - --- a -> b -> Either Failure () -boxBoxToEF0 :: ForeignOp -boxBoxToEF0 = - inBxBx arg1 arg2 result $ - outIoFailUnit stack1 stack2 stack3 fail unit result - where - (arg1, arg2, result, stack1, stack2, stack3, fail, unit) = fresh - --- a -> b -> c -> Either Failure () -boxBoxBoxToEF0 :: ForeignOp -boxBoxBoxToEF0 = - inBxBxBx arg1 arg2 arg3 result $ - outIoFailUnit stack1 stack2 stack3 fail unit result - where - (arg1, arg2, arg3, result, stack1, stack2, stack3, fail, unit) = fresh - --- a -> Either Failure Nat -boxToEFNat :: ForeignOp -boxToEFNat = - inBx arg result $ - outIoFailNat stack1 stack2 stack3 nat fail result - where - (arg, result, stack1, stack2, stack3, nat, fail) = fresh - --- Maybe a -> b -> Either Failure c -maybeBoxToEFBox :: ForeignOp -maybeBoxToEFBox = - inMaybeBx arg1 arg2 arg3 mb result $ - outIoFail stack1 stack2 stack3 any fail result - where - (arg1, arg2, arg3, mb, result, stack1, stack2, stack3, any, fail) = fresh - --- a -> b -> Either Failure c -boxBoxToEFBox :: ForeignOp -boxBoxToEFBox = - inBxBx arg1 arg2 result $ - outIoFail stack1 stack2 stack3 any fail result - where - (arg1, arg2, result, stack1, stack2, stack3, any, fail) = fresh - --- a -> b -> c -> Either Failure d -boxBoxBoxToEFBox :: ForeignOp -boxBoxBoxToEFBox = - inBxBxBx arg1 arg2 arg3 result $ - outIoFail stack1 stack2 stack3 any fail result - where - (arg1, arg2, arg3, result, stack1, stack2, stack3, any, fail) = fresh - --- Nat -> a --- Nat only -natToBox :: ForeignOp -natToBox = wordDirect Ty.natRef - --- Nat -> Nat -> a --- Nat only -natNatToBox :: ForeignOp -natNatToBox = wordWordDirect Ty.natRef Ty.natRef - --- Nat -> Nat -> a -> b -natNatBoxToBox :: ForeignOp -natNatBoxToBox instr = - ([BX, BX, BX],) - . TAbss [a1, a2, a3] - . unbox a1 Ty.natRef ua1 - . unbox a2 Ty.natRef ua2 - $ TFOp instr [ua1, ua2, a3] - where - (a1, a2, a3, ua1, ua2) = fresh - --- a -> Nat -> c --- Nat only -boxNatToBox :: ForeignOp -boxNatToBox = boxWordDirect Ty.natRef - --- a -> Nat -> Either Failure b -boxNatToEFBox :: ForeignOp -boxNatToEFBox = - inBxNat arg1 arg2 nat result $ - outIoFail stack1 stack2 stack3 any fail result - where - (arg1, arg2, nat, stack1, stack2, stack3, any, fail, result) = fresh - --- a -> Nat ->{Exception} b -boxNatToExnBox :: ForeignOp -boxNatToExnBox = - inBxNat arg1 arg2 nat result $ - outIoExnBox stack1 stack2 stack3 fail any result - where - (arg1, arg2, nat, stack1, stack2, stack3, any, fail, result) = fresh - --- a -> Nat -> b ->{Exception} () -boxNatBoxToExnUnit :: ForeignOp -boxNatBoxToExnUnit = - inBxNatBx arg1 arg2 arg3 nat result $ - outIoExnUnit stack1 stack2 stack3 any fail result - where - (arg1, arg2, arg3, nat, stack1, stack2, stack3, any, fail, result) = fresh - --- a -> Nat ->{Exception} Nat -boxNatToExnNat :: ForeignOp -boxNatToExnNat = - inBxNat arg1 arg2 nat result $ - outIoExnNat stack1 stack2 stack3 any fail result - where - (arg1, arg2, nat, stack1, stack2, stack3, any, fail, result) = fresh - --- a -> Nat -> Nat ->{Exception} () -boxNatNatToExnUnit :: ForeignOp -boxNatNatToExnUnit = - inBxNatNat arg1 arg2 arg3 nat1 nat2 result $ - outIoExnUnit stack1 stack2 stack3 any fail result - where - (arg1, arg2, arg3, nat1, nat2, result, stack1, stack2, stack3, any, fail) = fresh - --- a -> Nat -> Nat ->{Exception} b -boxNatNatToExnBox :: ForeignOp -boxNatNatToExnBox = - inBxNatNat arg1 arg2 arg3 nat1 nat2 result $ - outIoExnBox stack1 stack2 stack3 any fail result - where - (arg1, arg2, arg3, nat1, nat2, result, stack1, stack2, stack3, any, fail) = fresh - --- a -> Nat -> b -> Nat -> Nat ->{Exception} () -boxNatBoxNatNatToExnUnit :: ForeignOp -boxNatBoxNatNatToExnUnit instr = - ([BX, BX, BX, BX, BX],) - . TAbss [a0, a1, a2, a3, a4] - . unbox a1 Ty.natRef ua1 - . unbox a3 Ty.natRef ua3 - . unbox a4 Ty.natRef ua4 - . TLetD result UN (TFOp instr [a0, ua1, a2, ua3, ua4]) - $ outIoExnUnit stack1 stack2 stack3 any fail result - where - (a0, a1, a2, a3, a4, ua1, ua3, ua4, result, stack1, stack2, stack3, any, fail) = fresh - --- a ->{Exception} Either b c -boxToExnEBoxBox :: ForeignOp -boxToExnEBoxBox instr = - ([BX],) - . TAbs a - . TLetD t0 UN (TFOp instr [a]) - $ outIoExnEBoxBox stack1 stack2 stack3 any fail t0 t1 result - where - (a, stack1, stack2, stack3, any, fail, t0, t1, result) = fresh - --- Nat -> Either Failure b --- natToEFBox :: ForeignOp --- natToEFBox = inNat arg nat result $ outIoFail stack1 stack2 fail result --- where --- (arg, nat, stack1, stack2, fail, result) = fresh - --- Nat -> Either Failure () -natToEFUnit :: ForeignOp -natToEFUnit = - inNat arg nat result - . TMatch result - . MatchSum - $ mapFromList - [ failureCase stack1 stack2 stack3 unit fail, - ( 1, - ([],) - . TLetD unit BX (TCon Ty.unitRef 0 []) - $ right unit - ) - ] - where - (arg, nat, result, fail, stack1, stack2, stack3, unit) = fresh - --- a -> Either b c -boxToEBoxBox :: ForeignOp -boxToEBoxBox instr = - ([BX],) - . TAbss [b] - . TLetD e UN (TFOp instr [b]) - . TMatch e - . MatchSum - $ mapFromList - [ (0, ([BX], TAbs ev $ left ev)), - (1, ([BX], TAbs ev $ right ev)) - ] - where - (e, b, ev) = fresh - -builtinLookup :: Map.Map Reference (Sandbox, SuperNormal Symbol) -builtinLookup = - Map.fromList - . map (\(t, f) -> (Builtin t, f)) - $ [ ("Int.+", (Untracked, addi)), - ("Int.-", (Untracked, subi)), - ("Int.*", (Untracked, muli)), - ("Int./", (Untracked, divi)), - ("Int.mod", (Untracked, modi)), - ("Int.==", (Untracked, eqi)), - ("Int.<", (Untracked, lti)), - ("Int.<=", (Untracked, lei)), - ("Int.>", (Untracked, gti)), - ("Int.>=", (Untracked, gei)), - ("Int.fromRepresentation", (Untracked, coerceType Ty.natRef Ty.intRef)), - ("Int.toRepresentation", (Untracked, coerceType Ty.intRef Ty.natRef)), - ("Int.increment", (Untracked, inci)), - ("Int.signum", (Untracked, sgni)), - ("Int.negate", (Untracked, negi)), - ("Int.truncate0", (Untracked, trni)), - ("Int.isEven", (Untracked, evni)), - ("Int.isOdd", (Untracked, oddi)), - ("Int.shiftLeft", (Untracked, shli)), - ("Int.shiftRight", (Untracked, shri)), - ("Int.trailingZeros", (Untracked, tzeroi)), - ("Int.leadingZeros", (Untracked, lzeroi)), - ("Int.and", (Untracked, andi)), - ("Int.or", (Untracked, ori)), - ("Int.xor", (Untracked, xori)), - ("Int.complement", (Untracked, compli)), - ("Int.pow", (Untracked, powi)), - ("Int.toText", (Untracked, i2t)), - ("Int.fromText", (Untracked, t2i)), - ("Int.toFloat", (Untracked, i2f)), - ("Int.popCount", (Untracked, popi)), - ("Nat.+", (Untracked, addn)), - ("Nat.-", (Untracked, subn)), - ("Nat.sub", (Untracked, subn)), - ("Nat.*", (Untracked, muln)), - ("Nat./", (Untracked, divn)), - ("Nat.mod", (Untracked, modn)), - ("Nat.==", (Untracked, eqn)), - ("Nat.<", (Untracked, ltn)), - ("Nat.<=", (Untracked, len)), - ("Nat.>", (Untracked, gtn)), - ("Nat.>=", (Untracked, gen)), - ("Nat.increment", (Untracked, incn)), - ("Nat.isEven", (Untracked, evnn)), - ("Nat.isOdd", (Untracked, oddn)), - ("Nat.shiftLeft", (Untracked, shln)), - ("Nat.shiftRight", (Untracked, shrn)), - ("Nat.trailingZeros", (Untracked, tzeron)), - ("Nat.leadingZeros", (Untracked, lzeron)), - ("Nat.and", (Untracked, andn)), - ("Nat.or", (Untracked, orn)), - ("Nat.xor", (Untracked, xorn)), - ("Nat.complement", (Untracked, compln)), - ("Nat.pow", (Untracked, pown)), - ("Nat.drop", (Untracked, dropn)), - ("Nat.toInt", (Untracked, cast Ty.natRef Ty.intRef)), - ("Nat.toFloat", (Untracked, n2f)), - ("Nat.toText", (Untracked, n2t)), - ("Nat.fromText", (Untracked, t2n)), - ("Nat.popCount", (Untracked, popn)), - ("Float.+", (Untracked, addf)), - ("Float.-", (Untracked, subf)), - ("Float.*", (Untracked, mulf)), - ("Float./", (Untracked, divf)), - ("Float.pow", (Untracked, powf)), - ("Float.log", (Untracked, logf)), - ("Float.logBase", (Untracked, logbf)), - ("Float.sqrt", (Untracked, sqrtf)), - ("Float.fromRepresentation", (Untracked, coerceType Ty.natRef Ty.floatRef)), - ("Float.toRepresentation", (Untracked, coerceType Ty.floatRef Ty.natRef)), - ("Float.min", (Untracked, minf)), - ("Float.max", (Untracked, maxf)), - ("Float.<", (Untracked, ltf)), - ("Float.>", (Untracked, gtf)), - ("Float.<=", (Untracked, lef)), - ("Float.>=", (Untracked, gef)), - ("Float.==", (Untracked, eqf)), - ("Float.!=", (Untracked, neqf)), - ("Float.acos", (Untracked, acosf)), - ("Float.asin", (Untracked, asinf)), - ("Float.atan", (Untracked, atanf)), - ("Float.cos", (Untracked, cosf)), - ("Float.sin", (Untracked, sinf)), - ("Float.tan", (Untracked, tanf)), - ("Float.acosh", (Untracked, acoshf)), - ("Float.asinh", (Untracked, asinhf)), - ("Float.atanh", (Untracked, atanhf)), - ("Float.cosh", (Untracked, coshf)), - ("Float.sinh", (Untracked, sinhf)), - ("Float.tanh", (Untracked, tanhf)), - ("Float.exp", (Untracked, expf)), - ("Float.abs", (Untracked, absf)), - ("Float.ceiling", (Untracked, ceilf)), - ("Float.floor", (Untracked, floorf)), - ("Float.round", (Untracked, roundf)), - ("Float.truncate", (Untracked, truncf)), - ("Float.atan2", (Untracked, atan2f)), - ("Float.toText", (Untracked, f2t)), - ("Float.fromText", (Untracked, t2f)), - -- text - ("Text.empty", (Untracked, Lambda [] $ TLit (T ""))), - ("Text.++", (Untracked, appendt)), - ("Text.take", (Untracked, taket)), - ("Text.drop", (Untracked, dropt)), - ("Text.indexOf", (Untracked, indext)), - ("Text.size", (Untracked, sizet)), - ("Text.==", (Untracked, eqt)), - ("Text.!=", (Untracked, neqt)), - ("Text.<=", (Untracked, leqt)), - ("Text.>=", (Untracked, geqt)), - ("Text.<", (Untracked, lesst)), - ("Text.>", (Untracked, great)), - ("Text.uncons", (Untracked, unconst)), - ("Text.unsnoc", (Untracked, unsnoct)), - ("Text.toCharList", (Untracked, unpackt)), - ("Text.fromCharList", (Untracked, packt)), - ("Boolean.not", (Untracked, notb)), - ("Boolean.or", (Untracked, orb)), - ("Boolean.and", (Untracked, andb)), - ("bug", (Untracked, bug "builtin.bug")), - ("todo", (Untracked, bug "builtin.todo")), - ("Debug.watch", (Tracked, watch)), - ("Debug.trace", (Tracked, gen'trace)), - ("Debug.toText", (Tracked, debug'text)), - ("unsafe.coerceAbilities", (Untracked, poly'coerce)), - ("Char.toNat", (Untracked, cast Ty.charRef Ty.natRef)), - ("Char.fromNat", (Untracked, cast Ty.natRef Ty.charRef)), - ("Bytes.empty", (Untracked, emptyb)), - ("Bytes.fromList", (Untracked, packb)), - ("Bytes.toList", (Untracked, unpackb)), - ("Bytes.++", (Untracked, appendb)), - ("Bytes.take", (Untracked, takeb)), - ("Bytes.drop", (Untracked, dropb)), - ("Bytes.at", (Untracked, atb)), - ("Bytes.indexOf", (Untracked, indexb)), - ("Bytes.size", (Untracked, sizeb)), - ("Bytes.flatten", (Untracked, flattenb)), - ("List.take", (Untracked, takes)), - ("List.drop", (Untracked, drops)), - ("List.size", (Untracked, sizes)), - ("List.++", (Untracked, appends)), - ("List.at", (Untracked, ats)), - ("List.cons", (Untracked, conss)), - ("List.snoc", (Untracked, snocs)), - ("List.empty", (Untracked, emptys)), - ("List.viewl", (Untracked, viewls)), - ("List.viewr", (Untracked, viewrs)), - ("List.splitLeft", (Untracked, splitls)), - ("List.splitRight", (Untracked, splitrs)), - -- - -- , B "Debug.watch" $ forall1 "a" (\a -> text --> a --> a) - ("Universal.==", (Untracked, equ)), - ("Universal.compare", (Untracked, cmpu)), - ("Universal.>", (Untracked, gtu)), - ("Universal.<", (Untracked, ltu)), - ("Universal.>=", (Untracked, geu)), - ("Universal.<=", (Untracked, leu)), - -- internal stuff - ("jumpCont", (Untracked, jumpk)), - ("raise", (Untracked, raise)), - ("IO.forkComp.v2", (Tracked, fork'comp)), - ("Scope.run", (Untracked, scope'run)), - ("Code.isMissing", (Tracked, code'missing)), - ("Code.cache_", (Tracked, code'cache)), - ("Code.lookup", (Tracked, code'lookup)), - ("Code.validate", (Tracked, code'validate)), - ("Value.load", (Tracked, value'load)), - ("Value.value", (Tracked, value'create)), - ("Any.Any", (Untracked, any'construct)), - ("Any.unsafeExtract", (Untracked, any'extract)), - ("Link.Term.toText", (Untracked, term'link'to'text)), - ("STM.atomically", (Tracked, stm'atomic)), - ("validateSandboxed", (Untracked, check'sandbox)), - ("Value.validateSandboxed", (Tracked, value'sandbox)), - ("sandboxLinks", (Tracked, sandbox'links)), - ("IO.tryEval", (Tracked, try'eval)) - ] - ++ foreignWrappers - -type FDecl v = - ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc))) - --- Data type to determine whether a builtin should be tracked for --- sandboxing. Untracked means that it can be freely used, and Tracked --- means that the sandboxing check will by default consider them --- disallowed. -data Sandbox = Tracked | Untracked - deriving (Eq, Ord, Show, Read, Enum, Bounded) - -bomb :: Data.Text.Text -> a -> IO r -bomb name _ = die $ "attempted to use sandboxed operation: " ++ Data.Text.unpack name - -declareForeign :: - Sandbox -> - Data.Text.Text -> - ForeignOp -> - ForeignFunc -> - FDecl Symbol () -declareForeign sand name op func0 = do - sanitize <- ask - modify $ \(w, codes, funcs) -> - let func - | sanitize, - Tracked <- sand, - FF r w _ <- func0 = - FF r w (bomb name) - | otherwise = func0 - code = (name, (sand, uncurry Lambda (op w))) - in (w + 1, code : codes, mapInsert w (name, func) funcs) - -mkForeignIOF :: - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) - where - tryIOE :: IO a -> IO (Either Failure a) - tryIOE = fmap handleIOE . try - handleIOE :: Either IOException a -> Either Failure a - handleIOE (Left e) = Left $ Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue - handleIOE (Right a) = Right a - -unitValue :: Closure -unitValue = Closure.Enum Ty.unitRef 0 - -natValue :: Word64 -> Closure -natValue w = Closure.DataU1 Ty.natRef 0 (fromIntegral w) - -mkForeignTls :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) - where - tryIO1 :: IO r -> IO (Either TLS.TLSException r) - tryIO1 = try - tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r)) - tryIO2 = try - flatten :: Either IOException (Either TLS.TLSException r) -> Either (Failure) r - flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Right a)) = Right a - -mkForeignTlsE :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO (Either Failure r)) -> - ForeignFunc -mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) - where - tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r)) - tryIO1 = try - tryIO2 :: IO (Either TLS.TLSException (Either Failure r)) -> IO (Either IOException (Either TLS.TLSException (Either Failure r))) - tryIO2 = try - flatten :: Either IOException (Either TLS.TLSException (Either Failure r)) -> Either Failure r - flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Right (Left e))) = Left e - flatten (Right (Right (Right a))) = Right a - -declareUdpForeigns :: FDecl Symbol () -declareUdpForeigns = do - declareForeign Tracked "IO.UDP.clientSocket.impl.v1" boxBoxToEFBox - . mkForeignIOF - $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> - let hostStr = Util.Text.toString host - portStr = Util.Text.toString port - in UDP.clientSocket hostStr portStr True - - declareForeign Tracked "IO.UDP.UDPSocket.recv.impl.v1" boxToEFBox - . mkForeignIOF - $ \(sock :: UDPSocket) -> Bytes.fromArray <$> UDP.recv sock - - declareForeign Tracked "IO.UDP.UDPSocket.send.impl.v1" boxBoxToEF0 - . mkForeignIOF - $ \(sock :: UDPSocket, bytes :: Bytes.Bytes) -> - UDP.send sock (Bytes.toArray bytes) - - declareForeign Tracked "IO.UDP.UDPSocket.close.impl.v1" boxToEF0 - . mkForeignIOF - $ \(sock :: UDPSocket) -> UDP.close sock - - declareForeign Tracked "IO.UDP.ListenSocket.close.impl.v1" boxToEF0 - . mkForeignIOF - $ \(sock :: ListenSocket) -> UDP.stop sock - - declareForeign Tracked "IO.UDP.UDPSocket.toText.impl.v1" boxDirect - . mkForeign - $ \(sock :: UDPSocket) -> pure $ show sock - - declareForeign Tracked "IO.UDP.serverSocket.impl.v1" boxBoxToEFBox - . mkForeignIOF - $ \(ip :: Util.Text.Text, port :: Util.Text.Text) -> - let maybeIp = readMaybe $ Util.Text.toString ip :: Maybe IP - maybePort = readMaybe $ Util.Text.toString port :: Maybe PortNumber - in case (maybeIp, maybePort) of - (Nothing, _) -> fail "Invalid IP Address" - (_, Nothing) -> fail "Invalid Port Number" - (Just ip, Just pt) -> UDP.serverSocket (ip, pt) - - declareForeign Tracked "IO.UDP.ListenSocket.toText.impl.v1" boxDirect - . mkForeign - $ \(sock :: ListenSocket) -> pure $ show sock - - declareForeign Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" boxToEFTup - . mkForeignIOF - $ fmap (first Bytes.fromArray) <$> UDP.recvFrom - - declareForeign Tracked "IO.UDP.ClientSockAddr.toText.v1" boxDirect - . mkForeign - $ \(sock :: ClientSockAddr) -> pure $ show sock - - declareForeign Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" boxBoxBoxToEF0 - . mkForeignIOF - $ \(socket :: ListenSocket, bytes :: Bytes.Bytes, addr :: ClientSockAddr) -> - UDP.sendTo socket (Bytes.toArray bytes) addr - -declareForeigns :: FDecl Symbol () -declareForeigns = do - declareUdpForeigns - declareForeign Tracked "IO.openFile.impl.v3" boxIomrToEFBox $ - mkForeignIOF $ \(fnameText :: Util.Text.Text, n :: Int) -> - let fname = Util.Text.toString fnameText - mode = case n of - 0 -> ReadMode - 1 -> WriteMode - 2 -> AppendMode - _ -> ReadWriteMode - in openFile fname mode - - declareForeign Tracked "IO.closeFile.impl.v3" boxToEF0 $ mkForeignIOF hClose - declareForeign Tracked "IO.isFileEOF.impl.v3" boxToEFBool $ mkForeignIOF hIsEOF - declareForeign Tracked "IO.isFileOpen.impl.v3" boxToEFBool $ mkForeignIOF hIsOpen - declareForeign Tracked "IO.getEcho.impl.v1" boxToEFBool $ mkForeignIOF hGetEcho - declareForeign Tracked "IO.ready.impl.v1" boxToEFBool $ mkForeignIOF hReady - declareForeign Tracked "IO.getChar.impl.v1" boxToEFChar $ mkForeignIOF hGetChar - declareForeign Tracked "IO.isSeekable.impl.v3" boxToEFBool $ mkForeignIOF hIsSeekable - - declareForeign Tracked "IO.seekHandle.impl.v3" seek'handle - . mkForeignIOF - $ \(h, sm, n) -> hSeek h sm (fromIntegral (n :: Int)) - - declareForeign Tracked "IO.handlePosition.impl.v3" boxToEFNat - -- TODO: truncating integer - . mkForeignIOF - $ \h -> fromInteger @Word64 <$> hTell h - - declareForeign Tracked "IO.getBuffering.impl.v3" get'buffering $ - mkForeignIOF hGetBuffering - - declareForeign Tracked "IO.setBuffering.impl.v3" set'buffering - . mkForeignIOF - $ uncurry hSetBuffering - - declareForeign Tracked "IO.setEcho.impl.v1" set'echo . mkForeignIOF $ uncurry hSetEcho - - declareForeign Tracked "IO.getLine.impl.v1" boxToEFBox $ - mkForeignIOF $ - fmap Util.Text.fromText . Text.IO.hGetLine - - declareForeign Tracked "IO.getBytes.impl.v3" boxNatToEFBox . mkForeignIOF $ - \(h, n) -> Bytes.fromArray <$> hGet h n - - declareForeign Tracked "IO.getSomeBytes.impl.v1" boxNatToEFBox . mkForeignIOF $ - \(h, n) -> Bytes.fromArray <$> hGetSome h n - - declareForeign Tracked "IO.putBytes.impl.v3" boxBoxToEF0 . mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) - - declareForeign Tracked "IO.systemTime.impl.v3" unitToEFNat $ - mkForeignIOF $ - \() -> getPOSIXTime - - declareForeign Tracked "IO.systemTimeMicroseconds.v1" unitToInt $ - mkForeign $ - \() -> fmap (1e6 *) getPOSIXTime - - declareForeign Tracked "Clock.internals.monotonic.v1" unitToEFBox $ - mkForeignIOF $ - \() -> getTime Monotonic - - declareForeign Tracked "Clock.internals.realtime.v1" unitToEFBox $ - mkForeignIOF $ - \() -> getTime Realtime - - declareForeign Tracked "Clock.internals.processCPUTime.v1" unitToEFBox $ - mkForeignIOF $ - \() -> getTime ProcessCPUTime - - declareForeign Tracked "Clock.internals.threadCPUTime.v1" unitToEFBox $ - mkForeignIOF $ - \() -> getTime ThreadCPUTime - - declareForeign Tracked "Clock.internals.sec.v1" boxToInt $ - mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) - - -- A TimeSpec that comes from getTime never has negative nanos, - -- so we can safely cast to Nat - declareForeign Tracked "Clock.internals.nsec.v1" boxToNat $ - mkForeign (\n -> pure (fromIntegral $ nsec n :: Word64)) - - declareForeign Tracked "Clock.internals.systemTimeZone.v1" time'zone $ - mkForeign - ( \secs -> do - TimeZone offset summer name <- getTimeZone (posixSecondsToUTCTime (fromIntegral (secs :: Int))) - pure (offset :: Int, summer, name) - ) - - let chop = reverse . dropWhile isPathSeparator . reverse - - declareForeign Tracked "IO.getTempDirectory.impl.v3" unitToEFBox $ - mkForeignIOF $ - \() -> chop <$> getTemporaryDirectory - - declareForeign Tracked "IO.createTempDirectory.impl.v3" boxToEFBox $ - mkForeignIOF $ \prefix -> do - temp <- getTemporaryDirectory - chop <$> createTempDirectory temp prefix - - declareForeign Tracked "IO.getCurrentDirectory.impl.v3" unitToEFBox - . mkForeignIOF - $ \() -> getCurrentDirectory - - declareForeign Tracked "IO.setCurrentDirectory.impl.v3" boxToEF0 $ - mkForeignIOF setCurrentDirectory - - declareForeign Tracked "IO.fileExists.impl.v3" boxToEFBool $ - mkForeignIOF doesPathExist - - declareForeign Tracked "IO.getEnv.impl.v1" boxToEFBox $ - mkForeignIOF getEnv - - declareForeign Tracked "IO.getArgs.impl.v1" unitToEFBox $ - mkForeignIOF $ - \() -> fmap Util.Text.pack <$> SYS.getArgs - - declareForeign Tracked "IO.isDirectory.impl.v3" boxToEFBool $ - mkForeignIOF doesDirectoryExist - - declareForeign Tracked "IO.createDirectory.impl.v3" boxToEF0 $ - mkForeignIOF $ - createDirectoryIfMissing True - - declareForeign Tracked "IO.removeDirectory.impl.v3" boxToEF0 $ - mkForeignIOF removeDirectoryRecursive - - declareForeign Tracked "IO.renameDirectory.impl.v3" boxBoxToEF0 $ - mkForeignIOF $ - uncurry renameDirectory - - declareForeign Tracked "IO.directoryContents.impl.v3" boxToEFBox $ - mkForeignIOF $ - (fmap Util.Text.pack <$>) . getDirectoryContents - - declareForeign Tracked "IO.removeFile.impl.v3" boxToEF0 $ - mkForeignIOF removeFile - - declareForeign Tracked "IO.renameFile.impl.v3" boxBoxToEF0 $ - mkForeignIOF $ - uncurry renameFile - - declareForeign Tracked "IO.getFileTimestamp.impl.v3" boxToEFNat - . mkForeignIOF - $ fmap utcTimeToPOSIXSeconds . getModificationTime - - declareForeign Tracked "IO.getFileSize.impl.v3" boxToEFNat - -- TODO: truncating integer - . mkForeignIOF - $ \fp -> fromInteger @Word64 <$> getFileSize fp - - declareForeign Tracked "IO.serverSocket.impl.v3" maybeBoxToEFBox - . mkForeignIOF - $ \( mhst :: Maybe Util.Text.Text, - port - ) -> - fst <$> SYS.bindSock (hostPreference mhst) port - - declareForeign Tracked "Socket.toText" boxDirect - . mkForeign - $ \(sock :: Socket) -> pure $ show sock - - declareForeign Tracked "Handle.toText" boxDirect - . mkForeign - $ \(hand :: Handle) -> pure $ show hand - - declareForeign Tracked "ThreadId.toText" boxDirect - . mkForeign - $ \(threadId :: ThreadId) -> pure $ show threadId - - declareForeign Tracked "IO.socketPort.impl.v3" boxToEFNat - . mkForeignIOF - $ \(handle :: Socket) -> do - n <- SYS.socketPort handle - return (fromIntegral n :: Word64) - - declareForeign Tracked "IO.listen.impl.v3" boxToEF0 - . mkForeignIOF - $ \sk -> SYS.listenSock sk 2048 - - declareForeign Tracked "IO.clientSocket.impl.v3" boxBoxToEFBox - . mkForeignIOF - $ fmap fst . uncurry SYS.connectSock - - declareForeign Tracked "IO.closeSocket.impl.v3" boxToEF0 $ - mkForeignIOF SYS.closeSock - - declareForeign Tracked "IO.socketAccept.impl.v3" boxToEFBox - . mkForeignIOF - $ fmap fst . SYS.accept - - declareForeign Tracked "IO.socketSend.impl.v3" boxBoxToEF0 - . mkForeignIOF - $ \(sk, bs) -> SYS.send sk (Bytes.toArray bs) - - declareForeign Tracked "IO.socketReceive.impl.v3" boxNatToEFBox - . mkForeignIOF - $ \(hs, n) -> - maybe mempty Bytes.fromArray <$> SYS.recv hs n - - declareForeign Tracked "IO.kill.impl.v3" boxToEF0 $ mkForeignIOF killThread - - declareForeign Tracked "IO.delay.impl.v3" natToEFUnit $ - mkForeignIOF threadDelay - - declareForeign Tracked "IO.stdHandle" standard'handle - . mkForeign - $ \(n :: Int) -> case n of - 0 -> pure SYS.stdin - 1 -> pure SYS.stdout - 2 -> pure SYS.stderr - _ -> die "IO.stdHandle: invalid input." - - let exitDecode ExitSuccess = 0 - exitDecode (ExitFailure n) = n - - declareForeign Tracked "IO.process.call" boxBoxToNat . mkForeign $ - \(exe, map Util.Text.unpack -> args) -> - withCreateProcess (proc exe args) $ \_ _ _ p -> - exitDecode <$> waitForProcess p - - declareForeign Tracked "IO.process.start" start'process . mkForeign $ - \(exe, map Util.Text.unpack -> args) -> - runInteractiveProcess exe args Nothing Nothing - - declareForeign Tracked "IO.process.kill" boxTo0 . mkForeign $ - terminateProcess - - declareForeign Tracked "IO.process.wait" boxToNat . mkForeign $ - \ph -> exitDecode <$> waitForProcess ph - - declareForeign Tracked "IO.process.exitCode" boxToMaybeNat . mkForeign $ - fmap (fmap exitDecode) . getProcessExitCode - - declareForeign Tracked "MVar.new" boxDirect - . mkForeign - $ \(c :: Closure) -> newMVar c - - declareForeign Tracked "MVar.newEmpty.v2" unitDirect - . mkForeign - $ \() -> newEmptyMVar @Closure - - declareForeign Tracked "MVar.take.impl.v3" boxToEFBox - . mkForeignIOF - $ \(mv :: MVar Closure) -> takeMVar mv - - declareForeign Tracked "MVar.tryTake" boxToMaybeBox - . mkForeign - $ \(mv :: MVar Closure) -> tryTakeMVar mv - - declareForeign Tracked "MVar.put.impl.v3" boxBoxToEF0 - . mkForeignIOF - $ \(mv :: MVar Closure, x) -> putMVar mv x - - declareForeign Tracked "MVar.tryPut.impl.v3" boxBoxToEFBool - . mkForeignIOF - $ \(mv :: MVar Closure, x) -> tryPutMVar mv x - - declareForeign Tracked "MVar.swap.impl.v3" boxBoxToEFBox - . mkForeignIOF - $ \(mv :: MVar Closure, x) -> swapMVar mv x - - declareForeign Tracked "MVar.isEmpty" boxToBool - . mkForeign - $ \(mv :: MVar Closure) -> isEmptyMVar mv - - declareForeign Tracked "MVar.read.impl.v3" boxToEFBox - . mkForeignIOF - $ \(mv :: MVar Closure) -> readMVar mv - - declareForeign Tracked "MVar.tryRead.impl.v3" boxToEFMBox - . mkForeignIOF - $ \(mv :: MVar Closure) -> tryReadMVar mv - - declareForeign Untracked "Char.toText" (wordDirect Ty.charRef) . mkForeign $ - \(ch :: Char) -> pure (Util.Text.singleton ch) - - declareForeign Untracked "Text.repeat" (wordBoxDirect Ty.natRef) . mkForeign $ - \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) - - declareForeign Untracked "Text.reverse" boxDirect . mkForeign $ - pure . Util.Text.reverse - - declareForeign Untracked "Text.toUppercase" boxDirect . mkForeign $ - pure . Util.Text.toUppercase - - declareForeign Untracked "Text.toLowercase" boxDirect . mkForeign $ - pure . Util.Text.toLowercase - - declareForeign Untracked "Text.toUtf8" boxDirect . mkForeign $ - pure . Util.Text.toUtf8 - - declareForeign Untracked "Text.fromUtf8.impl.v3" boxToEFBox . mkForeign $ - pure . mapLeft (\t -> Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 - - declareForeign Tracked "Tls.ClientConfig.default" boxBoxDirect . mkForeign $ - \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> - fmap - ( \store -> - (defaultParamsClient (Util.Text.unpack hostName) (Bytes.toArray serverId)) - { TLS.clientSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, - TLS.clientShared = def {TLS.sharedCAStore = store} - } - ) - X.getSystemCertificateStore - - declareForeign Tracked "Tls.ServerConfig.default" boxBoxDirect $ - mkForeign $ - \(certs :: [X.SignedCertificate], key :: X.PrivKey) -> - pure $ - (def :: TLS.ServerParams) - { TLS.serverSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, - TLS.serverShared = def {TLS.sharedCredentials = Credentials [(X.CertificateChain certs, key)]} - } - - let updateClient :: X.CertificateStore -> TLS.ClientParams -> TLS.ClientParams - updateClient certs client = client {TLS.clientShared = ((clientShared client) {TLS.sharedCAStore = certs})} - in declareForeign Tracked "Tls.ClientConfig.certificates.set" boxBoxDirect . mkForeign $ - \(certs :: [X.SignedCertificate], params :: ClientParams) -> pure $ updateClient (X.makeCertificateStore certs) params - - let updateServer :: X.CertificateStore -> TLS.ServerParams -> TLS.ServerParams - updateServer certs client = client {TLS.serverShared = ((serverShared client) {TLS.sharedCAStore = certs})} - in declareForeign Tracked "Tls.ServerConfig.certificates.set" boxBoxDirect . mkForeign $ - \(certs :: [X.SignedCertificate], params :: ServerParams) -> pure $ updateServer (X.makeCertificateStore certs) params - - declareForeign Tracked "TVar.new" boxDirect . mkForeign $ - \(c :: Closure) -> unsafeSTMToIO $ STM.newTVar c - - declareForeign Tracked "TVar.read" boxDirect . mkForeign $ - \(v :: STM.TVar Closure) -> unsafeSTMToIO $ STM.readTVar v - - declareForeign Tracked "TVar.write" boxBoxTo0 . mkForeign $ - \(v :: STM.TVar Closure, c :: Closure) -> - unsafeSTMToIO $ STM.writeTVar v c - - declareForeign Tracked "TVar.newIO" boxDirect . mkForeign $ - \(c :: Closure) -> STM.newTVarIO c - - declareForeign Tracked "TVar.readIO" boxDirect . mkForeign $ - \(v :: STM.TVar Closure) -> STM.readTVarIO v - - declareForeign Tracked "TVar.swap" boxBoxDirect . mkForeign $ - \(v, c :: Closure) -> unsafeSTMToIO $ STM.swapTVar v c - - declareForeign Tracked "STM.retry" unitDirect . mkForeign $ - \() -> unsafeSTMToIO STM.retry :: IO Closure - - -- Scope and Ref stuff - declareForeign Untracked "Scope.ref" boxDirect - . mkForeign - $ \(c :: Closure) -> newIORef c - - declareForeign Tracked "IO.ref" boxDirect - . mkForeign - $ \(c :: Closure) -> evaluate c >>= newIORef - - -- The docs for IORef state that IORef operations can be observed - -- out of order ([1]) but actually GHC does emit the appropriate - -- load and store barriers nowadays ([2], [3]). - -- - -- [1] https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-IORef.html#g:2 - -- [2] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L286 - -- [3] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L298 - declareForeign Untracked "Ref.read" boxDirect . mkForeign $ - \(r :: IORef Closure) -> readIORef r - - declareForeign Untracked "Ref.write" boxBoxTo0 . mkForeign $ - \(r :: IORef Closure, c :: Closure) -> evaluate c >>= writeIORef r - - declareForeign Tracked "Ref.readForCas" boxDirect . mkForeign $ - \(r :: IORef Closure) -> readForCAS r - - declareForeign Tracked "Ref.Ticket.read" boxDirect . mkForeign $ - \(t :: Ticket Closure) -> pure $ peekTicket t - - -- In GHC, CAS returns both a Boolean and the current value of the - -- IORef, which can be used to retry a failed CAS. - -- This strategy is more efficient than returning a Boolean only - -- because it uses a single call to cmpxchg in assembly (see [1]) to - -- avoid an extra read per CAS iteration, however it's not supported - -- in Scheme. - -- Therefore, we adopt the more common signature that only returns a - -- Boolean, which doesn't even suffer from spurious failures because - -- GHC issues loads of mutable variables with memory_order_acquire - -- (see [2]) - -- - -- [1]: https://github.com/ghc/ghc/blob/master/rts/PrimOps.cmm#L697 - -- [2]: https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L285 - declareForeign Tracked "Ref.cas" boxBoxBoxToBool . mkForeign $ - \(r :: IORef Closure, t :: Ticket Closure, v :: Closure) -> fmap fst $ - do - t <- evaluate t - casIORef r t v - - declareForeign Tracked "Promise.new" unitDirect . mkForeign $ - \() -> newPromise @Closure - - -- the only exceptions from Promise.read are async and shouldn't be caught - declareForeign Tracked "Promise.read" boxDirect . mkForeign $ - \(p :: Promise Closure) -> readPromise p - - declareForeign Tracked "Promise.tryRead" boxToMaybeBox . mkForeign $ - \(p :: Promise Closure) -> tryReadPromise p - - declareForeign Tracked "Promise.write" boxBoxToBool . mkForeign $ - \(p :: Promise Closure, a :: Closure) -> writePromise p a - - declareForeign Tracked "Tls.newClient.impl.v3" boxBoxToEFBox . mkForeignTls $ - \( config :: TLS.ClientParams, - socket :: SYS.Socket - ) -> TLS.contextNew socket config - - declareForeign Tracked "Tls.newServer.impl.v3" boxBoxToEFBox . mkForeignTls $ - \( config :: TLS.ServerParams, - socket :: SYS.Socket - ) -> TLS.contextNew socket config - - declareForeign Tracked "Tls.handshake.impl.v3" boxToEF0 . mkForeignTls $ - \(tls :: TLS.Context) -> TLS.handshake tls - - declareForeign Tracked "Tls.send.impl.v3" boxBoxToEF0 . mkForeignTls $ - \( tls :: TLS.Context, - bytes :: Bytes.Bytes - ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) - - let wrapFailure t = Failure Ty.tlsFailureRef (Util.Text.pack t) unitValue - decoded :: Bytes.Bytes -> Either String PEM - decoded bytes = case pemParseLBS $ Bytes.toLazyByteString bytes of - Right (pem : _) -> Right pem - Right [] -> Left "no PEM found" - Left l -> Left l - asCert :: PEM -> Either String X.SignedCertificate - asCert pem = X.decodeSignedCertificate $ pemContent pem - in declareForeign Tracked "Tls.decodeCert.impl.v3" boxToEFBox . mkForeignTlsE $ - \(bytes :: Bytes.Bytes) -> pure $ mapLeft wrapFailure $ (decoded >=> asCert) bytes - - declareForeign Tracked "Tls.encodeCert" boxDirect . mkForeign $ - \(cert :: X.SignedCertificate) -> pure $ Bytes.fromArray $ X.encodeSignedObject cert - - declareForeign Tracked "Tls.decodePrivateKey" boxDirect . mkForeign $ - \(bytes :: Bytes.Bytes) -> pure $ X.readKeyFileFromMemory $ L.toStrict $ Bytes.toLazyByteString bytes - - declareForeign Tracked "Tls.encodePrivateKey" boxDirect . mkForeign $ - \(privateKey :: X.PrivKey) -> pure $ Util.Text.toUtf8 $ Util.Text.pack $ show privateKey - - declareForeign Tracked "Tls.receive.impl.v3" boxToEFBox . mkForeignTls $ - \(tls :: TLS.Context) -> do - bs <- TLS.recvData tls - pure $ Bytes.fromArray bs - - declareForeign Tracked "Tls.terminate.impl.v3" boxToEF0 . mkForeignTls $ - \(tls :: TLS.Context) -> TLS.bye tls - - declareForeign Untracked "Code.validateLinks" boxToExnEBoxBox - . mkForeign - $ \(lsgs0 :: [(Referent, SuperGroup Symbol)]) -> do - let f (msg, rs) = - Failure Ty.miscFailureRef (Util.Text.fromText msg) rs - pure . first f $ checkGroupHashes lsgs0 - declareForeign Untracked "Code.dependencies" boxDirect - . mkForeign - $ \(sg :: SuperGroup Symbol) -> - pure $ Wrap Ty.termLinkRef . Ref <$> groupTermLinks sg - declareForeign Untracked "Code.serialize" boxDirect - . mkForeign - $ \(sg :: SuperGroup Symbol) -> - pure . Bytes.fromArray $ serializeGroup builtinForeignNames sg - declareForeign Untracked "Code.deserialize" boxToEBoxBox - . mkForeign - $ pure . deserializeGroup @Symbol . Bytes.toArray - declareForeign Untracked "Code.display" boxBoxDirect . mkForeign $ - \(nm, sg) -> pure $ prettyGroup @Symbol (Util.Text.unpack nm) sg "" - declareForeign Untracked "Value.dependencies" boxDirect - . mkForeign - $ pure . fmap (Wrap Ty.termLinkRef . Ref) . valueTermLinks - declareForeign Untracked "Value.serialize" boxDirect - . mkForeign - $ pure . Bytes.fromArray . serializeValue - declareForeign Untracked "Value.deserialize" boxToEBoxBox - . mkForeign - $ pure . deserializeValue . Bytes.toArray - -- Hashing functions - let declareHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> FDecl Symbol () - declareHashAlgorithm txt alg = do - let algoRef = Builtin ("crypto.HashAlgorithm." <> txt) - declareForeign Untracked ("crypto.HashAlgorithm." <> txt) direct . mkForeign $ \() -> - pure (HashAlgorithm algoRef alg) - - declareHashAlgorithm "Sha3_512" Hash.SHA3_512 - declareHashAlgorithm "Sha3_256" Hash.SHA3_256 - declareHashAlgorithm "Sha2_512" Hash.SHA512 - declareHashAlgorithm "Sha2_256" Hash.SHA256 - declareHashAlgorithm "Sha1" Hash.SHA1 - declareHashAlgorithm "Blake2b_512" Hash.Blake2b_512 - declareHashAlgorithm "Blake2b_256" Hash.Blake2b_256 - declareHashAlgorithm "Blake2s_256" Hash.Blake2s_256 - declareHashAlgorithm "Md5" Hash.MD5 - - declareForeign Untracked "crypto.hashBytes" boxBoxDirect . mkForeign $ - \(HashAlgorithm _ alg, b :: Bytes.Bytes) -> - let ctx = Hash.hashInitWith alg - in pure . Bytes.fromArray . Hash.hashFinalize $ Hash.hashUpdates ctx (Bytes.byteStringChunks b) - - declareForeign Untracked "crypto.hmacBytes" boxBoxBoxDirect - . mkForeign - $ \(HashAlgorithm _ alg, key :: Bytes.Bytes, msg :: Bytes.Bytes) -> - let out = u alg $ HMAC.hmac (Bytes.toArray @BA.Bytes key) (Bytes.toArray @BA.Bytes msg) - u :: a -> HMAC.HMAC a -> HMAC.HMAC a - u _ h = h -- to help typechecker along - in pure $ Bytes.fromArray out - - declareForeign Untracked "crypto.hash" crypto'hash . mkForeign $ - \(HashAlgorithm _ alg, x) -> - let hashlazy :: - (Hash.HashAlgorithm a) => - a -> - L.ByteString -> - Hash.Digest a - hashlazy _ l = Hash.hashlazy l - in pure . Bytes.fromArray . hashlazy alg $ serializeValueLazy x - - declareForeign Untracked "crypto.hmac" crypto'hmac . mkForeign $ - \(HashAlgorithm _ alg, key, x) -> - let hmac :: - (Hash.HashAlgorithm a) => a -> L.ByteString -> HMAC.HMAC a - hmac _ s = - HMAC.finalize - . HMAC.updates - (HMAC.initialize $ Bytes.toArray @BA.Bytes key) - $ L.toChunks s - in pure . Bytes.fromArray . hmac alg $ serializeValueLazy x - - declareForeign Untracked "crypto.Ed25519.sign.impl" boxBoxBoxToEFBox - . mkForeign - $ pure . signEd25519Wrapper - - declareForeign Untracked "crypto.Ed25519.verify.impl" boxBoxBoxToEFBool - . mkForeign - $ pure . verifyEd25519Wrapper - - declareForeign Untracked "crypto.Rsa.sign.impl" boxBoxToEFBox - . mkForeign - $ pure . signRsaWrapper - - declareForeign Untracked "crypto.Rsa.verify.impl" boxBoxBoxToEFBool - . mkForeign - $ pure . verifyRsaWrapper - - let catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Util.Text.Text a) - catchAll e = do - e <- Exception.tryAnyDeep e - pure $ case e of - Left se -> Left (Util.Text.pack (show se)) - Right a -> Right a - - declareForeign Untracked "Universal.murmurHash" murmur'hash . mkForeign $ - pure . asWord64 . hash64 . serializeValueLazy - - declareForeign Tracked "IO.randomBytes" natToBox . mkForeign $ - \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n - - declareForeign Untracked "Bytes.zlib.compress" boxDirect . mkForeign $ pure . Bytes.zlibCompress - declareForeign Untracked "Bytes.gzip.compress" boxDirect . mkForeign $ pure . Bytes.gzipCompress - declareForeign Untracked "Bytes.zlib.decompress" boxToEBoxBox . mkForeign $ \bs -> - catchAll (pure (Bytes.zlibDecompress bs)) - declareForeign Untracked "Bytes.gzip.decompress" boxToEBoxBox . mkForeign $ \bs -> - catchAll (pure (Bytes.gzipDecompress bs)) - - declareForeign Untracked "Bytes.toBase16" boxDirect . mkForeign $ pure . Bytes.toBase16 - declareForeign Untracked "Bytes.toBase32" boxDirect . mkForeign $ pure . Bytes.toBase32 - declareForeign Untracked "Bytes.toBase64" boxDirect . mkForeign $ pure . Bytes.toBase64 - declareForeign Untracked "Bytes.toBase64UrlUnpadded" boxDirect . mkForeign $ pure . Bytes.toBase64UrlUnpadded - - declareForeign Untracked "Bytes.fromBase16" boxToEBoxBox . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase16 - declareForeign Untracked "Bytes.fromBase32" boxToEBoxBox . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase32 - declareForeign Untracked "Bytes.fromBase64" boxToEBoxBox . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase64 - declareForeign Untracked "Bytes.fromBase64UrlUnpadded" boxToEBoxBox . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded - - declareForeign Untracked "Bytes.decodeNat64be" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64be - declareForeign Untracked "Bytes.decodeNat64le" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64le - declareForeign Untracked "Bytes.decodeNat32be" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32be - declareForeign Untracked "Bytes.decodeNat32le" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32le - declareForeign Untracked "Bytes.decodeNat16be" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16be - declareForeign Untracked "Bytes.decodeNat16le" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16le - - declareForeign Untracked "Bytes.encodeNat64be" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat64be - declareForeign Untracked "Bytes.encodeNat64le" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat64le - declareForeign Untracked "Bytes.encodeNat32be" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat32be - declareForeign Untracked "Bytes.encodeNat32le" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat32le - declareForeign Untracked "Bytes.encodeNat16be" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat16be - declareForeign Untracked "Bytes.encodeNat16le" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat16le - - declareForeign Untracked "MutableArray.copyTo!" boxNatBoxNatNatToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "MutableArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ - checkBounds name (PA.sizeofMutableArray src) (soff + l - 1) $ - Right - <$> PA.copyMutableArray @IO @Closure - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "MutableByteArray.copyTo!" boxNatBoxNatNatToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "MutableByteArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ - checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l) 0 $ - Right - <$> PA.copyMutableByteArray @IO - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "ImmutableArray.copyTo!" boxNatBoxNatNatToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "ImmutableArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ - checkBounds name (PA.sizeofArray src) (soff + l - 1) $ - Right - <$> PA.copyArray @IO @Closure - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "ImmutableArray.size" boxToNat . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofArray @Closure - declareForeign Untracked "MutableArray.size" boxToNat . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Closure - declareForeign Untracked "ImmutableByteArray.size" boxToNat . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofByteArray - declareForeign Untracked "MutableByteArray.size" boxToNat . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld - - declareForeign Untracked "ImmutableByteArray.copyTo!" boxNatBoxNatNatToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "ImmutableByteArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ - checkBoundsPrim name (PA.sizeofByteArray src) (soff + l) 0 $ - Right - <$> PA.copyByteArray @IO - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "MutableArray.read" boxNatToExnBox - . mkForeign - $ checkedRead "MutableArray.read" - declareForeign Untracked "MutableByteArray.read8" boxNatToExnNat - . mkForeign - $ checkedRead8 "MutableByteArray.read8" - declareForeign Untracked "MutableByteArray.read16be" boxNatToExnNat - . mkForeign - $ checkedRead16 "MutableByteArray.read16be" - declareForeign Untracked "MutableByteArray.read24be" boxNatToExnNat - . mkForeign - $ checkedRead24 "MutableByteArray.read24be" - declareForeign Untracked "MutableByteArray.read32be" boxNatToExnNat - . mkForeign - $ checkedRead32 "MutableByteArray.read32be" - declareForeign Untracked "MutableByteArray.read40be" boxNatToExnNat - . mkForeign - $ checkedRead40 "MutableByteArray.read40be" - declareForeign Untracked "MutableByteArray.read64be" boxNatToExnNat - . mkForeign - $ checkedRead64 "MutableByteArray.read64be" - - declareForeign Untracked "MutableArray.write" boxNatBoxToExnUnit - . mkForeign - $ checkedWrite "MutableArray.write" - declareForeign Untracked "MutableByteArray.write8" boxNatNatToExnUnit - . mkForeign - $ checkedWrite8 "MutableByteArray.write8" - declareForeign Untracked "MutableByteArray.write16be" boxNatNatToExnUnit - . mkForeign - $ checkedWrite16 "MutableByteArray.write16be" - declareForeign Untracked "MutableByteArray.write32be" boxNatNatToExnUnit - . mkForeign - $ checkedWrite32 "MutableByteArray.write32be" - declareForeign Untracked "MutableByteArray.write64be" boxNatNatToExnUnit - . mkForeign - $ checkedWrite64 "MutableByteArray.write64be" - - declareForeign Untracked "ImmutableArray.read" boxNatToExnBox - . mkForeign - $ checkedIndex "ImmutableArray.read" - declareForeign Untracked "ImmutableByteArray.read8" boxNatToExnNat - . mkForeign - $ checkedIndex8 "ImmutableByteArray.read8" - declareForeign Untracked "ImmutableByteArray.read16be" boxNatToExnNat - . mkForeign - $ checkedIndex16 "ImmutableByteArray.read16be" - declareForeign Untracked "ImmutableByteArray.read24be" boxNatToExnNat - . mkForeign - $ checkedIndex24 "ImmutableByteArray.read24be" - declareForeign Untracked "ImmutableByteArray.read32be" boxNatToExnNat - . mkForeign - $ checkedIndex32 "ImmutableByteArray.read32be" - declareForeign Untracked "ImmutableByteArray.read40be" boxNatToExnNat - . mkForeign - $ checkedIndex40 "ImmutableByteArray.read40be" - declareForeign Untracked "ImmutableByteArray.read64be" boxNatToExnNat - . mkForeign - $ checkedIndex64 "ImmutableByteArray.read64be" - - declareForeign Untracked "MutableByteArray.freeze!" boxDirect . mkForeign $ - PA.unsafeFreezeByteArray - declareForeign Untracked "MutableArray.freeze!" boxDirect . mkForeign $ - PA.unsafeFreezeArray @IO @Closure - - declareForeign Untracked "MutableByteArray.freeze" boxNatNatToExnBox . mkForeign $ - \(src, off, len) -> - if len == 0 - then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 - else - checkBoundsPrim - "MutableByteArray.freeze" - (PA.sizeofMutableByteArray src) - (off + len) - 0 - $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) - - declareForeign Untracked "MutableArray.freeze" boxNatNatToExnBox . mkForeign $ - \(src, off, len) -> - if len == 0 - then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 Closure.BlackHole - else - checkBounds - "MutableArray.freeze" - (PA.sizeofMutableArray src) - (off + len - 1) - $ Right <$> PA.freezeArray src (fromIntegral off) (fromIntegral len) - - declareForeign Untracked "MutableByteArray.length" boxToNat . mkForeign $ - pure . PA.sizeofMutableByteArray @PA.RealWorld - - declareForeign Untracked "ImmutableByteArray.length" boxToNat . mkForeign $ - pure . PA.sizeofByteArray - - declareForeign Tracked "IO.array" natToBox . mkForeign $ - \n -> PA.newArray n Closure.BlackHole - declareForeign Tracked "IO.arrayOf" boxNatToBox . mkForeign $ - \(v :: Closure, n) -> PA.newArray n v - declareForeign Tracked "IO.bytearray" natToBox . mkForeign $ PA.newByteArray - declareForeign Tracked "IO.bytearrayOf" natNatToBox - . mkForeign - $ \(init, sz) -> do - arr <- PA.newByteArray sz - PA.fillByteArray arr 0 sz init - pure arr - - declareForeign Untracked "Scope.array" natToBox . mkForeign $ - \n -> PA.newArray n Closure.BlackHole - declareForeign Untracked "Scope.arrayOf" boxNatToBox . mkForeign $ - \(v :: Closure, n) -> PA.newArray n v - declareForeign Untracked "Scope.bytearray" natToBox . mkForeign $ PA.newByteArray - declareForeign Untracked "Scope.bytearrayOf" natNatToBox - . mkForeign - $ \(init, sz) -> do - arr <- PA.newByteArray sz - PA.fillByteArray arr 0 sz init - pure arr - - declareForeign Untracked "Text.patterns.literal" boxDirect . mkForeign $ - \txt -> evaluate . TPat.cpattern $ TPat.Literal txt - declareForeign Untracked "Text.patterns.digit" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharRange '0' '9')) in \() -> pure v - declareForeign Untracked "Text.patterns.letter" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Letter)) in \() -> pure v - declareForeign Untracked "Text.patterns.space" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Whitespace)) in \() -> pure v - declareForeign Untracked "Text.patterns.punctuation" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Punctuation)) in \() -> pure v - declareForeign Untracked "Text.patterns.anyChar" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char TPat.Any) in \() -> pure v - declareForeign Untracked "Text.patterns.eof" direct . mkForeign $ - let v = TPat.cpattern TPat.Eof in \() -> pure v - let ccd = wordWordDirect Ty.charRef Ty.charRef - declareForeign Untracked "Text.patterns.charRange" ccd . mkForeign $ - \(beg, end) -> evaluate . TPat.cpattern . TPat.Char $ TPat.CharRange beg end - declareForeign Untracked "Text.patterns.notCharRange" ccd . mkForeign $ - \(beg, end) -> evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharRange beg end - declareForeign Untracked "Text.patterns.charIn" boxDirect . mkForeign $ \ccs -> do - cs <- for ccs $ \case - Closure.DataU1 _ _ i -> pure (toEnum i) - _ -> die "Text.patterns.charIn: non-character closure" - evaluate . TPat.cpattern . TPat.Char $ TPat.CharSet cs - declareForeign Untracked "Text.patterns.notCharIn" boxDirect . mkForeign $ \ccs -> do - cs <- for ccs $ \case - Closure.DataU1 _ _ i -> pure (toEnum i) - _ -> die "Text.patterns.notCharIn: non-character closure" - evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs - declareForeign Untracked "Pattern.many" boxDirect . mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many False p - declareForeign Untracked "Pattern.many.corrected" boxDirect . mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many True p - declareForeign Untracked "Pattern.capture" boxDirect . mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p - declareForeign Untracked "Pattern.captureAs" boxBoxDirect . mkForeign $ - \(t, (TPat.CP p _)) -> evaluate . TPat.cpattern $ TPat.CaptureAs t p - declareForeign Untracked "Pattern.join" boxDirect . mkForeign $ \ps -> - evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps - declareForeign Untracked "Pattern.or" boxBoxDirect . mkForeign $ - \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r - declareForeign Untracked "Pattern.replicate" natNatBoxToBox . mkForeign $ - \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> - let m = fromIntegral m0; n = fromIntegral n0 - in evaluate . TPat.cpattern $ TPat.Replicate m n p - - declareForeign Untracked "Pattern.run" boxBoxToMaybeTup . mkForeign $ - \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input - - declareForeign Untracked "Pattern.isMatch" boxBoxToBool . mkForeign $ - \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input - - declareForeign Untracked "Char.Class.any" direct . mkForeign $ \() -> pure TPat.Any - declareForeign Untracked "Char.Class.not" boxDirect . mkForeign $ pure . TPat.Not - declareForeign Untracked "Char.Class.and" boxBoxDirect . mkForeign $ \(a, b) -> pure $ TPat.Intersect a b - declareForeign Untracked "Char.Class.or" boxBoxDirect . mkForeign $ \(a, b) -> pure $ TPat.Union a b - declareForeign Untracked "Char.Class.range" (wordWordDirect charRef charRef) . mkForeign $ \(a, b) -> pure $ TPat.CharRange a b - declareForeign Untracked "Char.Class.anyOf" boxDirect . mkForeign $ \ccs -> do - cs <- for ccs $ \case - Closure.DataU1 _ _ i -> pure (toEnum i) - _ -> die "Text.patterns.charIn: non-character closure" - evaluate $ TPat.CharSet cs - declareForeign Untracked "Char.Class.alphanumeric" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.AlphaNum) - declareForeign Untracked "Char.Class.upper" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Upper) - declareForeign Untracked "Char.Class.lower" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Lower) - declareForeign Untracked "Char.Class.whitespace" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Whitespace) - declareForeign Untracked "Char.Class.control" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Control) - declareForeign Untracked "Char.Class.printable" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Printable) - declareForeign Untracked "Char.Class.mark" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.MarkChar) - declareForeign Untracked "Char.Class.number" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Number) - declareForeign Untracked "Char.Class.punctuation" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Punctuation) - declareForeign Untracked "Char.Class.symbol" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Symbol) - declareForeign Untracked "Char.Class.separator" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Separator) - declareForeign Untracked "Char.Class.letter" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Letter) - declareForeign Untracked "Char.Class.is" (boxWordToBool charRef) . mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c - declareForeign Untracked "Text.patterns.char" boxDirect . mkForeign $ \c -> - let v = TPat.cpattern (TPat.Char c) in pure v - -type RW = PA.PrimState IO - -checkedRead :: - Text -> (PA.MutableArray RW Closure, Word64) -> IO (Either Failure Closure) -checkedRead name (arr, w) = - checkBounds - name - (PA.sizeofMutableArray arr) - w - (Right <$> PA.readArray arr (fromIntegral w)) - -checkedWrite :: - Text -> (PA.MutableArray RW Closure, Word64, Closure) -> IO (Either Failure ()) -checkedWrite name (arr, w, v) = - checkBounds - name - (PA.sizeofMutableArray arr) - w - (Right <$> PA.writeArray arr (fromIntegral w) v) - -checkedIndex :: - Text -> (PA.Array Closure, Word64) -> IO (Either Failure Closure) -checkedIndex name (arr, w) = - checkBounds - name - (PA.sizeofArray arr) - w - (Right <$> PA.indexArrayM arr (fromIntegral w)) - -checkedRead8 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead8 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ - (Right . fromIntegral) <$> PA.readByteArray @Word8 arr j - where - j = fromIntegral i - -checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead16 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ - mk16 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - where - j = fromIntegral i - -checkedRead24 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead24 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 3 $ - mk24 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - where - j = fromIntegral i - -checkedRead32 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead32 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ - mk32 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - where - j = fromIntegral i - -checkedRead40 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead40 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 6 $ - mk40 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - <*> PA.readByteArray @Word8 arr (j + 4) - where - j = fromIntegral i - -checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead64 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ - mk64 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - <*> PA.readByteArray @Word8 arr (j + 4) - <*> PA.readByteArray @Word8 arr (j + 5) - <*> PA.readByteArray @Word8 arr (j + 6) - <*> PA.readByteArray @Word8 arr (j + 7) - where - j = fromIntegral i - -mk16 :: Word8 -> Word8 -> Either Failure Word64 -mk16 b0 b1 = Right $ (fromIntegral b0 `shiftL` 8) .|. (fromIntegral b1) - -mk24 :: Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk24 b0 b1 b2 = - Right $ - (fromIntegral b0 `shiftL` 16) - .|. (fromIntegral b1 `shiftL` 8) - .|. (fromIntegral b2) - -mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk32 b0 b1 b2 b3 = - Right $ - (fromIntegral b0 `shiftL` 24) - .|. (fromIntegral b1 `shiftL` 16) - .|. (fromIntegral b2 `shiftL` 8) - .|. (fromIntegral b3) - -mk40 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk40 b0 b1 b2 b3 b4 = - Right $ - (fromIntegral b0 `shiftL` 32) - .|. (fromIntegral b1 `shiftL` 24) - .|. (fromIntegral b2 `shiftL` 16) - .|. (fromIntegral b3 `shiftL` 8) - .|. (fromIntegral b4) - -mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk64 b0 b1 b2 b3 b4 b5 b6 b7 = - Right $ - (fromIntegral b0 `shiftL` 56) - .|. (fromIntegral b1 `shiftL` 48) - .|. (fromIntegral b2 `shiftL` 40) - .|. (fromIntegral b3 `shiftL` 32) - .|. (fromIntegral b4 `shiftL` 24) - .|. (fromIntegral b5 `shiftL` 16) - .|. (fromIntegral b6 `shiftL` 8) - .|. (fromIntegral b7) - -checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite8 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ do - PA.writeByteArray arr j (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite16 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite16 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite32 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite32 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 24 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 16 :: Word8) - PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 3) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite64 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite64 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 56 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 48 :: Word8) - PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 40 :: Word8) - PA.writeByteArray arr (j + 3) (fromIntegral $ v `shiftR` 32 :: Word8) - PA.writeByteArray arr (j + 4) (fromIntegral $ v `shiftR` 24 :: Word8) - PA.writeByteArray arr (j + 5) (fromIntegral $ v `shiftR` 16 :: Word8) - PA.writeByteArray arr (j + 6) (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 7) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - --- index single byte -checkedIndex8 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex8 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 1 . pure $ - let j = fromIntegral i - in Right . fromIntegral $ PA.indexByteArray @Word8 arr j - --- index 16 big-endian -checkedIndex16 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex16 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 2 . pure $ - let j = fromIntegral i - in mk16 (PA.indexByteArray arr j) (PA.indexByteArray arr (j + 1)) - --- index 32 big-endian -checkedIndex24 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex24 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 3 . pure $ - let j = fromIntegral i - in mk24 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - --- index 32 big-endian -checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex32 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 4 . pure $ - let j = fromIntegral i - in mk32 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - --- index 40 big-endian -checkedIndex40 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex40 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 5 . pure $ - let j = fromIntegral i - in mk40 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - (PA.indexByteArray arr (j + 4)) - --- index 64 big-endian -checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex64 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 8 . pure $ - let j = fromIntegral i - in mk64 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - (PA.indexByteArray arr (j + 4)) - (PA.indexByteArray arr (j + 5)) - (PA.indexByteArray arr (j + 6)) - (PA.indexByteArray arr (j + 7)) - -checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) -checkBounds name l w act - | w < fromIntegral l = act - | otherwise = pure $ Left err - where - msg = name <> ": array index out of bounds" - err = Failure Ty.arrayFailureRef msg (natValue w) - --- Performs a bounds check on a byte array. Strategy is as follows: --- --- isz = signed array size-in-bytes --- off = unsigned byte offset into the array --- esz = unsigned number of bytes to be read --- --- 1. Turn the signed size-in-bytes of the array unsigned --- 2. Add the offset to the to-be-read number to get the maximum size needed --- 3. Check that the actual array size is at least as big as the needed size --- 4. Check that the offset is less than the size --- --- Step 4 ensures that step 3 has not overflowed. Since an actual array size can --- only be 63 bits (since it is signed), the only way for 3 to overflow is if --- the offset is larger than a possible array size, since it would need to be --- 2^64-k, where k is the small (<=8) number of bytes to be read. -checkBoundsPrim :: - Text -> Int -> Word64 -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) -checkBoundsPrim name isz off esz act - | w > bsz || off > bsz = pure $ Left err - | otherwise = act - where - msg = name <> ": array index out of bounds" - err = Failure Ty.arrayFailureRef msg (natValue off) - - bsz = fromIntegral isz - w = off + esz - -hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference -hostPreference Nothing = SYS.HostAny -hostPreference (Just host) = SYS.Host $ Util.Text.unpack host - -signEd25519Wrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes -signEd25519Wrapper (secret0, public0, msg0) = case validated of - CryptoFailed err -> - Left (Failure Ty.cryptoFailureRef (errMsg err) unitValue) - CryptoPassed (secret, public) -> - Right . Bytes.fromArray $ Ed25519.sign secret public msg - where - msg = Bytes.toArray msg0 :: ByteString - validated = - (,) - <$> Ed25519.secretKey (Bytes.toArray secret0 :: ByteString) - <*> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) - - errMsg CryptoError_PublicKeySizeInvalid = - "ed25519: Public key size invalid" - errMsg CryptoError_SecretKeySizeInvalid = - "ed25519: Secret key size invalid" - errMsg CryptoError_SecretKeyStructureInvalid = - "ed25519: Secret key structure invalid" - errMsg _ = "ed25519: unexpected error" - -verifyEd25519Wrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool -verifyEd25519Wrapper (public0, msg0, sig0) = case validated of - CryptoFailed err -> - Left $ Failure Ty.cryptoFailureRef (errMsg err) unitValue - CryptoPassed (public, sig) -> - Right $ Ed25519.verify public msg sig - where - msg = Bytes.toArray msg0 :: ByteString - validated = - (,) - <$> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) - <*> Ed25519.signature (Bytes.toArray sig0 :: ByteString) - - errMsg CryptoError_PublicKeySizeInvalid = - "ed25519: Public key size invalid" - errMsg CryptoError_SecretKeySizeInvalid = - "ed25519: Secret key size invalid" - errMsg CryptoError_SecretKeyStructureInvalid = - "ed25519: Secret key structure invalid" - errMsg _ = "ed25519: unexpected error" - -signRsaWrapper :: - (Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes -signRsaWrapper (secret0, msg0) = case validated of - Left err -> - Left (Failure Ty.cryptoFailureRef err unitValue) - Right secret -> - case RSA.sign Nothing (Just Hash.SHA256) secret msg of - Left err -> Left (Failure Ty.cryptoFailureRef (Rsa.rsaErrorToText err) unitValue) - Right signature -> Right $ Bytes.fromByteString signature - where - msg = Bytes.toArray msg0 :: ByteString - validated = Rsa.parseRsaPrivateKey (Bytes.toArray secret0 :: ByteString) - -verifyRsaWrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool -verifyRsaWrapper (public0, msg0, sig0) = case validated of - Left err -> - Left $ Failure Ty.cryptoFailureRef err unitValue - Right public -> - Right $ RSA.verify (Just Hash.SHA256) public msg sig - where - msg = Bytes.toArray msg0 :: ByteString - sig = Bytes.toArray sig0 :: ByteString - validated = Rsa.parseRsaPublicKey (Bytes.toArray public0 :: ByteString) - -typeReferences :: [(Reference, Word64)] -typeReferences = zip rs [1 ..] - where - rs = - [r | (_, r) <- Ty.builtinTypes] - ++ [DerivedId i | (_, i, _) <- Ty.builtinDataDecls] - ++ [DerivedId i | (_, i, _) <- Ty.builtinEffectDecls] - -foreignDeclResults :: - Bool -> (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) -foreignDeclResults sanitize = - execState (runReaderT declareForeigns sanitize) (0, [], mempty) - -foreignWrappers :: [(Data.Text.Text, (Sandbox, SuperNormal Symbol))] -foreignWrappers | (_, l, _) <- foreignDeclResults False = reverse l - -numberedTermLookup :: EnumMap Word64 (SuperNormal Symbol) -numberedTermLookup = - mapFromList . zip [1 ..] . Map.elems . fmap snd $ builtinLookup - -builtinTermNumbering :: Map Reference Word64 -builtinTermNumbering = - Map.fromList (zip (Map.keys $ builtinLookup) [1 ..]) - -builtinTermBackref :: EnumMap Word64 Reference -builtinTermBackref = - mapFromList . zip [1 ..] . Map.keys $ builtinLookup - -builtinTypeNumbering :: Map Reference Word64 -builtinTypeNumbering = Map.fromList typeReferences - -builtinTypeBackref :: EnumMap Word64 Reference -builtinTypeBackref = mapFromList $ swap <$> typeReferences - where - swap (x, y) = (y, x) - -builtinForeigns :: EnumMap Word64 ForeignFunc -builtinForeigns | (_, _, m) <- foreignDeclResults False = snd <$> m - -sandboxedForeigns :: EnumMap Word64 ForeignFunc -sandboxedForeigns | (_, _, m) <- foreignDeclResults True = snd <$> m - -builtinForeignNames :: EnumMap Word64 Data.Text.Text -builtinForeignNames | (_, _, m) <- foreignDeclResults False = fst <$> m - --- Bootstrapping for sandbox check. The eventual map will be one with --- associations `r -> s` where `s` is all the 'sensitive' base --- functions that `r` calls. -baseSandboxInfo :: Map Reference (Set Reference) -baseSandboxInfo = - Map.fromList $ - [ (r, Set.singleton r) - | (r, (sb, _)) <- Map.toList builtinLookup, - sb == Tracked - ] - -unsafeSTMToIO :: STM.STM a -> IO a -unsafeSTMToIO (STM.STM m) = IO m diff --git a/parser-typechecker/src/Unison/Runtime/Decompile.hs b/parser-typechecker/src/Unison/Runtime/Decompile.hs deleted file mode 100644 index a1b1646ce8..0000000000 --- a/parser-typechecker/src/Unison/Runtime/Decompile.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Runtime.Decompile - ( decompile, - DecompResult, - DecompError (..), - renderDecompError, - ) -where - -import Data.Set (singleton) -import Unison.ABT (substs) -import Unison.Codebase.Runtime (Error) -import Unison.ConstructorReference (GConstructorReference (..)) -import Unison.Prelude -import Unison.Reference (Reference, pattern Builtin) -import Unison.Referent (pattern Ref) -import Unison.Runtime.ANF (maskTags) -import Unison.Runtime.Array - ( Array, - ByteArray, - byteArrayToList, - ) -import Unison.Runtime.Foreign - ( Foreign (..), - HashAlgorithm (..), - maybeUnwrapBuiltin, - maybeUnwrapForeign, - ) -import Unison.Runtime.IOSource (iarrayFromListRef, ibarrayFromBytesRef) -import Unison.Runtime.MCode (CombIx (..)) -import Unison.Runtime.Stack - ( Closure (..), - pattern DataC, - pattern PApV, - ) -import Unison.Syntax.NamePrinter (prettyReference) -import Unison.Term - ( Term, - app, - apps', - boolean, - builtin, - char, - constructor, - float, - int, - list, - list', - nat, - ref, - termLink, - text, - typeLink, - pattern LamNamed', - ) -import Unison.Term qualified as Term -import Unison.Type - ( anyRef, - booleanRef, - charRef, - floatRef, - iarrayRef, - ibytearrayRef, - intRef, - listRef, - natRef, - termLinkRef, - typeLinkRef, - ) -import Unison.Util.Bytes qualified as By -import Unison.Util.Pretty (indentN, lines, lit, syntaxToColor, wrap) -import Unison.Util.Text qualified as Text -import Unison.Var (Var) -import Unsafe.Coerce -- for Int -> Double -import Prelude hiding (lines) - -con :: (Var v) => Reference -> Word64 -> Term v () -con rf ct = constructor () (ConstructorReference rf $ fromIntegral ct) - -bug :: (Var v) => Text -> Term v () -bug msg = app () (builtin () "bug") (text () msg) - -err :: DecompError -> a -> (Set DecompError, a) -err err x = (singleton err, x) - -data DecompError - = BadBool !Word64 - | BadUnboxed !Reference - | BadForeign !Reference - | BadData !Reference - | BadPAp !Reference - | UnkComb !Reference - | UnkLocal !Reference !Word64 - | Cont - | Exn - deriving (Eq, Ord) - -type DecompResult v = (Set DecompError, Term v ()) - -prf :: Reference -> Error -prf = syntaxToColor . prettyReference 10 - -renderDecompError :: DecompError -> Error -renderDecompError (BadBool n) = - lines - [ wrap "A boolean value had an unexpected constructor tag:", - indentN 2 . lit . fromString $ show n - ] -renderDecompError (BadUnboxed rf) = - lines - [ wrap "An apparent numeric type had an unrecognized reference:", - indentN 2 $ prf rf - ] -renderDecompError (BadForeign rf) = - lines - [ wrap "A foreign value with no decompiled representation was encountered:", - indentN 2 $ prf rf - ] -renderDecompError (BadData rf) = - lines - [ wrap - "A data type with no decompiled representation was encountered:", - indentN 2 $ prf rf - ] -renderDecompError (BadPAp rf) = - lines - [ wrap "A partial function application could not be decompiled: ", - indentN 2 $ prf rf - ] -renderDecompError (UnkComb rf) = - lines - [ wrap "A reference to an unknown function was encountered: ", - indentN 2 $ prf rf - ] -renderDecompError (UnkLocal rf n) = - lines - [ "A reference to an unknown portion to a function was encountered: ", - indentN 2 $ "function: " <> prf rf, - indentN 2 $ "section: " <> lit (fromString $ show n) - ] -renderDecompError Cont = "A continuation value was encountered" -renderDecompError Exn = "An exception value was encountered" - -decompile :: - (Var v) => - (Reference -> Maybe Reference) -> - (Word64 -> Word64 -> Maybe (Term v ())) -> - Closure -> - DecompResult v -decompile _ _ (DataC rf (maskTags -> ct) [] []) - | rf == booleanRef = tag2bool ct -decompile _ _ (DataC rf (maskTags -> ct) [i] []) = - decompileUnboxed rf ct i -decompile backref topTerms (DataC rf _ [] [b]) - | rf == anyRef = - app () (builtin () "Any.Any") <$> decompile backref topTerms b -decompile backref topTerms (DataC rf (maskTags -> ct) [] bs) = - apps' (con rf ct) <$> traverse (decompile backref topTerms) bs -decompile backref topTerms (PApV (CIx rf rt k) [] bs) - | rf == Builtin "jumpCont" = err Cont $ bug "" - | Builtin nm <- rf = - apps' (builtin () nm) <$> traverse (decompile backref topTerms) bs - | Just t <- topTerms rt k = - Term.etaReduceEtaVars . substitute t - <$> traverse (decompile backref topTerms) bs - | k > 0, - Just _ <- topTerms rt 0 = - err (UnkLocal rf k) $ bug "" - | otherwise = err (UnkComb rf) $ ref () rf -decompile _ _ (PAp (CIx rf _ _) _ _) = - err (BadPAp rf) $ bug "" -decompile _ _ (DataC rf _ _ _) = err (BadData rf) $ bug "" -decompile _ _ BlackHole = err Exn $ bug "" -decompile _ _ (Captured {}) = err Cont $ bug "" -decompile backref topTerms (Foreign f) = - decompileForeign backref topTerms f - -tag2bool :: (Var v) => Word64 -> DecompResult v -tag2bool 0 = pure (boolean () False) -tag2bool 1 = pure (boolean () True) -tag2bool n = err (BadBool n) $ con booleanRef n - -substitute :: (Var v) => Term v () -> [Term v ()] -> Term v () -substitute = align [] - where - align vts (LamNamed' v bd) (t : ts) = align ((v, t) : vts) bd ts - align vts tm [] = substs vts tm - -- this should not happen - align vts tm ts = apps' (substs vts tm) ts - -decompileUnboxed :: - (Var v) => Reference -> Word64 -> Int -> DecompResult v -decompileUnboxed r _ i - | r == natRef = pure . nat () $ fromIntegral i - | r == intRef = pure . int () $ fromIntegral i - | r == floatRef = pure . float () $ unsafeCoerce i - | r == charRef = pure . char () $ toEnum i - | otherwise = err (BadUnboxed r) . nat () $ fromIntegral i - -decompileForeign :: - (Var v) => - (Reference -> Maybe Reference) -> - (Word64 -> Word64 -> Maybe (Term v ())) -> - Foreign -> - DecompResult v -decompileForeign backref topTerms f - | Just t <- maybeUnwrapBuiltin f = pure $ text () (Text.toText t) - | Just b <- maybeUnwrapBuiltin f = pure $ decompileBytes b - | Just h <- maybeUnwrapBuiltin f = pure $ decompileHashAlgorithm h - | Just l <- maybeUnwrapForeign termLinkRef f = - pure . termLink () $ case l of - Ref r -> maybe l Ref $ backref r - _ -> l - | Just l <- maybeUnwrapForeign typeLinkRef f = - pure $ typeLink () l - | Just (a :: Array Closure) <- maybeUnwrapForeign iarrayRef f = - app () (ref () iarrayFromListRef) . list () - <$> traverse (decompile backref topTerms) (toList a) - | Just (a :: ByteArray) <- maybeUnwrapForeign ibytearrayRef f = - pure $ - app - () - (ref () ibarrayFromBytesRef) - (decompileBytes . By.fromWord8s $ byteArrayToList a) - | Just s <- unwrapSeq f = - list' () <$> traverse (decompile backref topTerms) s -decompileForeign _ _ (Wrap r _) = - err (BadForeign r) $ bug "" - -decompileBytes :: (Var v) => By.Bytes -> Term v () -decompileBytes = - app () (builtin () $ fromString "Bytes.fromList") - . list () - . fmap (nat () . fromIntegral) - . By.toWord8s - -decompileHashAlgorithm :: (Var v) => HashAlgorithm -> Term v () -decompileHashAlgorithm (HashAlgorithm r _) = ref () r - -unwrapSeq :: Foreign -> Maybe (Seq Closure) -unwrapSeq = maybeUnwrapForeign listRef diff --git a/parser-typechecker/src/Unison/Runtime/Exception.hs b/parser-typechecker/src/Unison/Runtime/Exception.hs deleted file mode 100644 index dff4a627b7..0000000000 --- a/parser-typechecker/src/Unison/Runtime/Exception.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Unison.Runtime.Exception where - -import Control.Exception -import Data.String (fromString) -import Data.Text -import GHC.Stack -import Unison.Reference (Reference) -import Unison.Runtime.Stack -import Unison.Util.Pretty as P - -data RuntimeExn - = PE CallStack (P.Pretty P.ColorText) - | BU [(Reference, Int)] Text Closure - deriving (Show) - -instance Exception RuntimeExn - -die :: (HasCallStack) => String -> IO a -die = throwIO . PE callStack . P.lit . fromString - -dieP :: HasCallStack => P.Pretty P.ColorText -> IO a -dieP = throwIO . PE callStack - -exn :: (HasCallStack) => String -> a -exn = throw . PE callStack . P.lit . fromString diff --git a/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs b/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs deleted file mode 100644 index 3f1b93d9e2..0000000000 --- a/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs +++ /dev/null @@ -1,548 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Runtime.Foreign.Function - ( ForeignFunc (..), - ForeignConvention (..), - mkForeign, - ) -where - -import Control.Concurrent (ThreadId) -import Control.Concurrent.MVar (MVar) -import Control.Concurrent.STM (TVar) -import Control.Exception (evaluate) -import Data.Atomics (Ticket) -import Data.Char qualified as Char -import Data.Foldable (toList) -import Data.IORef (IORef) -import Data.Primitive.Array as PA -import Data.Primitive.ByteArray as PA -import Data.Sequence qualified as Sq -import Data.Time.Clock.POSIX (POSIXTime) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.IO.Exception (IOErrorType (..), IOException (..)) -import Network.Socket (Socket) -import Network.UDP (UDPSocket) -import System.IO (BufferMode (..), Handle, IOMode, SeekMode) -import Unison.Builtin.Decls qualified as Ty -import Unison.Reference (Reference) -import Unison.Runtime.ANF (Mem (..), SuperGroup, Value, internalBug) -import Unison.Runtime.Exception -import Unison.Runtime.Foreign -import Unison.Runtime.MCode -import Unison.Runtime.Stack -import Unison.Symbol (Symbol) -import Unison.Type - ( iarrayRef, - ibytearrayRef, - marrayRef, - mbytearrayRef, - mvarRef, - promiseRef, - refRef, - ticketRef, - tvarRef, - typeLinkRef, - ) -import Unison.Util.Bytes (Bytes) -import Unison.Util.RefPromise (Promise) -import Unison.Util.Text (Text, pack, unpack) - --- Foreign functions operating on stacks -data ForeignFunc where - FF :: - (Stack 'UN -> Stack 'BX -> Args -> IO a) -> - (Stack 'UN -> Stack 'BX -> r -> IO (Stack 'UN, Stack 'BX)) -> - (a -> IO r) -> - ForeignFunc - -instance Show ForeignFunc where - show _ = "ForeignFunc" - -instance Eq ForeignFunc where - _ == _ = internalBug "Eq ForeignFunc" - -instance Ord ForeignFunc where - compare _ _ = internalBug "Ord ForeignFunc" - -class ForeignConvention a where - readForeign :: - [Int] -> [Int] -> Stack 'UN -> Stack 'BX -> IO ([Int], [Int], a) - writeForeign :: - Stack 'UN -> Stack 'BX -> a -> IO (Stack 'UN, Stack 'BX) - -mkForeign :: - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeign ev = FF readArgs writeForeign ev - where - readArgs ustk bstk (argsToLists -> (us, bs)) = - readForeign us bs ustk bstk >>= \case - ([], [], a) -> pure a - _ -> - internalBug - "mkForeign: too many arguments for foreign function" - -instance ForeignConvention Int where - readForeign (i : us) bs ustk _ = (us,bs,) <$> peekOff ustk i - readForeign [] _ _ _ = foreignCCError "Int" - writeForeign ustk bstk i = do - ustk <- bump ustk - (ustk, bstk) <$ poke ustk i - -instance ForeignConvention Word64 where - readForeign (i : us) bs ustk _ = (us,bs,) <$> peekOffN ustk i - readForeign [] _ _ _ = foreignCCError "Word64" - writeForeign ustk bstk n = do - ustk <- bump ustk - (ustk, bstk) <$ pokeN ustk n - -instance ForeignConvention Word8 where - readForeign = readForeignAs (fromIntegral :: Word64 -> Word8) - writeForeign = writeForeignAs (fromIntegral :: Word8 -> Word64) - -instance ForeignConvention Word16 where - readForeign = readForeignAs (fromIntegral :: Word64 -> Word16) - writeForeign = writeForeignAs (fromIntegral :: Word16 -> Word64) - -instance ForeignConvention Word32 where - readForeign = readForeignAs (fromIntegral :: Word64 -> Word32) - writeForeign = writeForeignAs (fromIntegral :: Word32 -> Word64) - -instance ForeignConvention Char where - readForeign (i : us) bs ustk _ = (us,bs,) . Char.chr <$> peekOff ustk i - readForeign [] _ _ _ = foreignCCError "Char" - writeForeign ustk bstk ch = do - ustk <- bump ustk - (ustk, bstk) <$ poke ustk (Char.ord ch) - -instance ForeignConvention Closure where - readForeign us (i : bs) _ bstk = (us,bs,) <$> peekOff bstk i - readForeign _ [] _ _ = foreignCCError "Closure" - writeForeign ustk bstk c = do - bstk <- bump bstk - (ustk, bstk) <$ (poke bstk =<< evaluate c) - -instance ForeignConvention Text where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin - -instance ForeignConvention Bytes where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin - -instance ForeignConvention Socket where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin - -instance ForeignConvention UDPSocket where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin - -instance ForeignConvention ThreadId where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin - -instance ForeignConvention Handle where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin - -instance ForeignConvention POSIXTime where - readForeign = readForeignAs (fromIntegral :: Int -> POSIXTime) - writeForeign = writeForeignAs (round :: POSIXTime -> Int) - -instance (ForeignConvention a) => ForeignConvention (Maybe a) where - readForeign (i : us) bs ustk bstk = - peekOff ustk i >>= \case - 0 -> pure (us, bs, Nothing) - 1 -> fmap Just <$> readForeign us bs ustk bstk - _ -> foreignCCError "Maybe" - readForeign [] _ _ _ = foreignCCError "Maybe" - - writeForeign ustk bstk Nothing = do - ustk <- bump ustk - (ustk, bstk) <$ poke ustk 0 - writeForeign ustk bstk (Just x) = do - (ustk, bstk) <- writeForeign ustk bstk x - ustk <- bump ustk - (ustk, bstk) <$ poke ustk 1 - -instance - (ForeignConvention a, ForeignConvention b) => - ForeignConvention (Either a b) - where - readForeign (i : us) bs ustk bstk = - peekOff ustk i >>= \case - 0 -> readForeignAs Left us bs ustk bstk - 1 -> readForeignAs Right us bs ustk bstk - _ -> foreignCCError "Either" - readForeign _ _ _ _ = foreignCCError "Either" - - writeForeign ustk bstk (Left a) = do - (ustk, bstk) <- writeForeign ustk bstk a - ustk <- bump ustk - (ustk, bstk) <$ poke ustk 0 - writeForeign ustk bstk (Right b) = do - (ustk, bstk) <- writeForeign ustk bstk b - ustk <- bump ustk - (ustk, bstk) <$ poke ustk 1 - -ioeDecode :: Int -> IOErrorType -ioeDecode 0 = AlreadyExists -ioeDecode 1 = NoSuchThing -ioeDecode 2 = ResourceBusy -ioeDecode 3 = ResourceExhausted -ioeDecode 4 = EOF -ioeDecode 5 = IllegalOperation -ioeDecode 6 = PermissionDenied -ioeDecode 7 = UserError -ioeDecode _ = internalBug "ioeDecode" - -ioeEncode :: IOErrorType -> Int -ioeEncode AlreadyExists = 0 -ioeEncode NoSuchThing = 1 -ioeEncode ResourceBusy = 2 -ioeEncode ResourceExhausted = 3 -ioeEncode EOF = 4 -ioeEncode IllegalOperation = 5 -ioeEncode PermissionDenied = 6 -ioeEncode UserError = 7 -ioeEncode _ = internalBug "ioeDecode" - -instance ForeignConvention IOException where - readForeign = readForeignAs (bld . ioeDecode) - where - bld t = IOError Nothing t "" "" Nothing Nothing - - writeForeign = writeForeignAs (ioeEncode . ioe_type) - -readForeignAs :: - (ForeignConvention a) => - (a -> b) -> - [Int] -> - [Int] -> - Stack 'UN -> - Stack 'BX -> - IO ([Int], [Int], b) -readForeignAs f us bs ustk bstk = fmap f <$> readForeign us bs ustk bstk - -writeForeignAs :: - (ForeignConvention b) => - (a -> b) -> - Stack 'UN -> - Stack 'BX -> - a -> - IO (Stack 'UN, Stack 'BX) -writeForeignAs f ustk bstk x = writeForeign ustk bstk (f x) - -readForeignEnum :: - (Enum a) => - [Int] -> - [Int] -> - Stack 'UN -> - Stack 'BX -> - IO ([Int], [Int], a) -readForeignEnum = readForeignAs toEnum - -writeForeignEnum :: - (Enum a) => - Stack 'UN -> - Stack 'BX -> - a -> - IO (Stack 'UN, Stack 'BX) -writeForeignEnum = writeForeignAs fromEnum - -readForeignBuiltin :: - (BuiltinForeign b) => - [Int] -> - [Int] -> - Stack 'UN -> - Stack 'BX -> - IO ([Int], [Int], b) -readForeignBuiltin = readForeignAs (unwrapBuiltin . marshalToForeign) - -writeForeignBuiltin :: - (BuiltinForeign b) => - Stack 'UN -> - Stack 'BX -> - b -> - IO (Stack 'UN, Stack 'BX) -writeForeignBuiltin = writeForeignAs (Foreign . wrapBuiltin) - -writeTypeLink :: - Stack 'UN -> - Stack 'BX -> - Reference -> - IO (Stack 'UN, Stack 'BX) -writeTypeLink = writeForeignAs (Foreign . Wrap typeLinkRef) - -readTypelink :: - [Int] -> - [Int] -> - Stack 'UN -> - Stack 'BX -> - IO ([Int], [Int], Reference) -readTypelink = readForeignAs (unwrapForeign . marshalToForeign) - -instance ForeignConvention Double where - readForeign (i : us) bs ustk _ = (us,bs,) <$> peekOffD ustk i - readForeign _ _ _ _ = foreignCCError "Double" - writeForeign ustk bstk d = - bump ustk >>= \ustk -> - (ustk, bstk) <$ pokeD ustk d - -instance ForeignConvention Bool where - readForeign = readForeignEnum - writeForeign = writeForeignEnum - -instance ForeignConvention String where - readForeign = readForeignAs unpack - writeForeign = writeForeignAs pack - -instance ForeignConvention SeekMode where - readForeign = readForeignEnum - writeForeign = writeForeignEnum - -instance ForeignConvention IOMode where - readForeign = readForeignEnum - writeForeign = writeForeignEnum - -instance ForeignConvention () where - readForeign us bs _ _ = pure (us, bs, ()) - writeForeign ustk bstk _ = pure (ustk, bstk) - -instance - (ForeignConvention a, ForeignConvention b) => - ForeignConvention (a, b) - where - readForeign us bs ustk bstk = do - (us, bs, a) <- readForeign us bs ustk bstk - (us, bs, b) <- readForeign us bs ustk bstk - pure (us, bs, (a, b)) - - writeForeign ustk bstk (x, y) = do - (ustk, bstk) <- writeForeign ustk bstk y - writeForeign ustk bstk x - -instance (ForeignConvention a) => ForeignConvention (Failure a) where - readForeign us bs ustk bstk = do - (us, bs, typeref) <- readTypelink us bs ustk bstk - (us, bs, message) <- readForeign us bs ustk bstk - (us, bs, any) <- readForeign us bs ustk bstk - pure (us, bs, Failure typeref message any) - - writeForeign ustk bstk (Failure typeref message any) = do - (ustk, bstk) <- writeForeign ustk bstk any - (ustk, bstk) <- writeForeign ustk bstk message - writeTypeLink ustk bstk typeref - -instance - ( ForeignConvention a, - ForeignConvention b, - ForeignConvention c - ) => - ForeignConvention (a, b, c) - where - readForeign us bs ustk bstk = do - (us, bs, a) <- readForeign us bs ustk bstk - (us, bs, b) <- readForeign us bs ustk bstk - (us, bs, c) <- readForeign us bs ustk bstk - pure (us, bs, (a, b, c)) - - writeForeign ustk bstk (a, b, c) = do - (ustk, bstk) <- writeForeign ustk bstk c - (ustk, bstk) <- writeForeign ustk bstk b - writeForeign ustk bstk a - -instance - ( ForeignConvention a, - ForeignConvention b, - ForeignConvention c, - ForeignConvention d - ) => - ForeignConvention (a, b, c, d) - where - readForeign us bs ustk bstk = do - (us, bs, a) <- readForeign us bs ustk bstk - (us, bs, b) <- readForeign us bs ustk bstk - (us, bs, c) <- readForeign us bs ustk bstk - (us, bs, d) <- readForeign us bs ustk bstk - pure (us, bs, (a, b, c, d)) - - writeForeign ustk bstk (a, b, c, d) = do - (ustk, bstk) <- writeForeign ustk bstk d - (ustk, bstk) <- writeForeign ustk bstk c - (ustk, bstk) <- writeForeign ustk bstk b - writeForeign ustk bstk a - -instance - ( ForeignConvention a, - ForeignConvention b, - ForeignConvention c, - ForeignConvention d, - ForeignConvention e - ) => - ForeignConvention (a, b, c, d, e) - where - readForeign us bs ustk bstk = do - (us, bs, a) <- readForeign us bs ustk bstk - (us, bs, b) <- readForeign us bs ustk bstk - (us, bs, c) <- readForeign us bs ustk bstk - (us, bs, d) <- readForeign us bs ustk bstk - (us, bs, e) <- readForeign us bs ustk bstk - pure (us, bs, (a, b, c, d, e)) - - writeForeign ustk bstk (a, b, c, d, e) = do - (ustk, bstk) <- writeForeign ustk bstk e - (ustk, bstk) <- writeForeign ustk bstk d - (ustk, bstk) <- writeForeign ustk bstk c - (ustk, bstk) <- writeForeign ustk bstk b - writeForeign ustk bstk a - -no'buf, line'buf, block'buf, sblock'buf :: Int -no'buf = fromIntegral Ty.bufferModeNoBufferingId -line'buf = fromIntegral Ty.bufferModeLineBufferingId -block'buf = fromIntegral Ty.bufferModeBlockBufferingId -sblock'buf = fromIntegral Ty.bufferModeSizedBlockBufferingId - -instance ForeignConvention BufferMode where - readForeign (i : us) bs ustk bstk = - peekOff ustk i >>= \case - t - | t == no'buf -> pure (us, bs, NoBuffering) - | t == line'buf -> pure (us, bs, LineBuffering) - | t == block'buf -> pure (us, bs, BlockBuffering Nothing) - | t == sblock'buf -> - fmap (BlockBuffering . Just) - <$> readForeign us bs ustk bstk - | otherwise -> - foreignCCError $ - "BufferMode (unknown tag: " <> show t <> ")" - readForeign _ _ _ _ = foreignCCError $ "BufferMode (empty stack)" - - writeForeign ustk bstk bm = - bump ustk >>= \ustk -> - case bm of - NoBuffering -> (ustk, bstk) <$ poke ustk no'buf - LineBuffering -> (ustk, bstk) <$ poke ustk line'buf - BlockBuffering Nothing -> (ustk, bstk) <$ poke ustk block'buf - BlockBuffering (Just n) -> do - poke ustk n - ustk <- bump ustk - (ustk, bstk) <$ poke ustk sblock'buf - -instance ForeignConvention [Closure] where - readForeign us (i : bs) _ bstk = - (us,bs,) . toList <$> peekOffS bstk i - readForeign _ _ _ _ = foreignCCError "[Closure]" - writeForeign ustk bstk l = do - bstk <- bump bstk - (ustk, bstk) <$ pokeS bstk (Sq.fromList l) - -instance ForeignConvention [Foreign] where - readForeign = readForeignAs (fmap marshalToForeign) - writeForeign = writeForeignAs (fmap Foreign) - -instance ForeignConvention (MVar Closure) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap mvarRef) - -instance ForeignConvention (TVar Closure) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap tvarRef) - -instance ForeignConvention (IORef Closure) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap refRef) - -instance ForeignConvention (Ticket Closure) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap ticketRef) - -instance ForeignConvention (Promise Closure) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap promiseRef) - -instance ForeignConvention (SuperGroup Symbol) where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin - -instance ForeignConvention Value where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin - -instance ForeignConvention Foreign where - readForeign = readForeignAs marshalToForeign - writeForeign = writeForeignAs Foreign - -instance ForeignConvention (PA.MutableArray s Closure) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap marrayRef) - -instance ForeignConvention (PA.MutableByteArray s) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap mbytearrayRef) - -instance ForeignConvention (PA.Array Closure) where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap iarrayRef) - -instance ForeignConvention PA.ByteArray where - readForeign = readForeignAs (unwrapForeign . marshalToForeign) - writeForeign = writeForeignAs (Foreign . Wrap ibytearrayRef) - -instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where - readForeign = readForeignBuiltin - writeForeign = writeForeignBuiltin - -fromUnisonPair :: Closure -> (a, b) -fromUnisonPair (DataC _ _ [] [x, DataC _ _ [] [y, _]]) = - (unwrapForeignClosure x, unwrapForeignClosure y) -fromUnisonPair _ = error "fromUnisonPair: invalid closure" - -toUnisonPair :: - (BuiltinForeign a, BuiltinForeign b) => (a, b) -> Closure -toUnisonPair (x, y) = - DataC - Ty.pairRef - 0 - [] - [wr x, DataC Ty.pairRef 0 [] [wr y, un]] - where - un = DataC Ty.unitRef 0 [] [] - wr z = Foreign $ wrapBuiltin z - -unwrapForeignClosure :: Closure -> a -unwrapForeignClosure = unwrapForeign . marshalToForeign - -instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignConvention [(a, b)] where - readForeign us (i : bs) _ bstk = - (us,bs,) - . fmap fromUnisonPair - . toList - <$> peekOffS bstk i - readForeign _ _ _ _ = foreignCCError "[(a,b)]" - - writeForeign ustk bstk l = do - bstk <- bump bstk - (ustk, bstk) <$ pokeS bstk (toUnisonPair <$> Sq.fromList l) - -instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention [b] where - readForeign us (i : bs) _ bstk = - (us,bs,) - . fmap unwrapForeignClosure - . toList - <$> peekOffS bstk i - readForeign _ _ _ _ = foreignCCError "[b]" - writeForeign ustk bstk l = do - bstk <- bump bstk - (ustk, bstk) <$ pokeS bstk (Foreign . wrapBuiltin <$> Sq.fromList l) - -foreignCCError :: String -> IO a -foreignCCError nm = - die $ "mismatched foreign calling convention for `" ++ nm ++ "`" diff --git a/parser-typechecker/src/Unison/Runtime/MCode.hs b/parser-typechecker/src/Unison/Runtime/MCode.hs deleted file mode 100644 index 28f821f231..0000000000 --- a/parser-typechecker/src/Unison/Runtime/MCode.hs +++ /dev/null @@ -1,1636 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PatternSynonyms #-} - -module Unison.Runtime.MCode - ( Args' (..), - Args (..), - RefNums (..), - MLit (..), - Instr (..), - Section (.., MatchT, MatchW), - Comb (..), - Combs, - CombIx (..), - Ref (..), - UPrim1 (..), - UPrim2 (..), - BPrim1 (..), - BPrim2 (..), - Branch (..), - bcount, - ucount, - emitCombs, - emitComb, - emptyRNs, - argsToLists, - combRef, - combDeps, - combTypes, - prettyCombs, - prettyComb, - ) -where - -import Control.Applicative (liftA2) -import Data.Bifunctor (bimap, first) -import Data.Bits (shiftL, shiftR, (.|.)) -import Data.Coerce -import Data.List (partition) -import Data.Map.Strict qualified as M -import Data.Primitive.ByteArray -import Data.Primitive.PrimArray -import Data.Word (Word16, Word64) -import GHC.Stack (HasCallStack) -import Unison.ABT.Normalized (pattern TAbss) -import Unison.Reference (Reference) -import Unison.Referent (Referent) -import Unison.Runtime.ANF - ( ANormal, - Branched (..), - CTag, - Direction (..), - Func (..), - Mem (..), - SuperGroup (..), - SuperNormal (..), - internalBug, - packTags, - pattern TApp, - pattern TBLit, - pattern TFOp, - pattern TFrc, - pattern THnd, - pattern TLets, - pattern TLit, - pattern TMatch, - pattern TName, - pattern TPrm, - pattern TShift, - pattern TVar, - ) -import Unison.Runtime.ANF qualified as ANF -import Unison.Util.EnumContainers as EC -import Unison.Util.Text (Text) -import Unison.Var (Var) - --- This outlines some of the ideas/features in this core --- language, and how they may be used to implement features of --- the surface language. - ------------------------ --- Delimited control -- ------------------------ - --- There is native support for delimited control operations in --- the core language. This means we can: --- 1. delimit a block of code with an integer tagged prompt, --- which corresponds to pushing a frame onto the --- continuation with said tag --- 2. capture a portion of the continuation up to a particular --- tag frame and turn it into a value, which _removes_ the --- tag frame from the continuation in the process --- 3. push such a captured value back onto the continuation - --- TBD: Since the captured continuations in _delimited_ control --- are (in this case impure) functions, it may make sense to make --- the representation of functions support these captured --- continuations directly. - --- The obvious use case of this feature is effects and handlers. --- Delimiting a block with a prompt is part of installing a --- handler for said block at least naively. The other part is --- establishing the code that should be executed for each --- operation to be handled. - --- It's important (I believe) in #2 that the prompt be removed --- from the continuation by a control effect. The captured --- continuation not being automatically delimited corresponds to --- a shallow handler's obligation to re-establish the handling of --- a re-invoked computation if it wishes to do so. The delimiter --- being removed from the capturing code's continuation --- corresponds to a handler being allowed to yield effects from --- the same siganture that it is handling. - --- In special cases, it should be possible to omit use of control --- effects in handlers. At the least, if a handler case resumes --- the computation in tail position, it should be unnecessary to --- capture the continuation at all. If all cases act this way, we --- don't need a delimiter, because we will never capture. - --- TBD: it may make more sense to have prompt pushing be part of --- some other construct, due to A-normal forms of the code. - ------------------------------ --- Unboxed sum-of-products -- ------------------------------ - --- It is not usually stated this way, but one of the core --- features of the STG machine is that functions/closures can --- return unboxed sum-of-products types. This is actually the way --- _all_ data types work in STG. The discriminee of a case --- statement must eventually return by pushing several values --- onto the stack (the product part) and specifying which branch --- to return to (the sum part). - --- The way heap allocated data is produced is that an --- intermediate frame may be in the continuation that grabs this --- information from the local storage and puts it into the heap. --- If this frame were omitted, only the unboxed component would --- be left. Also, in STG, the heap allocated data is just a means --- of reconstructing its unboxed analogue. Evaluating a heap --- allocated data type value just results in pushing its stored --- fields back on the stack, and immediately returning the tag. - --- The portion of this with the heap allocation frame omitted --- seems to be a natural match for the case analysis portion of --- handlers. A naive implementation of an effect algebra is as --- the data type of the polynomial functor generated by the --- signature, and handling corresponds to case analysis. However, --- in a real implementation, we don't want a heap allocated --- representation of this algebra, because its purpose is control --- flow. Each operation will be handled once as it occurs, and we --- won't save work by remembering some reified representation of --- which operations were used. - --- Since handlers in unison are written as functions, it seems to --- make sense to define a calling convention for unboxed --- sum-of-products as arguments. Variable numbers of stack --- positions could be pushed for such arguments, with tags --- specifying which case is being provided. - --- TBD: sum arguments to a function correspond to a product of --- functions, so it's possible that the calling convention for --- these functions should be similar to returning to a case, --- where we push arguments and then select which of several --- pieces of code to jump to. This view also seems relevant to --- the optimized implementation of certain forms of handler, --- where we want effects to just directly select some code to --- execute based on state that has been threaded to that point. - --- One thing to note: it probably does not make sense to --- completely divide returns into unboxed returns and allocation --- frames. The reason this works in STG is laziness. Naming a --- computation with `let` does not do any evaluation, but it does --- allocate space for its (boxed) result. The only thing that --- _does_ demand evaluation is case analysis. So, if a value with --- sum type is being evaluated, we know it must be about to be --- unpacked, and it makes little sense to pack it on the stack, --- though we can build a closure version of it in the writeback --- location established by `let`. - --- By contrast, in unison a `let` of a sum type evaluates it --- immediately, even if no one is analyzing it. So we might waste --- work rearranging the stack with the unpacked contents when we --- only needed the closure version to begin with. Instead, we --- gain the ability to make the unpacking operation use no stack, --- because we know what we are unpacking must be a value. Turning --- boxed function calls into unboxed versions thus seems like a --- situational optimization, rather than a universal calling --- convention. - -------------------------------- --- Delimited Dynamic Binding -- -------------------------------- - --- There is a final component to the implementation of ability --- handlers in this runtime system, and that is dynamically --- scoped variables associated to each prompt. Each prompt --- corresponds to an ability signature, and `reset` to a handler --- for said signature, but we need storage space for the code --- installed by said handler. It is possible to implement --- dynamically scoped variables entirely with delimited --- continuations, but it is more efficient to keep track of the --- storage directly when manipulating the continuations. - --- The dynamic scoping---and how it interacts with --- continuations---corresponds to the nested structure of --- handlers. Installing a handler establishes a variable scope, --- shadowing outer scopes for the same prompt. Shifting, however, --- can exit these scopes dynamically. So, for instance, if we --- have a structure like: - --- reset 0 $ ... --- reset 1 $ ... --- reset 0 $ ... --- shift 1 - --- We have nested scopes 0>1>0, with the second 0 shadowing the --- first. However, when we shift to 1, the inner 0 scope is --- captured into the continuation, and uses of the 0 ability in --- will be handled by the outer handler until it is shadowed --- again (and the captured continuation will re-establish the --- shadowing). - --- Mutation of the variables is possible, but mutation only --- affects the current scope. Essentially, the dynamic scoping is --- of mutable references, and when scope changes, we switch --- between different references, and the mutation of each --- reference does not affect the others. The purpose of the --- mutation is to enable more efficient implementation of --- certain recursive, 'deep' handlers, since those can operate --- more like stateful code than control operators. - -data Args' - = Arg1 !Int - | Arg2 !Int !Int - | -- frame index of each argument to the function - ArgN {-# UNPACK #-} !(PrimArray Int) - | ArgR !Int !Int - deriving (Show) - -data Args - = ZArgs - | UArg1 !Int - | UArg2 !Int !Int - | BArg1 !Int - | BArg2 !Int !Int - | DArg2 !Int !Int - | UArgR !Int !Int - | BArgR !Int !Int - | DArgR !Int !Int !Int !Int - | BArgN !(PrimArray Int) - | UArgN !(PrimArray Int) - | DArgN !(PrimArray Int) !(PrimArray Int) - | DArgV !Int !Int - deriving (Show, Eq, Ord) - -argsToLists :: Args -> ([Int], [Int]) -argsToLists ZArgs = ([], []) -argsToLists (UArg1 i) = ([i], []) -argsToLists (UArg2 i j) = ([i, j], []) -argsToLists (BArg1 i) = ([], [i]) -argsToLists (BArg2 i j) = ([], [i, j]) -argsToLists (DArg2 i j) = ([i], [j]) -argsToLists (UArgR i l) = (take l [i ..], []) -argsToLists (BArgR i l) = ([], take l [i ..]) -argsToLists (DArgR ui ul bi bl) = (take ul [ui ..], take bl [bi ..]) -argsToLists (BArgN bs) = ([], primArrayToList bs) -argsToLists (UArgN us) = (primArrayToList us, []) -argsToLists (DArgN us bs) = (primArrayToList us, primArrayToList bs) -argsToLists (DArgV _ _) = internalBug "argsToLists: DArgV" - -ucount, bcount :: Args -> Int -ucount (UArg1 _) = 1 -ucount (UArg2 _ _) = 2 -ucount (DArg2 _ _) = 1 -ucount (UArgR _ l) = l -ucount (DArgR _ l _ _) = l -ucount _ = 0 -{-# INLINE ucount #-} -bcount (BArg1 _) = 1 -bcount (BArg2 _ _) = 2 -bcount (DArg2 _ _) = 1 -bcount (BArgR _ l) = l -bcount (DArgR _ _ _ l) = l -bcount (BArgN a) = sizeofPrimArray a -bcount _ = 0 -{-# INLINE bcount #-} - -data UPrim1 - = -- integral - DECI - | INCI - | NEGI - | SGNI -- decrement,increment,negate,signum - | LZRO - | TZRO - | COMN - | POPC -- leading/trailingZeroes,complement - -- floating - | ABSF - | EXPF - | LOGF - | SQRT -- abs,exp,log,sqrt - | COSF - | ACOS - | COSH - | ACSH -- cos,acos,cosh,acosh - | SINF - | ASIN - | SINH - | ASNH -- sin,asin,sinh,asinh - | TANF - | ATAN - | TANH - | ATNH -- tan,atan,tanh,atanh - | ITOF - | NTOF - | CEIL - | FLOR -- intToFloat,natToFloat,ceiling,floor - | TRNF - | RNDF -- truncate,round - deriving (Show, Eq, Ord) - -data UPrim2 - = -- integral - ADDI - | SUBI - | MULI - | DIVI - | MODI -- +,-,*,/,mod - | DIVN - | MODN - | SHLI - | SHRI - | SHRN - | POWI -- shiftl,shiftr,shiftr,pow - | EQLI - | LEQI - | LEQN -- ==,<=,<= - | ANDN - | IORN - | XORN -- and,or,xor - -- floating - | EQLF - | LEQF -- ==,<= - | ADDF - | SUBF - | MULF - | DIVF - | ATN2 -- +,-,*,/,atan2 - | POWF - | LOGB - | MAXF - | MINF -- pow,low,max,min - deriving (Show, Eq, Ord) - -data BPrim1 - = -- text - SIZT - | USNC - | UCNS -- size,unsnoc,uncons - | ITOT - | NTOT - | FTOT -- intToText,natToText,floatToText - | TTOI - | TTON - | TTOF -- textToInt,textToNat,textToFloat - | PAKT - | UPKT -- pack,unpack - -- sequence - | VWLS - | VWRS - | SIZS -- viewl,viewr,size - | PAKB - | UPKB - | SIZB -- pack,unpack,size - | FLTB -- flatten - -- code - | MISS - | CACH - | LKUP - | LOAD -- isMissing,cache_,lookup,load - | CVLD -- validate - | VALU - | TLTT -- value, Term.Link.toText - -- debug - | DBTX -- debug text - | SDBL -- sandbox link list - deriving (Show, Eq, Ord) - -data BPrim2 - = -- universal - EQLU - | CMPU -- ==,compare - -- text - | DRPT - | CATT - | TAKT -- drop,append,take - | IXOT -- indexof - | EQLT - | LEQT - | LEST -- ==,<=,< - -- sequence - | DRPS - | CATS - | TAKS -- drop,append,take - | CONS - | SNOC - | IDXS -- cons,snoc,index - | SPLL - | SPLR -- splitLeft,splitRight - -- bytes - | TAKB - | DRPB - | IDXB - | CATB -- take,drop,index,append - | IXOB -- indexof - -- general - | THRO -- throw - | TRCE -- trace - -- code - | SDBX -- sandbox - | SDBV -- sandbox Value - deriving (Show, Eq, Ord) - -data MLit - = MI !Int - | MD !Double - | MT !Text - | MM !Referent - | MY !Reference - deriving (Show, Eq, Ord) - --- Instructions for manipulating the data stack in the main portion of --- a block -data Instr - = -- 1-argument unboxed primitive operations - UPrim1 - !UPrim1 -- primitive instruction - !Int -- index of prim argument - | -- 2-argument unboxed primitive operations - UPrim2 - !UPrim2 -- primitive instruction - !Int -- index of first prim argument - !Int -- index of second prim argument - | -- 1-argument primitive operations that may involve boxed values - BPrim1 - !BPrim1 - !Int - | -- 2-argument primitive operations that may involve boxed values - BPrim2 - !BPrim2 - !Int - !Int - | -- Call out to a Haskell function. This is considerably slower - -- for very simple operations, hence the primops. - ForeignCall - !Bool -- catch exceptions - !Word64 -- FFI call - !Args -- arguments - | -- Set the value of a dynamic reference - SetDyn - !Word64 -- the prompt tag of the reference - !Int -- the stack index of the closure to store - | -- Capture the continuation up to a given marker. - Capture !Word64 -- the prompt tag - | -- This is essentially the opposite of `Call`. Pack a given - -- statically known function into a closure with arguments. - -- No stack is necessary, because no nested evaluation happens, - -- so the instruction directly takes a follow-up. - Name !Ref !Args - | -- Dump some debugging information about the machine state to - -- the screen. - Info !String -- prefix for output - | -- Pack a data type value into a closure and place it - -- on the stack. - Pack - !Reference -- data type reference - !Word64 -- tag - !Args -- arguments to pack - | -- Unpack the contents of a data type onto the stack - Unpack - !(Maybe Reference) -- debug reference - !Int -- stack index of data to unpack - | -- Push a particular value onto the appropriate stack - Lit !MLit -- value to push onto the stack - | -- Push a particular value directly onto the boxed stack - BLit !Reference !MLit - | -- Print a value on the unboxed stack - Print !Int -- index of the primitive value to print - | -- Put a delimiter on the continuation - Reset !(EnumSet Word64) -- prompt ids - | -- Fork thread evaluating delayed computation on boxed stack - Fork !Int - | -- Atomic transaction evaluating delayed computation on boxed stack - Atomically !Int - | -- Build a sequence consisting of a variable number of arguments - Seq !Args - | -- Force a delayed expression, catching any runtime exceptions involved - TryForce !Int - deriving (Show, Eq, Ord) - -data Section - = -- Apply a function to arguments. This is the 'slow path', and - -- handles applying functions from arbitrary sources. This - -- requires checks to determine what exactly should happen. - App - !Bool -- skip argument check for known calling convention - !Ref -- function to call - !Args -- arguments - | -- This is the 'fast path', for when we statically know we're - -- making an exactly saturated call to a statically known - -- function. This allows skipping various checks that can cost - -- time in very tight loops. This also allows skipping the - -- stack check if we know that the current stack allowance is - -- sufficient for where we're jumping to. - Call - !Bool -- skip stack check - !Word64 -- global function reference - !Args -- arguments - | -- Jump to a captured continuation value. - Jump - !Int -- index of captured continuation - !Args -- arguments to send to continuation - | -- Branch on the value in the unboxed data stack - Match - !Int -- index of unboxed item to match on - !Branch -- branches - | -- Yield control to the current continuation, with arguments - Yield !Args -- values to yield - | -- Prefix an instruction onto a section - Ins !Instr !Section - | -- Sequence two sections. The second is pushed as a return - -- point for the results of the first. Stack modifications in - -- the first are lost on return to the second. - Let !Section !CombIx - | -- Throw an exception with the given message - Die String - | -- Immediately stop a thread of interpretation. This is more of - -- a debugging tool than a proper operation to target. - Exit - | -- Branch on a data type without dumping the tag onto the unboxed - -- stack. - DMatch - !(Maybe Reference) -- expected data type - !Int -- index of data item on boxed stack - !Branch -- branches - | -- Branch on a numeric type without dumping it to the stack - NMatch - !(Maybe Reference) -- expected data type - !Int -- index of data item on boxed stack - !Branch -- branches - | -- Branch on a request representation without dumping the tag - -- portion to the unboxed stack. - RMatch - !Int -- index of request item on the boxed stack - !Section -- pure case - !(EnumMap Word64 Branch) -- effect cases - deriving (Show, Eq, Ord) - -data CombIx - = CIx - !Reference -- top reference - !Word64 -- top level - !Word64 -- section - deriving (Eq, Ord, Show) - -combRef :: CombIx -> Reference -combRef (CIx r _ _) = r - -data RefNums = RN - { dnum :: Reference -> Word64, - cnum :: Reference -> Word64 - } - -emptyRNs :: RefNums -emptyRNs = RN mt mt - where - mt _ = internalBug "RefNums: empty" - -data Comb - = Lam - !Int -- Number of unboxed arguments - !Int -- Number of boxed arguments - !Int -- Maximum needed unboxed frame size - !Int -- Maximum needed boxed frame size - !Section -- Entry - deriving (Show, Eq, Ord) - -type Combs = EnumMap Word64 Comb - -data Ref - = Stk !Int -- stack reference to a closure - | Env - !Word64 -- global environment reference to a combinator - !Word64 -- section - | Dyn !Word64 -- dynamic scope reference to a closure - deriving (Show, Eq, Ord) - -data Branch - = -- if tag == n then t else f - Test1 - !Word64 - !Section - !Section - | Test2 - !Word64 - !Section -- if tag == m then ... - !Word64 - !Section -- else if tag == n then ... - !Section -- else ... - | TestW - !Section - !(EnumMap Word64 Section) - | TestT - !Section - !(M.Map Text Section) - deriving (Show, Eq, Ord) - --- Convenience patterns for matches used in the algorithms below. -pattern MatchW :: Int -> Section -> EnumMap Word64 Section -> Section -pattern MatchW i d cs = Match i (TestW d cs) - -pattern MatchT :: Int -> Section -> M.Map Text Section -> Section -pattern MatchT i d cs = Match i (TestT d cs) - -pattern NMatchW :: - Maybe Reference -> Int -> Section -> EnumMap Word64 Section -> Section -pattern NMatchW r i d cs = NMatch r i (TestW d cs) - --- Representation of the variable context available in the current --- frame. This tracks tags that have been dumped to the stack for --- proper indexing. The `Block` constructor is used to mark when we --- go into the first portion of a `Let`, to track the size of that --- sub-frame. -data Ctx v - = ECtx - | Block (Ctx v) - | Tag (Ctx v) - | Var v Mem (Ctx v) - deriving (Show) - --- Represents the context formed by the top-level let rec around a --- set of definitions. Previous steps have normalized the term to --- only contain a single recursive binding group. The variables in --- this binding group are resolved to numbered combinators rather --- than stack positions. -type RCtx v = M.Map v Word64 - --- Add a sequence of variables and corresponding calling conventions --- to the context. -ctx :: [v] -> [Mem] -> Ctx v -ctx vs cs = pushCtx (zip vs cs) ECtx - --- Look up a variable in the context, getting its position on the --- relevant stack and its calling convention if it is there. -ctxResolve :: (Var v) => Ctx v -> v -> Maybe (Int, Mem) -ctxResolve ctx v = walk 0 0 ctx - where - walk _ _ ECtx = Nothing - walk ui bi (Block ctx) = walk ui bi ctx - walk ui bi (Tag ctx) = walk (ui + 1) bi ctx - walk ui bi (Var x m ctx) - | v == x = case m of BX -> Just (bi, m); UN -> Just (ui, m) - | otherwise = walk ui' bi' ctx - where - (ui', bi') = case m of BX -> (ui, bi + 1); UN -> (ui + 1, bi) - --- Add a sequence of variables and calling conventions to the context. -pushCtx :: [(v, Mem)] -> Ctx v -> Ctx v -pushCtx new old = foldr (uncurry Var) old new - --- Concatenate two contexts -catCtx :: Ctx v -> Ctx v -> Ctx v -catCtx ECtx r = r -catCtx (Tag l) r = Tag $ catCtx l r -catCtx (Block l) r = Block $ catCtx l r -catCtx (Var v m l) r = Var v m $ catCtx l r - --- Split the context after a particular variable -breakAfter :: (Eq v) => (v -> Bool) -> Ctx v -> (Ctx v, Ctx v) -breakAfter _ ECtx = (ECtx, ECtx) -breakAfter p (Tag vs) = first Tag $ breakAfter p vs -breakAfter p (Block vs) = first Block $ breakAfter p vs -breakAfter p (Var v m vs) = (Var v m lvs, rvs) - where - (lvs, rvs) - | p v = (ECtx, vs) - | otherwise = breakAfter p vs - --- Modify the context to contain the variables introduced by an --- unboxed sum -sumCtx :: (Var v) => Ctx v -> v -> [(v, Mem)] -> Ctx v -sumCtx ctx v vcs - | (lctx, rctx) <- breakAfter (== v) ctx = - catCtx lctx $ pushCtx vcs rctx - --- Look up a variable in the top let rec context -rctxResolve :: (Var v) => RCtx v -> v -> Maybe Word64 -rctxResolve ctx u = M.lookup u ctx - --- Compile a top-level definition group to a collection of combinators. --- The provided word refers to the numbering for the overall group, --- and intra-group calls are numbered locally, with 0 specifying --- the global entry point. -emitCombs :: - (Var v) => - RefNums -> - Reference -> - Word64 -> - SuperGroup v -> - EnumMap Word64 Comb -emitCombs rns grpr grpn (Rec grp ent) = - emitComb rns grpr grpn rec (0, ent) <> aux - where - (rvs, cmbs) = unzip grp - ixs = map (`shiftL` 16) [1 ..] - rec = M.fromList $ zip rvs ixs - aux = foldMap (emitComb rns grpr grpn rec) (zip ixs cmbs) - --- Type for aggregating the necessary stack frame size. First field is --- unboxed size, second is boxed. The Applicative instance takes the --- point-wise maximum, so that combining values from different branches --- results in finding the maximum value of either size necessary. -data Counted a = C !Int !Int a - deriving (Functor) - -instance Applicative Counted where - pure = C 0 0 - C u0 b0 f <*> C u1 b1 x = C (max u0 u1) (max b0 b1) (f x) - -newtype Emit a - = EM (Word64 -> (EC.EnumMap Word64 Comb, Counted a)) - deriving (Functor) - -runEmit :: Word64 -> Emit a -> EC.EnumMap Word64 Comb -runEmit w (EM e) = fst $ e w - -instance Applicative Emit where - pure = EM . pure . pure . pure - EM ef <*> EM ex = EM $ (liftA2 . liftA2) (<*>) ef ex - -counted :: Counted a -> Emit a -counted = EM . pure . pure - -onCount :: (Counted a -> Counted b) -> Emit a -> Emit b -onCount f (EM e) = EM $ fmap f <$> e - -letIndex :: Word16 -> Word64 -> Word64 -letIndex l c = c .|. fromIntegral l - -record :: Ctx v -> Word16 -> Emit Section -> Emit Word64 -record ctx l (EM es) = EM $ \c -> - let (m, C u b s) = es c - (au, ab) = countCtx0 0 0 ctx - n = letIndex l c - in (EC.mapInsert n (Lam au ab u b s) m, C u b n) - -recordTop :: [v] -> Word16 -> Emit Section -> Emit () -recordTop vs l (EM e) = EM $ \c -> - let (m, C u b s) = e c - ab = length vs - n = letIndex l c - in (EC.mapInsert n (Lam 0 ab u b s) m, C u b ()) - --- Counts the stack space used by a context and annotates a value --- with it. -countCtx :: Ctx v -> a -> Emit a -countCtx ctx = counted . C u b where (u, b) = countCtx0 0 0 ctx - -countCtx0 :: Int -> Int -> Ctx v -> (Int, Int) -countCtx0 !ui !bi (Var _ UN ctx) = countCtx0 (ui + 1) bi ctx -countCtx0 ui bi (Var _ BX ctx) = countCtx0 ui (bi + 1) ctx -countCtx0 ui bi (Tag ctx) = countCtx0 (ui + 1) bi ctx -countCtx0 ui bi (Block ctx) = countCtx0 ui bi ctx -countCtx0 ui bi ECtx = (ui, bi) - -emitComb :: - (Var v) => - RefNums -> - Reference -> - Word64 -> - RCtx v -> - (Word64, SuperNormal v) -> - EC.EnumMap Word64 Comb -emitComb rns grpr grpn rec (n, Lambda ccs (TAbss vs bd)) = - runEmit n - . recordTop vs 0 - $ emitSection rns grpr grpn rec (ctx vs ccs) bd - -addCount :: Int -> Int -> Emit a -> Emit a -addCount i j = onCount $ \(C u b x) -> C (u + i) (b + j) x - --- Emit a machine code section from an ANF term -emitSection :: - (Var v) => - RefNums -> - Reference -> - Word64 -> - RCtx v -> - Ctx v -> - ANormal v -> - Emit Section -emitSection rns grpr grpn rec ctx (TLets d us ms bu bo) = - emitLet rns grpr grpn rec d (zip us ms) ctx bu $ - emitSection rns grpr grpn rec ectx bo - where - ectx = pushCtx (zip us ms) ctx -emitSection rns grpr grpn rec ctx (TName u (Left f) args bo) = - emitClosures grpn rec ctx args $ \ctx as -> - Ins (Name (Env (cnum rns f) 0) as) - <$> emitSection rns grpr grpn rec (Var u BX ctx) bo -emitSection rns grpr grpn rec ctx (TName u (Right v) args bo) - | Just (i, BX) <- ctxResolve ctx v = - emitClosures grpn rec ctx args $ \ctx as -> - Ins (Name (Stk i) as) - <$> emitSection rns grpr grpn rec (Var u BX ctx) bo - | Just n <- rctxResolve rec v = - emitClosures grpn rec ctx args $ \ctx as -> - Ins (Name (Env grpn n) as) - <$> emitSection rns grpr grpn rec (Var u BX ctx) bo - | otherwise = emitSectionVErr v -emitSection _ _ grpn rec ctx (TVar v) - | Just (i, BX) <- ctxResolve ctx v = countCtx ctx . Yield $ BArg1 i - | Just (i, UN) <- ctxResolve ctx v = countCtx ctx . Yield $ UArg1 i - | Just j <- rctxResolve rec v = - countCtx ctx $ App False (Env grpn j) ZArgs - | otherwise = emitSectionVErr v -emitSection _ _ grpn _ ctx (TPrm p args) = - -- 3 is a conservative estimate of how many extra stack slots - -- a prim op will need for its results. - addCount 3 3 - . countCtx ctx - . Ins (emitPOp p $ emitArgs grpn ctx args) - . Yield - $ DArgV i j - where - (i, j) = countBlock ctx -emitSection _ _ grpn _ ctx (TFOp p args) = - addCount 3 3 - . countCtx ctx - . Ins (emitFOp p $ emitArgs grpn ctx args) - . Yield - $ DArgV i j - where - (i, j) = countBlock ctx -emitSection rns _ grpn rec ctx (TApp f args) = - emitClosures grpn rec ctx args $ \ctx as -> - countCtx ctx $ emitFunction rns grpn rec ctx f as -emitSection _ _ _ _ ctx (TLit l) = - c . countCtx ctx . Ins (emitLit l) . Yield $ litArg l - where - c - | ANF.T {} <- l = addCount 0 1 - | ANF.LM {} <- l = addCount 0 1 - | ANF.LY {} <- l = addCount 0 1 - | otherwise = addCount 1 0 -emitSection _ _ _ _ ctx (TBLit l) = - addCount 0 1 . countCtx ctx . Ins (emitBLit l) . Yield $ BArg1 0 -emitSection rns grpr grpn rec ctx (TMatch v bs) - | Just (i, BX) <- ctxResolve ctx v, - MatchData r cs df <- bs = - DMatch (Just r) i - <$> emitDataMatching r rns grpr grpn rec ctx cs df - | Just (i, BX) <- ctxResolve ctx v, - MatchRequest hs0 df <- bs, - hs <- mapFromList $ first (dnum rns) <$> M.toList hs0 = - uncurry (RMatch i) - <$> emitRequestMatching rns grpr grpn rec ctx hs df - | Just (i, UN) <- ctxResolve ctx v, - MatchIntegral cs df <- bs = - emitLitMatching - MatchW - "missing integral case" - rns - grpr - grpn - rec - ctx - i - cs - df - | Just (i, BX) <- ctxResolve ctx v, - MatchNumeric r cs df <- bs = - emitLitMatching - (NMatchW (Just r)) - "missing integral case" - rns - grpr - grpn - rec - ctx - i - cs - df - | Just (i, BX) <- ctxResolve ctx v, - MatchText cs df <- bs = - emitLitMatching - MatchT - "missing text case" - rns - grpr - grpn - rec - ctx - i - cs - df - | Just (i, UN) <- ctxResolve ctx v, - MatchSum cs <- bs = - emitSumMatching rns grpr grpn rec ctx v i cs - | Just (_, cc) <- ctxResolve ctx v = - internalBug $ - "emitSection: mismatched calling convention for match: " - ++ matchCallingError cc bs - | otherwise = - internalBug $ - "emitSection: could not resolve match variable: " ++ show (ctx, v) -emitSection rns grpr grpn rec ctx (THnd rs h b) - | Just (i, BX) <- ctxResolve ctx h = - Ins (Reset (EC.setFromList ws)) - . flip (foldr (\r -> Ins (SetDyn r i))) ws - <$> emitSection rns grpr grpn rec ctx b - | otherwise = emitSectionVErr h - where - ws = dnum rns <$> rs -emitSection rns grpr grpn rec ctx (TShift r v e) = - Ins (Capture $ dnum rns r) - <$> emitSection rns grpr grpn rec (Var v BX ctx) e -emitSection _ _ _ _ ctx (TFrc v) - | Just (i, BX) <- ctxResolve ctx v = - countCtx ctx $ App False (Stk i) ZArgs - | Just _ <- ctxResolve ctx v = - internalBug $ - "emitSection: values to be forced must be boxed: " ++ show v - | otherwise = emitSectionVErr v -emitSection _ _ _ _ _ tm = - internalBug $ "emitSection: unhandled code: " ++ show tm - --- Emit the code for a function call -emitFunction :: - (Var v) => - RefNums -> - Word64 -> -- self combinator number - RCtx v -> -- recursive binding group - Ctx v -> -- local context - Func v -> - Args -> - Section -emitFunction _ grpn rec ctx (FVar v) as - | Just (i, BX) <- ctxResolve ctx v = - App False (Stk i) as - | Just j <- rctxResolve rec v = - App False (Env grpn j) as - | otherwise = emitSectionVErr v -emitFunction rns _ _ _ (FComb r) as - | otherwise -- slow path - = - App False (Env n 0) as - where - n = cnum rns r -emitFunction rns _ _ _ (FCon r t) as = - Ins (Pack r (packTags rt t) as) - . Yield - $ BArg1 0 - where - rt = toEnum . fromIntegral $ dnum rns r -emitFunction rns _ _ _ (FReq r e) as = - -- Currently implementing packed calling convention for abilities - -- TODO ct is 16 bits, but a is 48 bits. This will be a problem if we have - -- more than 2^16 types. - Ins (Pack r (packTags rt e) as) - . App True (Dyn a) - $ BArg1 0 - where - a = dnum rns r - rt = toEnum . fromIntegral $ a -emitFunction _ _ _ ctx (FCont k) as - | Just (i, BX) <- ctxResolve ctx k = Jump i as - | Nothing <- ctxResolve ctx k = emitFunctionVErr k - | otherwise = internalBug $ "emitFunction: continuations are boxed" -emitFunction _ _ _ _ (FPrim _) _ = - internalBug "emitFunction: impossible" - -countBlock :: Ctx v -> (Int, Int) -countBlock = go 0 0 - where - go !ui !bi (Var _ UN ctx) = go (ui + 1) bi ctx - go ui bi (Var _ BX ctx) = go ui (bi + 1) ctx - go ui bi (Tag ctx) = go (ui + 1) bi ctx - go ui bi _ = (ui, bi) - -matchCallingError :: Mem -> Branched v -> String -matchCallingError cc b = "(" ++ show cc ++ "," ++ brs ++ ")" - where - brs - | MatchData _ _ _ <- b = "MatchData" - | MatchEmpty <- b = "MatchEmpty" - | MatchIntegral _ _ <- b = "MatchIntegral" - | MatchNumeric _ _ _ <- b = "MatchNumeric" - | MatchRequest _ _ <- b = "MatchRequest" - | MatchSum _ <- b = "MatchSum" - | MatchText _ _ <- b = "MatchText" - -emitSectionVErr :: (Var v, HasCallStack) => v -> a -emitSectionVErr v = - internalBug $ - "emitSection: could not resolve function variable: " ++ show v - -emitFunctionVErr :: (Var v, HasCallStack) => v -> a -emitFunctionVErr v = - internalBug $ - "emitFunction: could not resolve function variable: " ++ show v - -litArg :: ANF.Lit -> Args -litArg ANF.T {} = BArg1 0 -litArg ANF.LM {} = BArg1 0 -litArg ANF.LY {} = BArg1 0 -litArg _ = UArg1 0 - --- Emit machine code for a let expression. Some expressions do not --- require a machine code Let, which uses more complicated stack --- manipulation. -emitLet :: - (Var v) => - RefNums -> - Reference -> - Word64 -> - RCtx v -> - Direction Word16 -> - [(v, Mem)] -> - Ctx v -> - ANormal v -> - Emit Section -> - Emit Section -emitLet _ _ _ _ _ _ _ (TLit l) = - fmap (Ins $ emitLit l) -emitLet _ _ _ _ _ _ _ (TBLit l) = - fmap (Ins $ emitBLit l) --- emitLet rns grp _ _ _ ctx (TApp (FComb r) args) --- -- We should be able to tell if we are making a saturated call --- -- or not here. We aren't carrying the information here yet, though. --- | False -- not saturated --- = fmap (Ins . Name (Env n 0) $ emitArgs grp ctx args) --- where --- n = cnum rns r -emitLet rns _ grpn _ _ _ ctx (TApp (FCon r n) args) = - fmap (Ins . Pack r (packTags rt n) $ emitArgs grpn ctx args) - where - rt = toEnum . fromIntegral $ dnum rns r -emitLet _ _ grpn _ _ _ ctx (TApp (FPrim p) args) = - fmap (Ins . either emitPOp emitFOp p $ emitArgs grpn ctx args) -emitLet rns grpr grpn rec d vcs ctx bnd - | Direct <- d = - internalBug $ "unsupported compound direct let: " ++ show bnd - | Indirect w <- d = - \esect -> - f - <$> emitSection rns grpr grpn rec (Block ctx) bnd - <*> record (pushCtx vcs ctx) w esect - where - f s w = Let s (CIx grpr grpn w) - --- Translate from ANF prim ops to machine code operations. The --- machine code operations are divided with respect to more detailed --- information about expected number and types of arguments. -emitPOp :: ANF.POp -> Args -> Instr --- Integral -emitPOp ANF.ADDI = emitP2 ADDI -emitPOp ANF.ADDN = emitP2 ADDI -emitPOp ANF.SUBI = emitP2 SUBI -emitPOp ANF.SUBN = emitP2 SUBI -emitPOp ANF.MULI = emitP2 MULI -emitPOp ANF.MULN = emitP2 MULI -emitPOp ANF.DIVI = emitP2 DIVI -emitPOp ANF.DIVN = emitP2 DIVN -emitPOp ANF.MODI = emitP2 MODI -- TODO: think about how these behave -emitPOp ANF.MODN = emitP2 MODN -- TODO: think about how these behave -emitPOp ANF.POWI = emitP2 POWI -emitPOp ANF.POWN = emitP2 POWI -emitPOp ANF.SHLI = emitP2 SHLI -emitPOp ANF.SHLN = emitP2 SHLI -- Note: left shift behaves uniformly -emitPOp ANF.SHRI = emitP2 SHRI -emitPOp ANF.SHRN = emitP2 SHRN -emitPOp ANF.LEQI = emitP2 LEQI -emitPOp ANF.LEQN = emitP2 LEQN -emitPOp ANF.EQLI = emitP2 EQLI -emitPOp ANF.EQLN = emitP2 EQLI -emitPOp ANF.SGNI = emitP1 SGNI -emitPOp ANF.NEGI = emitP1 NEGI -emitPOp ANF.INCI = emitP1 INCI -emitPOp ANF.INCN = emitP1 INCI -emitPOp ANF.DECI = emitP1 DECI -emitPOp ANF.DECN = emitP1 DECI -emitPOp ANF.TZRO = emitP1 TZRO -emitPOp ANF.LZRO = emitP1 LZRO -emitPOp ANF.POPC = emitP1 POPC -emitPOp ANF.ANDN = emitP2 ANDN -emitPOp ANF.IORN = emitP2 IORN -emitPOp ANF.XORN = emitP2 XORN -emitPOp ANF.COMN = emitP1 COMN --- Float -emitPOp ANF.ADDF = emitP2 ADDF -emitPOp ANF.SUBF = emitP2 SUBF -emitPOp ANF.MULF = emitP2 MULF -emitPOp ANF.DIVF = emitP2 DIVF -emitPOp ANF.LEQF = emitP2 LEQF -emitPOp ANF.EQLF = emitP2 EQLF -emitPOp ANF.MINF = emitP2 MINF -emitPOp ANF.MAXF = emitP2 MAXF -emitPOp ANF.POWF = emitP2 POWF -emitPOp ANF.EXPF = emitP1 EXPF -emitPOp ANF.ABSF = emitP1 ABSF -emitPOp ANF.SQRT = emitP1 SQRT -emitPOp ANF.LOGF = emitP1 LOGF -emitPOp ANF.LOGB = emitP2 LOGB -emitPOp ANF.CEIL = emitP1 CEIL -emitPOp ANF.FLOR = emitP1 FLOR -emitPOp ANF.TRNF = emitP1 TRNF -emitPOp ANF.RNDF = emitP1 RNDF -emitPOp ANF.COSF = emitP1 COSF -emitPOp ANF.SINF = emitP1 SINF -emitPOp ANF.TANF = emitP1 TANF -emitPOp ANF.COSH = emitP1 COSH -emitPOp ANF.SINH = emitP1 SINH -emitPOp ANF.TANH = emitP1 TANH -emitPOp ANF.ACOS = emitP1 ACOS -emitPOp ANF.ATAN = emitP1 ATAN -emitPOp ANF.ASIN = emitP1 ASIN -emitPOp ANF.ACSH = emitP1 ACSH -emitPOp ANF.ASNH = emitP1 ASNH -emitPOp ANF.ATNH = emitP1 ATNH -emitPOp ANF.ATN2 = emitP2 ATN2 --- conversions -emitPOp ANF.ITOF = emitP1 ITOF -emitPOp ANF.NTOF = emitP1 NTOF -emitPOp ANF.ITOT = emitBP1 ITOT -emitPOp ANF.NTOT = emitBP1 NTOT -emitPOp ANF.FTOT = emitBP1 FTOT -emitPOp ANF.TTON = emitBP1 TTON -emitPOp ANF.TTOI = emitBP1 TTOI -emitPOp ANF.TTOF = emitBP1 TTOF --- text -emitPOp ANF.CATT = emitBP2 CATT -emitPOp ANF.TAKT = emitBP2 TAKT -emitPOp ANF.DRPT = emitBP2 DRPT -emitPOp ANF.IXOT = emitBP2 IXOT -emitPOp ANF.SIZT = emitBP1 SIZT -emitPOp ANF.UCNS = emitBP1 UCNS -emitPOp ANF.USNC = emitBP1 USNC -emitPOp ANF.EQLT = emitBP2 EQLT -emitPOp ANF.LEQT = emitBP2 LEQT -emitPOp ANF.PAKT = emitBP1 PAKT -emitPOp ANF.UPKT = emitBP1 UPKT --- sequence -emitPOp ANF.CATS = emitBP2 CATS -emitPOp ANF.TAKS = emitBP2 TAKS -emitPOp ANF.DRPS = emitBP2 DRPS -emitPOp ANF.SIZS = emitBP1 SIZS -emitPOp ANF.CONS = emitBP2 CONS -emitPOp ANF.SNOC = emitBP2 SNOC -emitPOp ANF.IDXS = emitBP2 IDXS -emitPOp ANF.VWLS = emitBP1 VWLS -emitPOp ANF.VWRS = emitBP1 VWRS -emitPOp ANF.SPLL = emitBP2 SPLL -emitPOp ANF.SPLR = emitBP2 SPLR --- bytes -emitPOp ANF.PAKB = emitBP1 PAKB -emitPOp ANF.UPKB = emitBP1 UPKB -emitPOp ANF.TAKB = emitBP2 TAKB -emitPOp ANF.DRPB = emitBP2 DRPB -emitPOp ANF.IXOB = emitBP2 IXOB -emitPOp ANF.IDXB = emitBP2 IDXB -emitPOp ANF.SIZB = emitBP1 SIZB -emitPOp ANF.FLTB = emitBP1 FLTB -emitPOp ANF.CATB = emitBP2 CATB --- universal comparison -emitPOp ANF.EQLU = emitBP2 EQLU -emitPOp ANF.CMPU = emitBP2 CMPU --- code operations -emitPOp ANF.MISS = emitBP1 MISS -emitPOp ANF.CACH = emitBP1 CACH -emitPOp ANF.LKUP = emitBP1 LKUP -emitPOp ANF.TLTT = emitBP1 TLTT -emitPOp ANF.CVLD = emitBP1 CVLD -emitPOp ANF.LOAD = emitBP1 LOAD -emitPOp ANF.VALU = emitBP1 VALU -emitPOp ANF.SDBX = emitBP2 SDBX -emitPOp ANF.SDBL = emitBP1 SDBL -emitPOp ANF.SDBV = emitBP2 SDBV --- error call -emitPOp ANF.EROR = emitBP2 THRO -emitPOp ANF.TRCE = emitBP2 TRCE -emitPOp ANF.DBTX = emitBP1 DBTX --- non-prim translations -emitPOp ANF.BLDS = Seq -emitPOp ANF.FORK = \case - BArg1 i -> Fork i - _ -> internalBug "fork takes exactly one boxed argument" -emitPOp ANF.ATOM = \case - BArg1 i -> Atomically i - _ -> internalBug "atomically takes exactly one boxed argument" -emitPOp ANF.PRNT = \case - BArg1 i -> Print i - _ -> internalBug "print takes exactly one boxed argument" -emitPOp ANF.INFO = \case - ZArgs -> Info "debug" - _ -> internalBug "info takes no arguments" -emitPOp ANF.TFRC = \case - BArg1 i -> TryForce i - _ -> internalBug "tryEval takes exactly one boxed argument" - --- handled in emitSection because Die is not an instruction - --- Emit machine code for ANF IO operations. These are all translated --- to 'foreing function' calls, but there is a special case for the --- standard handle access function, because it does not yield an --- explicit error. -emitFOp :: ANF.FOp -> Args -> Instr -emitFOp fop = ForeignCall True (fromIntegral $ fromEnum fop) - --- Helper functions for packing the variable argument representation --- into the indexes stored in prim op instructions -emitP1 :: UPrim1 -> Args -> Instr -emitP1 p (UArg1 i) = UPrim1 p i -emitP1 p a = - internalBug $ - "wrong number of args for unary unboxed primop: " - ++ show (p, a) - -emitP2 :: UPrim2 -> Args -> Instr -emitP2 p (UArg2 i j) = UPrim2 p i j -emitP2 p a = - internalBug $ - "wrong number of args for binary unboxed primop: " - ++ show (p, a) - -emitBP1 :: BPrim1 -> Args -> Instr -emitBP1 p (UArg1 i) = BPrim1 p i -emitBP1 p (BArg1 i) = BPrim1 p i -emitBP1 p a = - internalBug $ - "wrong number of args for unary boxed primop: " - ++ show (p, a) - -emitBP2 :: BPrim2 -> Args -> Instr -emitBP2 p (UArg2 i j) = BPrim2 p i j -emitBP2 p (BArg2 i j) = BPrim2 p i j -emitBP2 p (DArg2 i j) = BPrim2 p i j -emitBP2 p a = - internalBug $ - "wrong number of args for binary boxed primop: " - ++ show (p, a) - -emitDataMatching :: - (Var v) => - Reference -> - RefNums -> - Reference -> - Word64 -> - RCtx v -> - Ctx v -> - EnumMap CTag ([Mem], ANormal v) -> - Maybe (ANormal v) -> - Emit Branch -emitDataMatching r rns grpr grpn rec ctx cs df = - TestW <$> edf <*> traverse (emitCase rns grpr grpn rec ctx) (coerce cs) - where - -- Note: this is not really accurate. A default data case needs - -- stack space corresponding to the actual data that shows up there. - -- However, we currently don't use default cases for data. - edf - | Just co <- df = emitSection rns grpr grpn rec ctx co - | otherwise = countCtx ctx $ Die ("missing data case for hash " <> show r) - --- Emits code corresponding to an unboxed sum match. --- The match is against a tag on the stack, and cases introduce --- variables to the middle of the context, because the fields were --- already there, but it was unknown how many there were until --- branching on the tag. -emitSumMatching :: - (Var v) => - RefNums -> - Reference -> - Word64 -> - RCtx v -> - Ctx v -> - v -> - Int -> - EnumMap Word64 ([Mem], ANormal v) -> - Emit Section -emitSumMatching rns grpr grpn rec ctx v i cs = - MatchW i edf <$> traverse (emitSumCase rns grpr grpn rec ctx v) cs - where - edf = Die "uncovered unboxed sum case" - -emitRequestMatching :: - (Var v) => - RefNums -> - Reference -> - Word64 -> - RCtx v -> - Ctx v -> - EnumMap Word64 (EnumMap CTag ([Mem], ANormal v)) -> - ANormal v -> - Emit (Section, EnumMap Word64 Branch) -emitRequestMatching rns grpr grpn rec ctx hs df = (,) <$> pur <*> tops - where - pur = emitCase rns grpr grpn rec ctx ([BX], df) - tops = traverse f (coerce hs) - f cs = TestW edf <$> traverse (emitCase rns grpr grpn rec ctx) cs - edf = Die "unhandled ability" - -emitLitMatching :: - (Var v) => - (Traversable f) => - (Int -> Section -> f Section -> Section) -> - String -> - RefNums -> - Reference -> - Word64 -> - RCtx v -> - Ctx v -> - Int -> - f (ANormal v) -> - Maybe (ANormal v) -> - Emit Section -emitLitMatching con err rns grpr grpn rec ctx i cs df = - con i <$> edf <*> traverse (emitCase rns grpr grpn rec ctx . ([],)) cs - where - edf - | Just co <- df = emitSection rns grpr grpn rec ctx co - | otherwise = countCtx ctx $ Die err - -emitCase :: - (Var v) => - RefNums -> - Reference -> - Word64 -> - RCtx v -> - Ctx v -> - ([Mem], ANormal v) -> - Emit Section -emitCase rns grpr grpn rec ctx (ccs, TAbss vs bo) = - emitSection rns grpr grpn rec (pushCtx (zip vs ccs) ctx) bo - -emitSumCase :: - (Var v) => - RefNums -> - Reference -> - Word64 -> - RCtx v -> - Ctx v -> - v -> - ([Mem], ANormal v) -> - Emit Section -emitSumCase rns grpr grpn rec ctx v (ccs, TAbss vs bo) = - emitSection rns grpr grpn rec (sumCtx ctx v $ zip vs ccs) bo - -litToMLit :: ANF.Lit -> MLit -litToMLit (ANF.I i) = MI $ fromIntegral i -litToMLit (ANF.N n) = MI $ fromIntegral n -litToMLit (ANF.C c) = MI $ fromEnum c -litToMLit (ANF.F d) = MD d -litToMLit (ANF.T t) = MT t -litToMLit (ANF.LM r) = MM r -litToMLit (ANF.LY r) = MY r - -emitLit :: ANF.Lit -> Instr -emitLit = Lit . litToMLit - -doubleToInt :: Double -> Int -doubleToInt d = indexByteArray (byteArrayFromList [d]) 0 - -emitBLit :: ANF.Lit -> Instr -emitBLit l@(ANF.F d) = BLit (ANF.litRef l) (MI $ doubleToInt d) -emitBLit l = BLit (ANF.litRef l) (litToMLit l) - --- Emits some fix-up code for calling functions. Some of the --- variables in scope come from the top-level let rec, but these --- are definitions, not values on the stack. These definitions cannot --- be passed directly as function arguments, and must have a --- corresponding stack entry allocated first. So, this function inserts --- these allocations and passes the appropriate context into the --- provided continuation. -emitClosures :: - (Var v) => - Word64 -> - RCtx v -> - Ctx v -> - [v] -> - (Ctx v -> Args -> Emit Section) -> - Emit Section -emitClosures grpn rec ctx args k = - allocate ctx args $ \ctx -> k ctx $ emitArgs grpn ctx args - where - allocate ctx [] k = k ctx - allocate ctx (a : as) k - | Just _ <- ctxResolve ctx a = allocate ctx as k - | Just n <- rctxResolve rec a = - Ins (Name (Env grpn n) ZArgs) <$> allocate (Var a BX ctx) as k - | otherwise = - internalBug $ "emitClosures: unknown reference: " ++ show a - -emitArgs :: (Var v) => Word64 -> Ctx v -> [v] -> Args -emitArgs grpn ctx args - | Just l <- traverse (ctxResolve ctx) args = demuxArgs l - | otherwise = - internalBug $ - "emitArgs[" - ++ show grpn - ++ "]: " - ++ "could not resolve argument variables: " - ++ show args - --- Turns a list of stack positions and calling conventions into the --- argument format expected in the machine code. -demuxArgs :: [(Int, Mem)] -> Args -demuxArgs as0 = - case bimap (fmap fst) (fmap fst) $ partition ((== UN) . snd) as0 of - ([], []) -> ZArgs - ([], [i]) -> BArg1 i - ([], [i, j]) -> BArg2 i j - ([i], []) -> UArg1 i - ([i, j], []) -> UArg2 i j - ([i], [j]) -> DArg2 i j - ([], bs) -> BArgN $ primArrayFromList bs - (us, []) -> UArgN $ primArrayFromList us - -- TODO: handle ranges - (us, bs) -> DArgN (primArrayFromList us) (primArrayFromList bs) - -combDeps :: Comb -> [Word64] -combDeps (Lam _ _ _ _ s) = sectionDeps s - -combTypes :: Comb -> [Word64] -combTypes (Lam _ _ _ _ s) = sectionTypes s - -sectionDeps :: Section -> [Word64] -sectionDeps (App _ (Env w _) _) = [w] -sectionDeps (Call _ w _) = [w] -sectionDeps (Match _ br) = branchDeps br -sectionDeps (DMatch _ _ br) = branchDeps br -sectionDeps (RMatch _ pu br) = - sectionDeps pu ++ foldMap branchDeps br -sectionDeps (NMatch _ _ br) = branchDeps br -sectionDeps (Ins i s) - | Name (Env w _) _ <- i = w : sectionDeps s - | otherwise = sectionDeps s -sectionDeps (Let s (CIx _ w _)) = w : sectionDeps s -sectionDeps _ = [] - -sectionTypes :: Section -> [Word64] -sectionTypes (Ins i s) = instrTypes i ++ sectionTypes s -sectionTypes (Let s _) = sectionTypes s -sectionTypes (Match _ br) = branchTypes br -sectionTypes (DMatch _ _ br) = branchTypes br -sectionTypes (NMatch _ _ br) = branchTypes br -sectionTypes (RMatch _ pu br) = - sectionTypes pu ++ foldMap branchTypes br -sectionTypes _ = [] - -instrTypes :: Instr -> [Word64] -instrTypes (Pack _ w _) = [w `shiftR` 16] -instrTypes (Reset ws) = setToList ws -instrTypes (Capture w) = [w] -instrTypes (SetDyn w _) = [w] -instrTypes _ = [] - -branchDeps :: Branch -> [Word64] -branchDeps (Test1 _ s1 d) = sectionDeps s1 ++ sectionDeps d -branchDeps (Test2 _ s1 _ s2 d) = - sectionDeps s1 ++ sectionDeps s2 ++ sectionDeps d -branchDeps (TestW d m) = - sectionDeps d ++ foldMap sectionDeps m -branchDeps (TestT d m) = - sectionDeps d ++ foldMap sectionDeps m - -branchTypes :: Branch -> [Word64] -branchTypes (Test1 _ s1 d) = sectionTypes s1 ++ sectionTypes d -branchTypes (Test2 _ s1 _ s2 d) = - sectionTypes s1 ++ sectionTypes s2 ++ sectionTypes d -branchTypes (TestW d m) = - sectionTypes d ++ foldMap sectionTypes m -branchTypes (TestT d m) = - sectionTypes d ++ foldMap sectionTypes m - -indent :: Int -> ShowS -indent ind = showString (replicate (ind * 2) ' ') - -prettyCombs :: - Word64 -> - EnumMap Word64 Comb -> - ShowS -prettyCombs w es = - foldr - (\(i, c) r -> prettyComb w i c . showString "\n" . r) - id - (mapToList es) - -prettyComb :: Word64 -> Word64 -> Comb -> ShowS -prettyComb w i (Lam ua ba _ _ s) = - shows w - . showString ":" - . shows i - . shows [ua, ba] - . showString ":\n" - . prettySection 2 s - -prettySection :: Int -> Section -> ShowS -prettySection ind sec = - indent ind . case sec of - App _ r as -> - showString "App " - . showsPrec 12 r - . showString " " - . prettyArgs as - Call _ i as -> - showString "Call " . shows i . showString " " . prettyArgs as - Jump i as -> - showString "Jump " . shows i . showString " " . prettyArgs as - Match i bs -> - showString "Match " - . shows i - . showString "\n" - . prettyBranches (ind + 1) bs - Yield as -> showString "Yield " . prettyArgs as - Ins i nx -> - prettyIns i . showString "\n" . prettySection ind nx - Let s n -> - showString "Let\n" - . prettySection (ind + 2) s - . showString "\n" - . indent ind - . prettyIx n - Die s -> showString $ "Die " ++ s - Exit -> showString "Exit" - DMatch _ i bs -> - showString "DMatch " - . shows i - . showString "\n" - . prettyBranches (ind + 1) bs - NMatch _ i bs -> - showString "NMatch " - . shows i - . showString "\n" - . prettyBranches (ind + 1) bs - RMatch i pu bs -> - showString "RMatch " - . shows i - . showString "\nPUR ->\n" - . prettySection (ind + 1) pu - . foldr (\p r -> rqc p . r) id (mapToList bs) - where - rqc (i, e) = - showString "\n" - . shows i - . showString " ->\n" - . prettyBranches (ind + 1) e - -prettyIx :: CombIx -> ShowS -prettyIx (CIx _ c s) = - showString "Resume[" - . shows c - . showString "," - . shows s - . showString "]" - -prettyBranches :: Int -> Branch -> ShowS -prettyBranches ind bs = - case bs of - Test1 i e df -> pdf df . picase i e - Test2 i ei j ej df -> pdf df . picase i ei . picase j ej - TestW df m -> - pdf df . foldr (\(i, e) r -> picase i e . r) id (mapToList m) - TestT df m -> - pdf df . foldr (\(i, e) r -> ptcase i e . r) id (M.toList m) - where - pdf e = indent ind . showString "DFLT ->\n" . prettySection (ind + 1) e - ptcase t e = - showString "\n" - . indent ind - . shows t - . showString " ->\n" - . prettySection (ind + 1) e - picase i e = - showString "\n" - . indent ind - . shows i - . showString " ->\n" - . prettySection (ind + 1) e - -un :: ShowS -un = ('U' :) - -bx :: ShowS -bx = ('B' :) - -prettyIns :: Instr -> ShowS -prettyIns (Pack r i as) = - showString "Pack " - . showsPrec 10 r - . (' ' :) - . shows i - . (' ' :) - . prettyArgs as -prettyIns i = shows i - -prettyArgs :: Args -> ShowS -prettyArgs ZArgs = shows @[Int] [] -prettyArgs (UArg1 i) = un . shows [i] -prettyArgs (BArg1 i) = bx . shows [i] -prettyArgs (UArg2 i j) = un . shows [i, j] -prettyArgs (BArg2 i j) = bx . shows [i, j] -prettyArgs (DArg2 i j) = un . shows [i] . (' ' :) . bx . shows [j] -prettyArgs (UArgR i l) = un . shows (Prelude.take l [i ..]) -prettyArgs (BArgR i l) = bx . shows (Prelude.take l [i ..]) -prettyArgs (DArgR i l j k) = - un - . shows (Prelude.take l [i ..]) - . (' ' :) - . bx - . shows (Prelude.take k [j ..]) -prettyArgs (UArgN v) = un . shows (primArrayToList v) -prettyArgs (BArgN v) = bx . shows (primArrayToList v) -prettyArgs (DArgN u b) = - un - . shows (primArrayToList u) - . (' ' :) - . bx - . shows (primArrayToList b) -prettyArgs (DArgV i j) = ('V' :) . shows [i, j] diff --git a/parser-typechecker/src/Unison/Runtime/MCode/Serialize.hs b/parser-typechecker/src/Unison/Runtime/MCode/Serialize.hs deleted file mode 100644 index 2d1cabf8d3..0000000000 --- a/parser-typechecker/src/Unison/Runtime/MCode/Serialize.hs +++ /dev/null @@ -1,443 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} - -module Unison.Runtime.MCode.Serialize - ( putComb, - getComb, - ) -where - -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Bytes.VarInt -import Data.Primitive.PrimArray -import Data.Word (Word64) -import GHC.Exts (IsList (..)) -import Unison.Runtime.MCode hiding (MatchT) -import Unison.Runtime.Serialize -import Unison.Util.Text qualified as Util.Text - -putComb :: (MonadPut m) => Comb -> m () -putComb (Lam ua ba uf bf body) = - pInt ua *> pInt ba *> pInt uf *> pInt bf *> putSection body - -getComb :: (MonadGet m) => m Comb -getComb = Lam <$> gInt <*> gInt <*> gInt <*> gInt <*> getSection - -data SectionT - = AppT - | CallT - | JumpT - | MatchT - | YieldT - | InsT - | LetT - | DieT - | ExitT - | DMatchT - | NMatchT - | RMatchT - -instance Tag SectionT where - tag2word AppT = 0 - tag2word CallT = 1 - tag2word JumpT = 2 - tag2word MatchT = 3 - tag2word YieldT = 4 - tag2word InsT = 5 - tag2word LetT = 6 - tag2word DieT = 7 - tag2word ExitT = 8 - tag2word DMatchT = 9 - tag2word NMatchT = 10 - tag2word RMatchT = 11 - - word2tag 0 = pure AppT - word2tag 1 = pure CallT - word2tag 2 = pure JumpT - word2tag 3 = pure MatchT - word2tag 4 = pure YieldT - word2tag 5 = pure InsT - word2tag 6 = pure LetT - word2tag 7 = pure DieT - word2tag 8 = pure ExitT - word2tag 9 = pure DMatchT - word2tag 10 = pure NMatchT - word2tag 11 = pure RMatchT - word2tag i = unknownTag "SectionT" i - -putSection :: (MonadPut m) => Section -> m () -putSection (App b r a) = - putTag AppT *> serialize b *> putRef r *> putArgs a -putSection (Call b w a) = - putTag CallT *> serialize b *> pWord w *> putArgs a -putSection (Jump i a) = - putTag JumpT *> pInt i *> putArgs a -putSection (Match i b) = - putTag MatchT *> pInt i *> putBranch b -putSection (Yield a) = - putTag YieldT *> putArgs a -putSection (Ins i s) = - putTag InsT *> putInstr i *> putSection s -putSection (Let s ci) = - putTag LetT *> putSection s *> putCombIx ci -putSection (Die s) = - putTag DieT *> serialize s -putSection Exit = - putTag ExitT -putSection (DMatch mr i b) = - putTag DMatchT *> putMaybe mr putReference *> pInt i *> putBranch b -putSection (NMatch mr i b) = - putTag NMatchT *> putMaybe mr putReference *> pInt i *> putBranch b -putSection (RMatch i pu bs) = - putTag RMatchT - *> pInt i - *> putSection pu - *> putEnumMap pWord putBranch bs - -getSection :: (MonadGet m) => m Section -getSection = - getTag >>= \case - AppT -> App <$> deserialize <*> getRef <*> getArgs - CallT -> Call <$> deserialize <*> gWord <*> getArgs - JumpT -> Jump <$> gInt <*> getArgs - MatchT -> Match <$> gInt <*> getBranch - YieldT -> Yield <$> getArgs - InsT -> Ins <$> getInstr <*> getSection - LetT -> Let <$> getSection <*> getCombIx - DieT -> Die <$> deserialize - ExitT -> pure Exit - DMatchT -> DMatch <$> getMaybe getReference <*> gInt <*> getBranch - NMatchT -> NMatch <$> getMaybe getReference <*> gInt <*> getBranch - RMatchT -> - RMatch <$> gInt <*> getSection <*> getEnumMap gWord getBranch - -data InstrT - = UPrim1T - | UPrim2T - | BPrim1T - | BPrim2T - | ForeignCallT - | SetDynT - | CaptureT - | NameT - | InfoT - | PackT - | UnpackT - | LitT - | PrintT - | ResetT - | ForkT - | AtomicallyT - | SeqT - | TryForceT - | BLitT - -instance Tag InstrT where - tag2word UPrim1T = 0 - tag2word UPrim2T = 1 - tag2word BPrim1T = 2 - tag2word BPrim2T = 3 - tag2word ForeignCallT = 4 - tag2word SetDynT = 5 - tag2word CaptureT = 6 - tag2word NameT = 7 - tag2word InfoT = 8 - tag2word PackT = 9 - tag2word UnpackT = 10 - tag2word LitT = 11 - tag2word PrintT = 12 - tag2word ResetT = 13 - tag2word ForkT = 14 - tag2word AtomicallyT = 15 - tag2word SeqT = 16 - tag2word TryForceT = 17 - tag2word BLitT = 18 - - word2tag 0 = pure UPrim1T - word2tag 1 = pure UPrim2T - word2tag 2 = pure BPrim1T - word2tag 3 = pure BPrim2T - word2tag 4 = pure ForeignCallT - word2tag 5 = pure SetDynT - word2tag 6 = pure CaptureT - word2tag 7 = pure NameT - word2tag 8 = pure InfoT - word2tag 9 = pure PackT - word2tag 10 = pure UnpackT - word2tag 11 = pure LitT - word2tag 12 = pure PrintT - word2tag 13 = pure ResetT - word2tag 14 = pure ForkT - word2tag 15 = pure AtomicallyT - word2tag 16 = pure SeqT - word2tag 17 = pure TryForceT - word2tag 18 = pure BLitT - word2tag n = unknownTag "InstrT" n - -putInstr :: (MonadPut m) => Instr -> m () -putInstr (UPrim1 up i) = - putTag UPrim1T *> putTag up *> pInt i -putInstr (UPrim2 up i j) = - putTag UPrim2T *> putTag up *> pInt i *> pInt j -putInstr (BPrim1 bp i) = - putTag BPrim1T *> putTag bp *> pInt i -putInstr (BPrim2 bp i j) = - putTag BPrim2T *> putTag bp *> pInt i *> pInt j -putInstr (ForeignCall b w a) = - putTag ForeignCallT *> serialize b *> pWord w *> putArgs a -putInstr (SetDyn w i) = - putTag SetDynT *> pWord w *> pInt i -putInstr (Capture w) = - putTag CaptureT *> pWord w -putInstr (Name r a) = - putTag NameT *> putRef r *> putArgs a -putInstr (Info s) = - putTag InfoT *> serialize s -putInstr (Pack r w a) = - putTag PackT *> putReference r *> pWord w *> putArgs a -putInstr (Unpack mr i) = - putTag UnpackT *> putMaybe mr putReference *> pInt i -putInstr (Lit l) = - putTag LitT *> putLit l -putInstr (BLit r l) = - putTag BLitT *> putReference r *> putLit l -putInstr (Print i) = - putTag PrintT *> pInt i -putInstr (Reset s) = - putTag ResetT *> putEnumSet pWord s -putInstr (Fork i) = - putTag ForkT *> pInt i -putInstr (Atomically i) = - putTag AtomicallyT *> pInt i -putInstr (Seq a) = - putTag SeqT *> putArgs a -putInstr (TryForce i) = - putTag TryForceT *> pInt i - -getInstr :: (MonadGet m) => m Instr -getInstr = - getTag >>= \case - UPrim1T -> UPrim1 <$> getTag <*> gInt - UPrim2T -> UPrim2 <$> getTag <*> gInt <*> gInt - BPrim1T -> BPrim1 <$> getTag <*> gInt - BPrim2T -> BPrim2 <$> getTag <*> gInt <*> gInt - ForeignCallT -> ForeignCall <$> deserialize <*> gWord <*> getArgs - SetDynT -> SetDyn <$> gWord <*> gInt - CaptureT -> Capture <$> gWord - NameT -> Name <$> getRef <*> getArgs - InfoT -> Info <$> deserialize - PackT -> Pack <$> getReference <*> gWord <*> getArgs - UnpackT -> Unpack <$> getMaybe getReference <*> gInt - LitT -> Lit <$> getLit - BLitT -> BLit <$> getReference <*> getLit - PrintT -> Print <$> gInt - ResetT -> Reset <$> getEnumSet gWord - ForkT -> Fork <$> gInt - AtomicallyT -> Atomically <$> gInt - SeqT -> Seq <$> getArgs - TryForceT -> TryForce <$> gInt - -data ArgsT - = ZArgsT - | UArg1T - | UArg2T - | BArg1T - | BArg2T - | DArg2T - | UArgRT - | BArgRT - | DArgRT - | BArgNT - | UArgNT - | DArgNT - | DArgVT - -instance Tag ArgsT where - tag2word ZArgsT = 0 - tag2word UArg1T = 1 - tag2word UArg2T = 2 - tag2word BArg1T = 3 - tag2word BArg2T = 4 - tag2word DArg2T = 5 - tag2word UArgRT = 6 - tag2word BArgRT = 7 - tag2word DArgRT = 8 - tag2word BArgNT = 9 - tag2word UArgNT = 10 - tag2word DArgNT = 11 - tag2word DArgVT = 12 - - word2tag 0 = pure ZArgsT - word2tag 1 = pure UArg1T - word2tag 2 = pure UArg2T - word2tag 3 = pure BArg1T - word2tag 4 = pure BArg2T - word2tag 5 = pure DArg2T - word2tag 6 = pure UArgRT - word2tag 7 = pure BArgRT - word2tag 8 = pure DArgRT - word2tag 9 = pure BArgNT - word2tag 10 = pure UArgNT - word2tag 11 = pure DArgNT - word2tag 12 = pure DArgVT - word2tag n = unknownTag "ArgsT" n - -putArgs :: (MonadPut m) => Args -> m () -putArgs ZArgs = putTag ZArgsT -putArgs (UArg1 i) = putTag UArg1T *> pInt i -putArgs (UArg2 i j) = putTag UArg1T *> pInt i *> pInt j -putArgs (BArg1 i) = putTag BArg1T *> pInt i -putArgs (BArg2 i j) = putTag BArg2T *> pInt i *> pInt j -putArgs (DArg2 i j) = putTag DArg2T *> pInt i *> pInt j -putArgs (UArgR i j) = putTag UArgRT *> pInt i *> pInt j -putArgs (BArgR i j) = putTag BArgRT *> pInt i *> pInt j -putArgs (DArgR i j k l) = - putTag DArgRT *> pInt i *> pInt j *> pInt k *> pInt l -putArgs (BArgN pa) = putTag BArgNT *> putIntArr pa -putArgs (UArgN pa) = putTag UArgNT *> putIntArr pa -putArgs (DArgN ua ba) = - putTag DArgNT *> putIntArr ua *> putIntArr ba -putArgs (DArgV i j) = putTag DArgVT *> pInt i *> pInt j - -getArgs :: (MonadGet m) => m Args -getArgs = - getTag >>= \case - ZArgsT -> pure ZArgs - UArg1T -> UArg1 <$> gInt - UArg2T -> UArg2 <$> gInt <*> gInt - BArg1T -> BArg1 <$> gInt - BArg2T -> BArg2 <$> gInt <*> gInt - DArg2T -> DArg2 <$> gInt <*> gInt - UArgRT -> UArgR <$> gInt <*> gInt - BArgRT -> BArgR <$> gInt <*> gInt - DArgRT -> DArgR <$> gInt <*> gInt <*> gInt <*> gInt - BArgNT -> BArgN <$> getIntArr - UArgNT -> UArgN <$> getIntArr - DArgNT -> DArgN <$> getIntArr <*> getIntArr - DArgVT -> DArgV <$> gInt <*> gInt - -data RefT = StkT | EnvT | DynT - -instance Tag RefT where - tag2word StkT = 0 - tag2word EnvT = 1 - tag2word DynT = 2 - - word2tag 0 = pure StkT - word2tag 1 = pure EnvT - word2tag 2 = pure DynT - word2tag n = unknownTag "RefT" n - -putRef :: (MonadPut m) => Ref -> m () -putRef (Stk i) = putTag StkT *> pInt i -putRef (Env i j) = putTag EnvT *> pWord i *> pWord j -putRef (Dyn i) = putTag DynT *> pWord i - -getRef :: (MonadGet m) => m Ref -getRef = - getTag >>= \case - StkT -> Stk <$> gInt - EnvT -> Env <$> gWord <*> gWord - DynT -> Dyn <$> gWord - -putCombIx :: (MonadPut m) => CombIx -> m () -putCombIx (CIx r n i) = putReference r *> pWord n *> pWord i - -getCombIx :: (MonadGet m) => m CombIx -getCombIx = CIx <$> getReference <*> gWord <*> gWord - -data MLitT = MIT | MDT | MTT | MMT | MYT - -instance Tag MLitT where - tag2word MIT = 0 - tag2word MDT = 1 - tag2word MTT = 2 - tag2word MMT = 3 - tag2word MYT = 4 - - word2tag 0 = pure MIT - word2tag 1 = pure MDT - word2tag 2 = pure MTT - word2tag 3 = pure MMT - word2tag 4 = pure MYT - word2tag n = unknownTag "MLitT" n - -putLit :: (MonadPut m) => MLit -> m () -putLit (MI i) = putTag MIT *> pInt i -putLit (MD d) = putTag MDT *> putFloat d -putLit (MT t) = putTag MTT *> putText (Util.Text.toText t) -putLit (MM r) = putTag MMT *> putReferent r -putLit (MY r) = putTag MYT *> putReference r - -getLit :: (MonadGet m) => m MLit -getLit = - getTag >>= \case - MIT -> MI <$> gInt - MDT -> MD <$> getFloat - MTT -> MT . Util.Text.fromText <$> getText - MMT -> MM <$> getReferent - MYT -> MY <$> getReference - -data BranchT = Test1T | Test2T | TestWT | TestTT - -instance Tag BranchT where - tag2word Test1T = 0 - tag2word Test2T = 1 - tag2word TestWT = 2 - tag2word TestTT = 3 - - word2tag 0 = pure Test1T - word2tag 1 = pure Test2T - word2tag 2 = pure TestWT - word2tag 3 = pure TestTT - word2tag n = unknownTag "BranchT" n - -putBranch :: (MonadPut m) => Branch -> m () -putBranch (Test1 w s d) = - putTag Test1T *> pWord w *> putSection s *> putSection d -putBranch (Test2 a sa b sb d) = - putTag Test2T - *> pWord a - *> putSection sa - *> pWord b - *> putSection sb - *> putSection d -putBranch (TestW d m) = - putTag TestWT *> putSection d *> putEnumMap pWord putSection m -putBranch (TestT d m) = - putTag TestTT *> putSection d *> putMap (putText . Util.Text.toText) putSection m - -getBranch :: (MonadGet m) => m Branch -getBranch = - getTag >>= \case - Test1T -> Test1 <$> gWord <*> getSection <*> getSection - Test2T -> - Test2 - <$> gWord - <*> getSection - <*> gWord - <*> getSection - <*> getSection - TestWT -> TestW <$> getSection <*> getEnumMap gWord getSection - TestTT -> TestT <$> getSection <*> getMap (Util.Text.fromText <$> getText) getSection - -gInt :: (MonadGet m) => m Int -gInt = unVarInt <$> deserialize - -pInt :: (MonadPut m) => Int -> m () -pInt i = serialize (VarInt i) - -gWord :: (MonadGet m) => m Word64 -gWord = unVarInt <$> deserialize - -pWord :: (MonadPut m) => Word64 -> m () -pWord w = serialize (VarInt w) - -putIntArr :: (MonadPut m) => PrimArray Int -> m () -putIntArr pa = putFoldable pInt $ toList pa - -getIntArr :: (MonadGet m) => m (PrimArray Int) -getIntArr = fromList <$> getList gInt diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs deleted file mode 100644 index 473fdb34a0..0000000000 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ /dev/null @@ -1,2502 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} --- TODO: Fix up all the uni-patterns -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Unison.Runtime.Machine where - -import Control.Concurrent (ThreadId) -import Control.Concurrent.STM as STM -import Control.Exception -import Data.Bits -import Data.Map.Strict qualified as M -import Data.Ord (comparing) -import Data.Primitive.ByteArray qualified as BA -import Data.Sequence qualified as Sq -import Data.Set qualified as S -import Data.Set qualified as Set -import Data.Text qualified as DTx -import Data.Text.IO qualified as Tx -import Data.Traversable -import GHC.Conc as STM (unsafeIOToSTM) -import GHC.Stack -import Unison.Builtin.Decls (exceptionRef, ioFailureRef) -import Unison.Builtin.Decls qualified as Rf -import Unison.ConstructorReference qualified as CR -import Unison.Prelude hiding (Text) -import Unison.Reference - ( Reference, - Reference' (Builtin), - isBuiltin, - toShortHash, - ) -import Unison.Referent (Referent, pattern Con, pattern Ref) -import Unison.Runtime.ANF as ANF - ( CompileExn (..), - Mem (..), - SuperGroup, - foldGroupLinks, - maskTags, - packTags, - valueLinks, - ) -import Unison.Runtime.ANF qualified as ANF -import Unison.Runtime.Array as PA -import Unison.Runtime.Builtin -import Unison.Runtime.Exception -import Unison.Runtime.Foreign -import Unison.Runtime.Foreign.Function -import Unison.Runtime.MCode -import Unison.Runtime.Stack -import Unison.ShortHash qualified as SH -import Unison.Symbol (Symbol) -import Unison.Type qualified as Rf -import Unison.Util.Bytes qualified as By -import Unison.Util.EnumContainers as EC -import Unison.Util.Pretty (toPlainUnbroken) -import Unison.Util.Text qualified as Util.Text -import UnliftIO (IORef) -import UnliftIO qualified -import UnliftIO.Concurrent qualified as UnliftIO - --- | A ref storing every currently active thread. --- This is helpful for cleaning up orphaned threads when the main process --- completes. We track threads when running in a host process like UCM, --- otherwise we don't bother since forked threads are cleaned up automatically on --- termination. -type ActiveThreads = Maybe (IORef (Set ThreadId)) - -type Tag = Word64 - --- dynamic environment -type DEnv = EnumMap Word64 Closure - -data Tracer - = NoTrace - | MsgTrace String String String - | SimpleTrace String - --- code caching environment -data CCache = CCache - { foreignFuncs :: EnumMap Word64 ForeignFunc, - sandboxed :: Bool, - tracer :: Bool -> Closure -> Tracer, - combs :: TVar (EnumMap Word64 Combs), - combRefs :: TVar (EnumMap Word64 Reference), - tagRefs :: TVar (EnumMap Word64 Reference), - freshTm :: TVar Word64, - freshTy :: TVar Word64, - intermed :: TVar (M.Map Reference (SuperGroup Symbol)), - refTm :: TVar (M.Map Reference Word64), - refTy :: TVar (M.Map Reference Word64), - sandbox :: TVar (M.Map Reference (Set Reference)) - } - -refNumsTm :: CCache -> IO (M.Map Reference Word64) -refNumsTm cc = readTVarIO (refTm cc) - -refNumsTy :: CCache -> IO (M.Map Reference Word64) -refNumsTy cc = readTVarIO (refTy cc) - -refNumTm :: CCache -> Reference -> IO Word64 -refNumTm cc r = - refNumsTm cc >>= \case - (M.lookup r -> Just w) -> pure w - _ -> die $ "refNumTm: unknown reference: " ++ show r - -refNumTy :: CCache -> Reference -> IO Word64 -refNumTy cc r = - refNumsTy cc >>= \case - (M.lookup r -> Just w) -> pure w - _ -> die $ "refNumTy: unknown reference: " ++ show r - -refNumTy' :: CCache -> Reference -> IO (Maybe Word64) -refNumTy' cc r = M.lookup r <$> refNumsTy cc - -baseCCache :: Bool -> IO CCache -baseCCache sandboxed = do - CCache ffuncs sandboxed noTrace - <$> newTVarIO combs - <*> newTVarIO builtinTermBackref - <*> newTVarIO builtinTypeBackref - <*> newTVarIO ftm - <*> newTVarIO fty - <*> newTVarIO mempty - <*> newTVarIO builtinTermNumbering - <*> newTVarIO builtinTypeNumbering - <*> newTVarIO baseSandboxInfo - where - ffuncs | sandboxed = sandboxedForeigns | otherwise = builtinForeigns - noTrace _ _ = NoTrace - ftm = 1 + maximum builtinTermNumbering - fty = 1 + maximum builtinTypeNumbering - - rns = emptyRNs {dnum = refLookup "ty" builtinTypeNumbering} - - combs = - mapWithKey - (\k v -> let r = builtinTermBackref ! k in emitComb @Symbol rns r k mempty (0, v)) - numberedTermLookup - -info :: (Show a) => String -> a -> IO () -info ctx x = infos ctx (show x) - -infos :: String -> String -> IO () -infos ctx s = putStrLn $ ctx ++ ": " ++ s - -stk'info :: Stack 'BX -> IO () -stk'info s@(BS _ _ sp _) = do - let prn i - | i < 0 = return () - | otherwise = peekOff s i >>= print >> prn (i - 1) - prn sp - --- Entry point for evaluating a section -eval0 :: CCache -> ActiveThreads -> Section -> IO () -eval0 !env !activeThreads !co = do - ustk <- alloc - bstk <- alloc - (denv, k) <- - topDEnv <$> readTVarIO (refTy env) <*> readTVarIO (refTm env) - eval env denv activeThreads ustk bstk (k KE) dummyRef co - -topDEnv :: - M.Map Reference Word64 -> - M.Map Reference Word64 -> - (DEnv, K -> K) -topDEnv rfTy rfTm - | Just n <- M.lookup exceptionRef rfTy, - rcrf <- Builtin (DTx.pack "raise"), - Just j <- M.lookup rcrf rfTm = - ( EC.mapSingleton n (PAp (CIx rcrf j 0) unull bnull), - Mark 0 0 (EC.setSingleton n) mempty - ) -topDEnv _ _ = (mempty, id) - --- Entry point for evaluating a numbered combinator. --- An optional callback for the base of the stack may be supplied. --- --- This is the entry point actually used in the interactive --- environment currently. -apply0 :: - Maybe (Stack 'UN -> Stack 'BX -> IO ()) -> - CCache -> - ActiveThreads -> - Word64 -> - IO () -apply0 !callback !env !threadTracker !i = do - ustk <- alloc - bstk <- alloc - cmbrs <- readTVarIO $ combRefs env - (denv, kf) <- - topDEnv <$> readTVarIO (refTy env) <*> readTVarIO (refTm env) - r <- case EC.lookup i cmbrs of - Just r -> pure r - Nothing -> die "apply0: missing reference to entry point" - apply env denv threadTracker ustk bstk (kf k0) True ZArgs $ - PAp (CIx r i 0) unull bnull - where - k0 = maybe KE (CB . Hook) callback - --- Apply helper currently used for forking. Creates the new stacks --- necessary to evaluate a closure with the provided information. -apply1 :: - (Stack 'UN -> Stack 'BX -> IO ()) -> - CCache -> - ActiveThreads -> - Closure -> - IO () -apply1 callback env threadTracker clo = do - ustk <- alloc - bstk <- alloc - apply env mempty threadTracker ustk bstk k0 True ZArgs clo - where - k0 = CB $ Hook callback - --- Entry point for evaluating a saved continuation. --- --- The continuation must be from an evaluation context expecting a --- unit value. -jump0 :: - (Stack 'UN -> Stack 'BX -> IO ()) -> - CCache -> - ActiveThreads -> - Closure -> - IO () -jump0 !callback !env !activeThreads !clo = do - ustk <- alloc - bstk <- alloc - (denv, kf) <- - topDEnv <$> readTVarIO (refTy env) <*> readTVarIO (refTm env) - bstk <- bump bstk - poke bstk (Enum Rf.unitRef unitTag) - jump env denv activeThreads ustk bstk (kf k0) (BArg1 0) clo - where - k0 = CB (Hook callback) - -unitValue :: Closure -unitValue = Enum Rf.unitRef unitTag - -lookupDenv :: Word64 -> DEnv -> Closure -lookupDenv p denv = fromMaybe BlackHole $ EC.lookup p denv - -buildLit :: Reference -> MLit -> Closure -buildLit rf (MI i) - | Just n <- M.lookup rf builtinTypeNumbering, - rt <- toEnum (fromIntegral n) = - DataU1 rf (packTags rt 0) i - | otherwise = error "buildLit: unknown reference" -buildLit _ (MT t) = Foreign (Wrap Rf.textRef t) -buildLit _ (MM r) = Foreign (Wrap Rf.termLinkRef r) -buildLit _ (MY r) = Foreign (Wrap Rf.typeLinkRef r) -buildLit _ (MD _) = error "buildLit: double" - -exec :: - CCache -> - DEnv -> - ActiveThreads -> - Stack 'UN -> - Stack 'BX -> - K -> - Reference -> - Instr -> - IO (DEnv, Stack 'UN, Stack 'BX, K) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (Info tx) = do - info tx ustk - info tx bstk - info tx k - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k _ (Name r args) = do - bstk <- name ustk bstk args =<< resolve env denv bstk r - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (SetDyn p i) = do - clo <- peekOff bstk i - pure (EC.mapInsert p clo denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (Capture p) = do - (cap, denv, ustk, bstk, k) <- splitCont denv ustk bstk k p - bstk <- bump bstk - poke bstk cap - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (UPrim1 op i) = do - ustk <- uprim1 ustk op i - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (UPrim2 op i j) = do - ustk <- uprim2 ustk op i j - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 MISS i) - | sandboxed env = die "attempted to use sandboxed operation: isMissing" - | otherwise = do - clink <- peekOff bstk i - let Ref link = unwrapForeign $ marshalToForeign clink - m <- readTVarIO (intermed env) - ustk <- bump ustk - if (link `M.member` m) then poke ustk 1 else poke ustk 0 - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 CACH i) - | sandboxed env = die "attempted to use sandboxed operation: cache" - | otherwise = do - arg <- peekOffS bstk i - news <- decodeCacheArgument arg - unknown <- cacheAdd news env - bstk <- bump bstk - pokeS - bstk - (Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> unknown) - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 CVLD i) - | sandboxed env = die "attempted to use sandboxed operation: validate" - | otherwise = do - arg <- peekOffS bstk i - news <- decodeCacheArgument arg - codeValidate news env >>= \case - Nothing -> do - ustk <- bump ustk - poke ustk 0 - pure (denv, ustk, bstk, k) - Just (Failure ref msg clo) -> do - ustk <- bump ustk - bstk <- bumpn bstk 3 - poke ustk 1 - poke bstk (Foreign $ Wrap Rf.typeLinkRef ref) - pokeOffBi bstk 1 msg - pokeOff bstk 2 clo - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 LKUP i) - | sandboxed env = die "attempted to use sandboxed operation: lookup" - | otherwise = do - clink <- peekOff bstk i - let Ref link = unwrapForeign $ marshalToForeign clink - m <- readTVarIO (intermed env) - ustk <- bump ustk - bstk <- case M.lookup link m of - Nothing - | Just w <- M.lookup link builtinTermNumbering, - Just sn <- EC.lookup w numberedTermLookup -> do - poke ustk 1 - bstk <- bump bstk - bstk <$ pokeBi bstk (ANF.Rec [] sn) - | otherwise -> bstk <$ poke ustk 0 - Just sg -> do - poke ustk 1 - bstk <- bump bstk - bstk <$ pokeBi bstk sg - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (BPrim1 TLTT i) = do - clink <- peekOff bstk i - let shortHash = case unwrapForeign $ marshalToForeign clink of - Ref r -> toShortHash r - Con r _ -> CR.toShortHash r - let sh = Util.Text.fromText . SH.toText $ shortHash - bstk <- bump bstk - pokeBi bstk sh - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 LOAD i) - | sandboxed env = die "attempted to use sandboxed operation: load" - | otherwise = do - v <- peekOffBi bstk i - ustk <- bump ustk - bstk <- bump bstk - reifyValue env v >>= \case - Left miss -> do - poke ustk 0 - pokeS bstk $ - Sq.fromList $ - Foreign . Wrap Rf.termLinkRef . Ref <$> miss - Right x -> do - poke ustk 1 - poke bstk x - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 VALU i) = do - m <- readTVarIO (tagRefs env) - c <- peekOff bstk i - bstk <- bump bstk - pokeBi bstk =<< reflectValue m c - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 DBTX i) - | sandboxed env = - die "attempted to use sandboxed operation: Debug.toText" - | otherwise = do - clo <- peekOff bstk i - ustk <- bump ustk - bstk <- case tracer env False clo of - NoTrace -> bstk <$ poke ustk 0 - MsgTrace _ tx _ -> do - poke ustk 1 - bstk <- bump bstk - bstk <$ pokeBi bstk (Util.Text.pack tx) - SimpleTrace tx -> do - poke ustk 2 - bstk <- bump bstk - bstk <$ pokeBi bstk (Util.Text.pack tx) - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 SDBL i) - | sandboxed env = - die "attempted to use sandboxed operation: sandboxLinks" - | otherwise = do - tl <- peekOffBi bstk i - bstk <- bump bstk - pokeS bstk . encodeSandboxListResult =<< sandboxList env tl - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (BPrim1 op i) = do - (ustk, bstk) <- bprim1 ustk bstk op i - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim2 SDBX i j) = do - s <- peekOffS bstk i - c <- peekOff bstk j - l <- decodeSandboxArgument s - b <- checkSandboxing env l c - ustk <- bump ustk - poke ustk $ if b then 1 else 0 - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim2 SDBV i j) - | sandboxed env = - die "attempted to use sandboxed operation: Value.validateSandboxed" - | otherwise = do - s <- peekOffS bstk i - v <- peekOffBi bstk j - l <- decodeSandboxArgument s - res <- checkValueSandboxing env l v - bstk <- bump bstk - poke bstk $ encodeSandboxResult res - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (BPrim2 EQLU i j) = do - x <- peekOff bstk i - y <- peekOff bstk j - ustk <- bump ustk - poke ustk $ if universalEq (==) x y then 1 else 0 - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (BPrim2 CMPU i j) = do - x <- peekOff bstk i - y <- peekOff bstk j - ustk <- bump ustk - poke ustk . fromEnum $ universalCompare compare x y - pure (denv, ustk, bstk, k) -exec !_ !_ !_activeThreads !_ !bstk !k r (BPrim2 THRO i j) = do - name <- peekOffBi @Util.Text.Text bstk i - x <- peekOff bstk j - throwIO (BU (traceK r k) (Util.Text.toText name) x) -exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim2 TRCE i j) - | sandboxed env = die "attempted to use sandboxed operation: trace" - | otherwise = do - tx <- peekOffBi bstk i - clo <- peekOff bstk j - case tracer env True clo of - NoTrace -> pure () - SimpleTrace str -> do - putStrLn $ "trace: " ++ Util.Text.unpack tx - putStrLn str - MsgTrace msg ugl pre -> do - putStrLn $ "trace: " ++ Util.Text.unpack tx - putStrLn "" - putStrLn msg - putStrLn "\nraw structure:\n" - putStrLn ugl - putStrLn "partial decompilation:\n" - putStrLn pre - pure (denv, ustk, bstk, k) -exec !_ !denv !_trackThreads !ustk !bstk !k _ (BPrim2 op i j) = do - (ustk, bstk) <- bprim2 ustk bstk op i j - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (Pack r t args) = do - clo <- buildData ustk bstk r t args - bstk <- bump bstk - poke bstk clo - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (Unpack r i) = do - (ustk, bstk) <- dumpData r ustk bstk =<< peekOff bstk i - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (Print i) = do - t <- peekOffBi bstk i - Tx.putStrLn (Util.Text.toText t) - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MI n)) = do - ustk <- bump ustk - poke ustk n - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MD d)) = do - ustk <- bump ustk - pokeD ustk d - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MT t)) = do - bstk <- bump bstk - poke bstk (Foreign (Wrap Rf.textRef t)) - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MM r)) = do - bstk <- bump bstk - poke bstk (Foreign (Wrap Rf.termLinkRef r)) - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MY r)) = do - bstk <- bump bstk - poke bstk (Foreign (Wrap Rf.typeLinkRef r)) - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (BLit rf l) = do - bstk <- bump bstk - poke bstk $ buildLit rf l - pure (denv, ustk, bstk, k) -exec !_ !denv !_activeThreads !ustk !bstk !k _ (Reset ps) = do - (ustk, ua) <- saveArgs ustk - (bstk, ba) <- saveArgs bstk - pure (denv, ustk, bstk, Mark ua ba ps clos k) - where - clos = EC.restrictKeys denv ps -exec !_ !denv !_activeThreads !ustk !bstk !k _ (Seq as) = do - l <- closureArgs bstk as - bstk <- bump bstk - pokeS bstk $ Sq.fromList l - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k _ (ForeignCall _ w args) - | Just (FF arg res ev) <- EC.lookup w (foreignFuncs env) = - uncurry (denv,,,k) - <$> (arg ustk bstk args >>= ev >>= res ustk bstk) - | otherwise = - die $ "reference to unknown foreign function: " ++ show w -exec !env !denv !activeThreads !ustk !bstk !k _ (Fork i) - | sandboxed env = die "attempted to use sandboxed operation: fork" - | otherwise = do - tid <- forkEval env activeThreads =<< peekOff bstk i - bstk <- bump bstk - poke bstk . Foreign . Wrap Rf.threadIdRef $ tid - pure (denv, ustk, bstk, k) -exec !env !denv !activeThreads !ustk !bstk !k _ (Atomically i) - | sandboxed env = die $ "attempted to use sandboxed operation: atomically" - | otherwise = do - c <- peekOff bstk i - bstk <- bump bstk - atomicEval env activeThreads (poke bstk) c - pure (denv, ustk, bstk, k) -exec !env !denv !activeThreads !ustk !bstk !k _ (TryForce i) - | sandboxed env = die $ "attempted to use sandboxed operation: tryForce" - | otherwise = do - c <- peekOff bstk i - ustk <- bump ustk - bstk <- bump bstk - ev <- Control.Exception.try $ nestEval env activeThreads (poke bstk) c - bstk <- encodeExn ustk bstk ev - pure (denv, ustk, bstk, k) -{-# INLINE exec #-} - -encodeExn :: - Stack 'UN -> - Stack 'BX -> - Either SomeException () -> - IO (Stack 'BX) -encodeExn ustk bstk (Right _) = bstk <$ poke ustk 1 -encodeExn ustk bstk (Left exn) = do - bstk <- bumpn bstk 2 - poke ustk 0 - poke bstk $ Foreign (Wrap Rf.typeLinkRef link) - pokeOffBi bstk 1 msg - bstk <$ pokeOff bstk 2 extra - where - disp e = Util.Text.pack $ show e - (link, msg, extra) - | Just (ioe :: IOException) <- fromException exn = - (Rf.ioFailureRef, disp ioe, unitValue) - | Just re <- fromException exn = case re of - PE _stk msg -> - (Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, unitValue) - BU _ tx cl -> (Rf.runtimeFailureRef, Util.Text.fromText tx, cl) - | Just (ae :: ArithException) <- fromException exn = - (Rf.arithmeticFailureRef, disp ae, unitValue) - | Just (nae :: NestedAtomically) <- fromException exn = - (Rf.stmFailureRef, disp nae, unitValue) - | Just (be :: BlockedIndefinitelyOnSTM) <- fromException exn = - (Rf.stmFailureRef, disp be, unitValue) - | Just (be :: BlockedIndefinitelyOnMVar) <- fromException exn = - (Rf.ioFailureRef, disp be, unitValue) - | Just (ie :: AsyncException) <- fromException exn = - (Rf.threadKilledFailureRef, disp ie, unitValue) - | otherwise = (Rf.miscFailureRef, disp exn, unitValue) - -numValue :: Maybe Reference -> Closure -> IO Word64 -numValue _ (DataU1 _ _ i) = pure (fromIntegral i) -numValue mr clo = - die $ - "numValue: bad closure: " - ++ show clo - ++ maybe "" (\r -> "\nexpected type: " ++ show r) mr - -eval :: - CCache -> - DEnv -> - ActiveThreads -> - Stack 'UN -> - Stack 'BX -> - K -> - Reference -> - Section -> - IO () -eval !env !denv !activeThreads !ustk !bstk !k r (Match i (TestT df cs)) = do - t <- peekOffBi bstk i - eval env denv activeThreads ustk bstk k r $ selectTextBranch t df cs -eval !env !denv !activeThreads !ustk !bstk !k r (Match i br) = do - n <- peekOffN ustk i - eval env denv activeThreads ustk bstk k r $ selectBranch n br -eval !env !denv !activeThreads !ustk !bstk !k r (DMatch mr i br) = do - (t, ustk, bstk) <- dumpDataNoTag mr ustk bstk =<< peekOff bstk i - eval env denv activeThreads ustk bstk k r $ - selectBranch (maskTags t) br -eval !env !denv !activeThreads !ustk !bstk !k r (NMatch mr i br) = do - n <- numValue mr =<< peekOff bstk i - eval env denv activeThreads ustk bstk k r $ selectBranch n br -eval !env !denv !activeThreads !ustk !bstk !k r (RMatch i pu br) = do - (t, ustk, bstk) <- dumpDataNoTag Nothing ustk bstk =<< peekOff bstk i - if t == 0 - then eval env denv activeThreads ustk bstk k r pu - else case ANF.unpackTags t of - (ANF.rawTag -> e, ANF.rawTag -> t) - | Just ebs <- EC.lookup e br -> - eval env denv activeThreads ustk bstk k r $ selectBranch t ebs - | otherwise -> unhandledErr "eval" env e -eval !env !denv !activeThreads !ustk !bstk !k _ (Yield args) - | asize ustk + asize bstk > 0, - BArg1 i <- args = - peekOff bstk i >>= apply env denv activeThreads ustk bstk k False ZArgs - | otherwise = do - (ustk, bstk) <- moveArgs ustk bstk args - ustk <- frameArgs ustk - bstk <- frameArgs bstk - yield env denv activeThreads ustk bstk k -eval !env !denv !activeThreads !ustk !bstk !k _ (App ck r args) = - resolve env denv bstk r - >>= apply env denv activeThreads ustk bstk k ck args -eval !env !denv !activeThreads !ustk !bstk !k _ (Call ck n args) = - combSection env (CIx dummyRef n 0) - >>= enter env denv activeThreads ustk bstk k ck args -eval !env !denv !activeThreads !ustk !bstk !k _ (Jump i args) = - peekOff bstk i >>= jump env denv activeThreads ustk bstk k args -eval !env !denv !activeThreads !ustk !bstk !k r (Let nw cix) = do - (ustk, ufsz, uasz) <- saveFrame ustk - (bstk, bfsz, basz) <- saveFrame bstk - eval env denv activeThreads ustk bstk (Push ufsz bfsz uasz basz cix k) r nw -eval !env !denv !activeThreads !ustk !bstk !k r (Ins i nx) = do - (denv, ustk, bstk, k) <- exec env denv activeThreads ustk bstk k r i - eval env denv activeThreads ustk bstk k r nx -eval !_ !_ !_ !_activeThreads !_ !_ _ Exit = pure () -eval !_ !_ !_ !_activeThreads !_ !_ _ (Die s) = die s -{-# NOINLINE eval #-} - -forkEval :: CCache -> ActiveThreads -> Closure -> IO ThreadId -forkEval env activeThreads clo = - do - threadId <- - UnliftIO.forkFinally - (apply1 err env activeThreads clo) - (const cleanupThread) - trackThread threadId - pure threadId - where - err :: Stack 'UN -> Stack 'BX -> IO () - err _ _ = pure () - trackThread :: ThreadId -> IO () - trackThread threadID = do - case activeThreads of - Nothing -> pure () - Just activeThreads -> UnliftIO.atomicModifyIORef' activeThreads (\ids -> (Set.insert threadID ids, ())) - cleanupThread :: IO () - cleanupThread = do - case activeThreads of - Nothing -> pure () - Just activeThreads -> do - myThreadId <- UnliftIO.myThreadId - UnliftIO.atomicModifyIORef' activeThreads (\ids -> (Set.delete myThreadId ids, ())) -{-# INLINE forkEval #-} - -nestEval :: CCache -> ActiveThreads -> (Closure -> IO ()) -> Closure -> IO () -nestEval env activeThreads write clo = apply1 readBack env activeThreads clo - where - readBack _ bstk = peek bstk >>= write -{-# INLINE nestEval #-} - -atomicEval :: CCache -> ActiveThreads -> (Closure -> IO ()) -> Closure -> IO () -atomicEval env activeThreads write clo = - atomically . unsafeIOToSTM $ nestEval env activeThreads write clo -{-# INLINE atomicEval #-} - --- fast path application -enter :: - CCache -> - DEnv -> - ActiveThreads -> - Stack 'UN -> - Stack 'BX -> - K -> - Bool -> - Args -> - Comb -> - IO () -enter !env !denv !activeThreads !ustk !bstk !k !ck !args !comb = do - ustk <- if ck then ensure ustk uf else pure ustk - bstk <- if ck then ensure bstk bf else pure bstk - (ustk, bstk) <- moveArgs ustk bstk args - ustk <- acceptArgs ustk ua - bstk <- acceptArgs bstk ba - -- TODO: start putting references in `Call` if we ever start - -- detecting saturated calls. - eval env denv activeThreads ustk bstk k dummyRef entry - where - Lam ua ba uf bf entry = comb -{-# INLINE enter #-} - --- fast path by-name delaying -name :: Stack 'UN -> Stack 'BX -> Args -> Closure -> IO (Stack 'BX) -name !ustk !bstk !args clo = case clo of - PAp comb useg bseg -> do - (useg, bseg) <- closeArgs I ustk bstk useg bseg args - bstk <- bump bstk - poke bstk $ PAp comb useg bseg - pure bstk - _ -> die $ "naming non-function: " ++ show clo -{-# INLINE name #-} - --- slow path application -apply :: - CCache -> - DEnv -> - ActiveThreads -> - Stack 'UN -> - Stack 'BX -> - K -> - Bool -> - Args -> - Closure -> - IO () -apply !env !denv !activeThreads !ustk !bstk !k !ck !args (PAp comb useg bseg) = - combSection env comb >>= \case - Lam ua ba uf bf entry - | ck || ua <= uac && ba <= bac -> do - ustk <- ensure ustk uf - bstk <- ensure bstk bf - (ustk, bstk) <- moveArgs ustk bstk args - ustk <- dumpSeg ustk useg A - bstk <- dumpSeg bstk bseg A - ustk <- acceptArgs ustk ua - bstk <- acceptArgs bstk ba - eval env denv activeThreads ustk bstk k (combRef comb) entry - | otherwise -> do - (useg, bseg) <- closeArgs C ustk bstk useg bseg args - ustk <- discardFrame =<< frameArgs ustk - bstk <- discardFrame =<< frameArgs bstk - bstk <- bump bstk - poke bstk $ PAp comb useg bseg - yield env denv activeThreads ustk bstk k - where - uac = asize ustk + ucount args + uscount useg - bac = asize bstk + bcount args + bscount bseg -apply !env !denv !activeThreads !ustk !bstk !k !_ !args clo - | ZArgs <- args, - asize ustk == 0, - asize bstk == 0 = do - ustk <- discardFrame ustk - bstk <- discardFrame bstk - bstk <- bump bstk - poke bstk clo - yield env denv activeThreads ustk bstk k - | otherwise = die $ "applying non-function: " ++ show clo -{-# INLINE apply #-} - -jump :: - CCache -> - DEnv -> - ActiveThreads -> - Stack 'UN -> - Stack 'BX -> - K -> - Args -> - Closure -> - IO () -jump !env !denv !activeThreads !ustk !bstk !k !args clo = case clo of - Captured sk0 ua ba useg bseg -> do - let (up, bp, sk) = adjust sk0 - (useg, bseg) <- closeArgs K ustk bstk useg bseg args - ustk <- discardFrame ustk - bstk <- discardFrame bstk - ustk <- dumpSeg ustk useg $ F (ucount args) ua - bstk <- dumpSeg bstk bseg $ F (bcount args) ba - ustk <- adjustArgs ustk up - bstk <- adjustArgs bstk bp - repush env activeThreads ustk bstk denv sk k - _ -> die "jump: non-cont" - where - -- Adjusts a repushed continuation to account for pending arguments. If - -- there are any frames in the pushed continuation, the nearest one needs to - -- record the additional pending arguments. - -- - -- If the repushed continuation has no frames, then the arguments are still - -- pending, and the result stacks need to be adjusted. Hence the 3 results. - adjust (Mark ua ba rs denv k) = - (0, 0, Mark (ua + asize ustk) (ba + asize bstk) rs denv k) - adjust (Push un bn ua ba cix k) = - (0, 0, Push un bn (ua + asize ustk) (ba + asize bstk) cix k) - adjust k = (asize ustk, asize bstk, k) -{-# INLINE jump #-} - -repush :: - CCache -> - ActiveThreads -> - Stack 'UN -> - Stack 'BX -> - DEnv -> - K -> - K -> - IO () -repush !env !activeThreads !ustk !bstk = go - where - go !denv KE !k = yield env denv activeThreads ustk bstk k - go !denv (Mark ua ba ps cs sk) !k = go denv' sk $ Mark ua ba ps cs' k - where - denv' = cs <> EC.withoutKeys denv ps - cs' = EC.restrictKeys denv ps - go !denv (Push un bn ua ba nx sk) !k = - go denv sk $ Push un bn ua ba nx k - go !_ (CB _) !_ = die "repush: impossible" -{-# INLINE repush #-} - -moveArgs :: - Stack 'UN -> - Stack 'BX -> - Args -> - IO (Stack 'UN, Stack 'BX) -moveArgs !ustk !bstk ZArgs = do - ustk <- discardFrame ustk - bstk <- discardFrame bstk - pure (ustk, bstk) -moveArgs !ustk !bstk (DArgV i j) = do - ustk <- - if ul > 0 - then prepareArgs ustk (ArgR 0 ul) - else discardFrame ustk - bstk <- - if bl > 0 - then prepareArgs bstk (ArgR 0 bl) - else discardFrame bstk - pure (ustk, bstk) - where - ul = fsize ustk - i - bl = fsize bstk - j -moveArgs !ustk !bstk (UArg1 i) = do - ustk <- prepareArgs ustk (Arg1 i) - bstk <- discardFrame bstk - pure (ustk, bstk) -moveArgs !ustk !bstk (UArg2 i j) = do - ustk <- prepareArgs ustk (Arg2 i j) - bstk <- discardFrame bstk - pure (ustk, bstk) -moveArgs !ustk !bstk (UArgR i l) = do - ustk <- prepareArgs ustk (ArgR i l) - bstk <- discardFrame bstk - pure (ustk, bstk) -moveArgs !ustk !bstk (BArg1 i) = do - ustk <- discardFrame ustk - bstk <- prepareArgs bstk (Arg1 i) - pure (ustk, bstk) -moveArgs !ustk !bstk (BArg2 i j) = do - ustk <- discardFrame ustk - bstk <- prepareArgs bstk (Arg2 i j) - pure (ustk, bstk) -moveArgs !ustk !bstk (BArgR i l) = do - ustk <- discardFrame ustk - bstk <- prepareArgs bstk (ArgR i l) - pure (ustk, bstk) -moveArgs !ustk !bstk (DArg2 i j) = do - ustk <- prepareArgs ustk (Arg1 i) - bstk <- prepareArgs bstk (Arg1 j) - pure (ustk, bstk) -moveArgs !ustk !bstk (DArgR ui ul bi bl) = do - ustk <- prepareArgs ustk (ArgR ui ul) - bstk <- prepareArgs bstk (ArgR bi bl) - pure (ustk, bstk) -moveArgs !ustk !bstk (UArgN as) = do - ustk <- prepareArgs ustk (ArgN as) - bstk <- discardFrame bstk - pure (ustk, bstk) -moveArgs !ustk !bstk (BArgN as) = do - ustk <- discardFrame ustk - bstk <- prepareArgs bstk (ArgN as) - pure (ustk, bstk) -moveArgs !ustk !bstk (DArgN us bs) = do - ustk <- prepareArgs ustk (ArgN us) - bstk <- prepareArgs bstk (ArgN bs) - pure (ustk, bstk) -{-# INLINE moveArgs #-} - -closureArgs :: Stack 'BX -> Args -> IO [Closure] -closureArgs !_ ZArgs = pure [] -closureArgs !bstk (BArg1 i) = do - x <- peekOff bstk i - pure [x] -closureArgs !bstk (BArg2 i j) = do - x <- peekOff bstk i - y <- peekOff bstk j - pure [x, y] -closureArgs !bstk (BArgR i l) = - for (take l [i ..]) (peekOff bstk) -closureArgs !bstk (BArgN bs) = - for (PA.primArrayToList bs) (peekOff bstk) -closureArgs !_ _ = - error "closure arguments can only be boxed." -{-# INLINE closureArgs #-} - -buildData :: - Stack 'UN -> Stack 'BX -> Reference -> Tag -> Args -> IO Closure -buildData !_ !_ !r !t ZArgs = pure $ Enum r t -buildData !ustk !_ !r !t (UArg1 i) = do - x <- peekOff ustk i - pure $ DataU1 r t x -buildData !ustk !_ !r !t (UArg2 i j) = do - x <- peekOff ustk i - y <- peekOff ustk j - pure $ DataU2 r t x y -buildData !_ !bstk !r !t (BArg1 i) = do - x <- peekOff bstk i - pure $ DataB1 r t x -buildData !_ !bstk !r !t (BArg2 i j) = do - x <- peekOff bstk i - y <- peekOff bstk j - pure $ DataB2 r t x y -buildData !ustk !bstk !r !t (DArg2 i j) = do - x <- peekOff ustk i - y <- peekOff bstk j - pure $ DataUB r t x y -buildData !ustk !_ !r !t (UArgR i l) = do - useg <- augSeg I ustk unull (Just $ ArgR i l) - pure $ DataG r t useg bnull -buildData !_ !bstk !r !t (BArgR i l) = do - bseg <- augSeg I bstk bnull (Just $ ArgR i l) - pure $ DataG r t unull bseg -buildData !ustk !bstk !r !t (DArgR ui ul bi bl) = do - useg <- augSeg I ustk unull (Just $ ArgR ui ul) - bseg <- augSeg I bstk bnull (Just $ ArgR bi bl) - pure $ DataG r t useg bseg -buildData !ustk !_ !r !t (UArgN as) = do - useg <- augSeg I ustk unull (Just $ ArgN as) - pure $ DataG r t useg bnull -buildData !_ !bstk !r !t (BArgN as) = do - bseg <- augSeg I bstk bnull (Just $ ArgN as) - pure $ DataG r t unull bseg -buildData !ustk !bstk !r !t (DArgN us bs) = do - useg <- augSeg I ustk unull (Just $ ArgN us) - bseg <- augSeg I bstk bnull (Just $ ArgN bs) - pure $ DataG r t useg bseg -buildData !ustk !bstk !r !t (DArgV ui bi) = do - useg <- - if ul > 0 - then augSeg I ustk unull (Just $ ArgR 0 ul) - else pure unull - bseg <- - if bl > 0 - then augSeg I bstk bnull (Just $ ArgR 0 bl) - else pure bnull - pure $ DataG r t useg bseg - where - ul = fsize ustk - ui - bl = fsize bstk - bi -{-# INLINE buildData #-} - --- Dumps a data type closure to the stack without writing its tag. --- Instead, the tag is returned for direct case analysis. -dumpDataNoTag :: - Maybe Reference -> - Stack 'UN -> - Stack 'BX -> - Closure -> - IO (Word64, Stack 'UN, Stack 'BX) -dumpDataNoTag !_ !ustk !bstk (Enum _ t) = pure (t, ustk, bstk) -dumpDataNoTag !_ !ustk !bstk (DataU1 _ t x) = do - ustk <- bump ustk - poke ustk x - pure (t, ustk, bstk) -dumpDataNoTag !_ !ustk !bstk (DataU2 _ t x y) = do - ustk <- bumpn ustk 2 - pokeOff ustk 1 y - poke ustk x - pure (t, ustk, bstk) -dumpDataNoTag !_ !ustk !bstk (DataB1 _ t x) = do - bstk <- bump bstk - poke bstk x - pure (t, ustk, bstk) -dumpDataNoTag !_ !ustk !bstk (DataB2 _ t x y) = do - bstk <- bumpn bstk 2 - pokeOff bstk 1 y - poke bstk x - pure (t, ustk, bstk) -dumpDataNoTag !_ !ustk !bstk (DataUB _ t x y) = do - ustk <- bump ustk - bstk <- bump bstk - poke ustk x - poke bstk y - pure (t, ustk, bstk) -dumpDataNoTag !_ !ustk !bstk (DataG _ t us bs) = do - ustk <- dumpSeg ustk us S - bstk <- dumpSeg bstk bs S - pure (t, ustk, bstk) -dumpDataNoTag !mr !_ !_ clo = - die $ - "dumpDataNoTag: bad closure: " - ++ show clo - ++ maybe "" (\r -> "\nexpected type: " ++ show r) mr -{-# INLINE dumpDataNoTag #-} - -dumpData :: - Maybe Reference -> - Stack 'UN -> - Stack 'BX -> - Closure -> - IO (Stack 'UN, Stack 'BX) -dumpData !_ !ustk !bstk (Enum _ t) = do - ustk <- bump ustk - pokeN ustk $ maskTags t - pure (ustk, bstk) -dumpData !_ !ustk !bstk (DataU1 _ t x) = do - ustk <- bumpn ustk 2 - pokeOff ustk 1 x - pokeN ustk $ maskTags t - pure (ustk, bstk) -dumpData !_ !ustk !bstk (DataU2 _ t x y) = do - ustk <- bumpn ustk 3 - pokeOff ustk 2 y - pokeOff ustk 1 x - pokeN ustk $ maskTags t - pure (ustk, bstk) -dumpData !_ !ustk !bstk (DataB1 _ t x) = do - ustk <- bump ustk - bstk <- bump bstk - poke bstk x - pokeN ustk $ maskTags t - pure (ustk, bstk) -dumpData !_ !ustk !bstk (DataB2 _ t x y) = do - ustk <- bump ustk - bstk <- bumpn bstk 2 - pokeOff bstk 1 y - poke bstk x - pokeN ustk $ maskTags t - pure (ustk, bstk) -dumpData !_ !ustk !bstk (DataUB _ t x y) = do - ustk <- bumpn ustk 2 - bstk <- bump bstk - pokeOff ustk 1 x - poke bstk y - pokeN ustk $ maskTags t - pure (ustk, bstk) -dumpData !_ !ustk !bstk (DataG _ t us bs) = do - ustk <- dumpSeg ustk us S - bstk <- dumpSeg bstk bs S - ustk <- bump ustk - pokeN ustk $ maskTags t - pure (ustk, bstk) -dumpData !mr !_ !_ clo = - die $ - "dumpData: bad closure: " - ++ show clo - ++ maybe "" (\r -> "\nexpected type: " ++ show r) mr -{-# INLINE dumpData #-} - --- Note: although the representation allows it, it is impossible --- to under-apply one sort of argument while over-applying the --- other. Thus, it is unnecessary to worry about doing tricks to --- only grab a certain number of arguments. -closeArgs :: - Augment -> - Stack 'UN -> - Stack 'BX -> - Seg 'UN -> - Seg 'BX -> - Args -> - IO (Seg 'UN, Seg 'BX) -closeArgs mode !ustk !bstk !useg !bseg args = - (,) - <$> augSeg mode ustk useg uargs - <*> augSeg mode bstk bseg bargs - where - (uargs, bargs) = case args of - ZArgs -> (Nothing, Nothing) - UArg1 i -> (Just $ Arg1 i, Nothing) - BArg1 i -> (Nothing, Just $ Arg1 i) - UArg2 i j -> (Just $ Arg2 i j, Nothing) - BArg2 i j -> (Nothing, Just $ Arg2 i j) - UArgR i l -> (Just $ ArgR i l, Nothing) - BArgR i l -> (Nothing, Just $ ArgR i l) - DArg2 i j -> (Just $ Arg1 i, Just $ Arg1 j) - DArgR ui ul bi bl -> (Just $ ArgR ui ul, Just $ ArgR bi bl) - UArgN as -> (Just $ ArgN as, Nothing) - BArgN as -> (Nothing, Just $ ArgN as) - DArgN us bs -> (Just $ ArgN us, Just $ ArgN bs) - DArgV ui bi -> (ua, ba) - where - ua - | ul > 0 = Just $ ArgR 0 ul - | otherwise = Nothing - ba - | bl > 0 = Just $ ArgR 0 bl - | otherwise = Nothing - ul = fsize ustk - ui - bl = fsize bstk - bi - -peekForeign :: Stack 'BX -> Int -> IO a -peekForeign bstk i = - peekOff bstk i >>= \case - Foreign x -> pure $ unwrapForeign x - _ -> die "bad foreign argument" -{-# INLINE peekForeign #-} - -uprim1 :: Stack 'UN -> UPrim1 -> Int -> IO (Stack 'UN) -uprim1 !ustk DECI !i = do - m <- peekOff ustk i - ustk <- bump ustk - poke ustk (m - 1) - pure ustk -uprim1 !ustk INCI !i = do - m <- peekOff ustk i - ustk <- bump ustk - poke ustk (m + 1) - pure ustk -uprim1 !ustk NEGI !i = do - m <- peekOff ustk i - ustk <- bump ustk - poke ustk (-m) - pure ustk -uprim1 !ustk SGNI !i = do - m <- peekOff ustk i - ustk <- bump ustk - poke ustk (signum m) - pure ustk -uprim1 !ustk ABSF !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (abs d) - pure ustk -uprim1 !ustk CEIL !i = do - d <- peekOffD ustk i - ustk <- bump ustk - poke ustk (ceiling d) - pure ustk -uprim1 !ustk FLOR !i = do - d <- peekOffD ustk i - ustk <- bump ustk - poke ustk (floor d) - pure ustk -uprim1 !ustk TRNF !i = do - d <- peekOffD ustk i - ustk <- bump ustk - poke ustk (truncate d) - pure ustk -uprim1 !ustk RNDF !i = do - d <- peekOffD ustk i - ustk <- bump ustk - poke ustk (round d) - pure ustk -uprim1 !ustk EXPF !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (exp d) - pure ustk -uprim1 !ustk LOGF !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (log d) - pure ustk -uprim1 !ustk SQRT !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (sqrt d) - pure ustk -uprim1 !ustk COSF !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (cos d) - pure ustk -uprim1 !ustk SINF !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (sin d) - pure ustk -uprim1 !ustk TANF !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (tan d) - pure ustk -uprim1 !ustk COSH !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (cosh d) - pure ustk -uprim1 !ustk SINH !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (sinh d) - pure ustk -uprim1 !ustk TANH !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (tanh d) - pure ustk -uprim1 !ustk ACOS !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (acos d) - pure ustk -uprim1 !ustk ASIN !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (asin d) - pure ustk -uprim1 !ustk ATAN !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (atan d) - pure ustk -uprim1 !ustk ASNH !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (asinh d) - pure ustk -uprim1 !ustk ACSH !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (acosh d) - pure ustk -uprim1 !ustk ATNH !i = do - d <- peekOffD ustk i - ustk <- bump ustk - pokeD ustk (atanh d) - pure ustk -uprim1 !ustk ITOF !i = do - n <- peekOff ustk i - ustk <- bump ustk - pokeD ustk (fromIntegral n) - pure ustk -uprim1 !ustk NTOF !i = do - n <- peekOffN ustk i - ustk <- bump ustk - pokeD ustk (fromIntegral n) - pure ustk -uprim1 !ustk LZRO !i = do - n <- peekOffN ustk i - ustk <- bump ustk - poke ustk (countLeadingZeros n) - pure ustk -uprim1 !ustk TZRO !i = do - n <- peekOffN ustk i - ustk <- bump ustk - poke ustk (countTrailingZeros n) - pure ustk -uprim1 !ustk POPC !i = do - n <- peekOffN ustk i - ustk <- bump ustk - poke ustk (popCount n) - pure ustk -uprim1 !ustk COMN !i = do - n <- peekOffN ustk i - ustk <- bump ustk - pokeN ustk (complement n) - pure ustk -{-# INLINE uprim1 #-} - -uprim2 :: Stack 'UN -> UPrim2 -> Int -> Int -> IO (Stack 'UN) -uprim2 !ustk ADDI !i !j = do - m <- peekOff ustk i - n <- peekOff ustk j - ustk <- bump ustk - poke ustk (m + n) - pure ustk -uprim2 !ustk SUBI !i !j = do - m <- peekOff ustk i - n <- peekOff ustk j - ustk <- bump ustk - poke ustk (m - n) - pure ustk -uprim2 !ustk MULI !i !j = do - m <- peekOff ustk i - n <- peekOff ustk j - ustk <- bump ustk - poke ustk (m * n) - pure ustk -uprim2 !ustk DIVI !i !j = do - m <- peekOff ustk i - n <- peekOff ustk j - ustk <- bump ustk - poke ustk (m `div` n) - pure ustk -uprim2 !ustk MODI !i !j = do - m <- peekOff ustk i - n <- peekOff ustk j - ustk <- bump ustk - poke ustk (m `mod` n) - pure ustk -uprim2 !ustk SHLI !i !j = do - m <- peekOff ustk i - n <- peekOff ustk j - ustk <- bump ustk - poke ustk (m `shiftL` n) - pure ustk -uprim2 !ustk SHRI !i !j = do - m <- peekOff ustk i - n <- peekOff ustk j - ustk <- bump ustk - poke ustk (m `shiftR` n) - pure ustk -uprim2 !ustk SHRN !i !j = do - m <- peekOffN ustk i - n <- peekOff ustk j - ustk <- bump ustk - pokeN ustk (m `shiftR` n) - pure ustk -uprim2 !ustk POWI !i !j = do - m <- peekOff ustk i - n <- peekOffN ustk j - ustk <- bump ustk - poke ustk (m ^ n) - pure ustk -uprim2 !ustk EQLI !i !j = do - m <- peekOff ustk i - n <- peekOff ustk j - ustk <- bump ustk - poke ustk $ if m == n then 1 else 0 - pure ustk -uprim2 !ustk LEQI !i !j = do - m <- peekOff ustk i - n <- peekOff ustk j - ustk <- bump ustk - poke ustk $ if m <= n then 1 else 0 - pure ustk -uprim2 !ustk LEQN !i !j = do - m <- peekOffN ustk i - n <- peekOffN ustk j - ustk <- bump ustk - poke ustk $ if m <= n then 1 else 0 - pure ustk -uprim2 !ustk DIVN !i !j = do - m <- peekOffN ustk i - n <- peekOffN ustk j - ustk <- bump ustk - pokeN ustk (m `div` n) - pure ustk -uprim2 !ustk MODN !i !j = do - m <- peekOffN ustk i - n <- peekOffN ustk j - ustk <- bump ustk - pokeN ustk (m `mod` n) - pure ustk -uprim2 !ustk ADDF !i !j = do - x <- peekOffD ustk i - y <- peekOffD ustk j - ustk <- bump ustk - pokeD ustk (x + y) - pure ustk -uprim2 !ustk SUBF !i !j = do - x <- peekOffD ustk i - y <- peekOffD ustk j - ustk <- bump ustk - pokeD ustk (x - y) - pure ustk -uprim2 !ustk MULF !i !j = do - x <- peekOffD ustk i - y <- peekOffD ustk j - ustk <- bump ustk - pokeD ustk (x * y) - pure ustk -uprim2 !ustk DIVF !i !j = do - x <- peekOffD ustk i - y <- peekOffD ustk j - ustk <- bump ustk - pokeD ustk (x / y) - pure ustk -uprim2 !ustk LOGB !i !j = do - x <- peekOffD ustk i - y <- peekOffD ustk j - ustk <- bump ustk - pokeD ustk (logBase x y) - pure ustk -uprim2 !ustk POWF !i !j = do - x <- peekOffD ustk i - y <- peekOffD ustk j - ustk <- bump ustk - pokeD ustk (x ** y) - pure ustk -uprim2 !ustk MAXF !i !j = do - x <- peekOffD ustk i - y <- peekOffD ustk j - ustk <- bump ustk - pokeD ustk (max x y) - pure ustk -uprim2 !ustk MINF !i !j = do - x <- peekOffD ustk i - y <- peekOffD ustk j - ustk <- bump ustk - pokeD ustk (min x y) - pure ustk -uprim2 !ustk EQLF !i !j = do - x <- peekOffD ustk i - y <- peekOffD ustk j - ustk <- bump ustk - poke ustk (if x == y then 1 else 0) - pure ustk -uprim2 !ustk LEQF !i !j = do - x <- peekOffD ustk i - y <- peekOffD ustk j - ustk <- bump ustk - poke ustk (if x <= y then 1 else 0) - pure ustk -uprim2 !ustk ATN2 !i !j = do - x <- peekOffD ustk i - y <- peekOffD ustk j - ustk <- bump ustk - pokeD ustk (atan2 x y) - pure ustk -uprim2 !ustk ANDN !i !j = do - x <- peekOffN ustk i - y <- peekOffN ustk j - ustk <- bump ustk - pokeN ustk (x .&. y) - pure ustk -uprim2 !ustk IORN !i !j = do - x <- peekOffN ustk i - y <- peekOffN ustk j - ustk <- bump ustk - pokeN ustk (x .|. y) - pure ustk -uprim2 !ustk XORN !i !j = do - x <- peekOffN ustk i - y <- peekOffN ustk j - ustk <- bump ustk - pokeN ustk (xor x y) - pure ustk -{-# INLINE uprim2 #-} - -bprim1 :: - Stack 'UN -> - Stack 'BX -> - BPrim1 -> - Int -> - IO (Stack 'UN, Stack 'BX) -bprim1 !ustk !bstk SIZT i = do - t <- peekOffBi bstk i - ustk <- bump ustk - poke ustk $ Util.Text.size t - pure (ustk, bstk) -bprim1 !ustk !bstk SIZS i = do - s <- peekOffS bstk i - ustk <- bump ustk - poke ustk $ Sq.length s - pure (ustk, bstk) -bprim1 !ustk !bstk ITOT i = do - n <- peekOff ustk i - bstk <- bump bstk - pokeBi bstk . Util.Text.pack $ show n - pure (ustk, bstk) -bprim1 !ustk !bstk NTOT i = do - n <- peekOffN ustk i - bstk <- bump bstk - pokeBi bstk . Util.Text.pack $ show n - pure (ustk, bstk) -bprim1 !ustk !bstk FTOT i = do - f <- peekOffD ustk i - bstk <- bump bstk - pokeBi bstk . Util.Text.pack $ show f - pure (ustk, bstk) -bprim1 !ustk !bstk USNC i = - peekOffBi bstk i >>= \t -> case Util.Text.unsnoc t of - Nothing -> do - ustk <- bump ustk - poke ustk 0 - pure (ustk, bstk) - Just (t, c) -> do - ustk <- bumpn ustk 2 - bstk <- bump bstk - pokeOff ustk 1 $ fromEnum c - poke ustk 1 - pokeBi bstk t - pure (ustk, bstk) -bprim1 !ustk !bstk UCNS i = - peekOffBi bstk i >>= \t -> case Util.Text.uncons t of - Nothing -> do - ustk <- bump ustk - poke ustk 0 - pure (ustk, bstk) - Just (c, t) -> do - ustk <- bumpn ustk 2 - bstk <- bump bstk - pokeOff ustk 1 $ fromEnum c - poke ustk 1 - pokeBi bstk t - pure (ustk, bstk) -bprim1 !ustk !bstk TTOI i = - peekOffBi bstk i >>= \t -> case readm $ Util.Text.unpack t of - Just n - | fromIntegral (minBound :: Int) <= n, - n <= fromIntegral (maxBound :: Int) -> do - ustk <- bumpn ustk 2 - poke ustk 1 - pokeOff ustk 1 (fromInteger n) - pure (ustk, bstk) - _ -> do - ustk <- bump ustk - poke ustk 0 - pure (ustk, bstk) - where - readm ('+' : s) = readMaybe s - readm s = readMaybe s -bprim1 !ustk !bstk TTON i = - peekOffBi bstk i >>= \t -> case readMaybe $ Util.Text.unpack t of - Just n - | 0 <= n, - n <= fromIntegral (maxBound :: Word) -> do - ustk <- bumpn ustk 2 - poke ustk 1 - pokeOffN ustk 1 (fromInteger n) - pure (ustk, bstk) - _ -> do - ustk <- bump ustk - poke ustk 0 - pure (ustk, bstk) -bprim1 !ustk !bstk TTOF i = - peekOffBi bstk i >>= \t -> case readMaybe $ Util.Text.unpack t of - Nothing -> do - ustk <- bump ustk - poke ustk 0 - pure (ustk, bstk) - Just f -> do - ustk <- bumpn ustk 2 - poke ustk 1 - pokeOffD ustk 1 f - pure (ustk, bstk) -bprim1 !ustk !bstk VWLS i = - peekOffS bstk i >>= \case - Sq.Empty -> do - ustk <- bump ustk - poke ustk 0 - pure (ustk, bstk) - x Sq.:<| xs -> do - ustk <- bump ustk - poke ustk 1 - bstk <- bumpn bstk 2 - pokeOffS bstk 1 xs - poke bstk x - pure (ustk, bstk) -bprim1 !ustk !bstk VWRS i = - peekOffS bstk i >>= \case - Sq.Empty -> do - ustk <- bump ustk - poke ustk 0 - pure (ustk, bstk) - xs Sq.:|> x -> do - ustk <- bump ustk - poke ustk 1 - bstk <- bumpn bstk 2 - pokeOff bstk 1 x - pokeS bstk xs - pure (ustk, bstk) -bprim1 !ustk !bstk PAKT i = do - s <- peekOffS bstk i - bstk <- bump bstk - pokeBi bstk . Util.Text.pack . toList $ clo2char <$> s - pure (ustk, bstk) - where - clo2char (DataU1 _ t i) | t == charTag = toEnum i - clo2char c = error $ "pack text: non-character closure: " ++ show c -bprim1 !ustk !bstk UPKT i = do - t <- peekOffBi bstk i - bstk <- bump bstk - pokeS bstk - . Sq.fromList - . fmap (DataU1 Rf.charRef charTag . fromEnum) - . Util.Text.unpack - $ t - pure (ustk, bstk) -bprim1 !ustk !bstk PAKB i = do - s <- peekOffS bstk i - bstk <- bump bstk - pokeBi bstk . By.fromWord8s . fmap clo2w8 $ toList s - pure (ustk, bstk) - where - clo2w8 (DataU1 _ t n) | t == natTag = toEnum n - clo2w8 c = error $ "pack bytes: non-natural closure: " ++ show c -bprim1 !ustk !bstk UPKB i = do - b <- peekOffBi bstk i - bstk <- bump bstk - pokeS bstk . Sq.fromList . fmap (DataU1 Rf.natRef natTag . fromEnum) $ - By.toWord8s b - pure (ustk, bstk) -bprim1 !ustk !bstk SIZB i = do - b <- peekOffBi bstk i - ustk <- bump ustk - poke ustk $ By.size b - pure (ustk, bstk) -bprim1 !ustk !bstk FLTB i = do - b <- peekOffBi bstk i - bstk <- bump bstk - pokeBi bstk $ By.flatten b - pure (ustk, bstk) --- impossible -bprim1 !ustk !bstk MISS _ = pure (ustk, bstk) -bprim1 !ustk !bstk CACH _ = pure (ustk, bstk) -bprim1 !ustk !bstk LKUP _ = pure (ustk, bstk) -bprim1 !ustk !bstk CVLD _ = pure (ustk, bstk) -bprim1 !ustk !bstk TLTT _ = pure (ustk, bstk) -bprim1 !ustk !bstk LOAD _ = pure (ustk, bstk) -bprim1 !ustk !bstk VALU _ = pure (ustk, bstk) -bprim1 !ustk !bstk DBTX _ = pure (ustk, bstk) -bprim1 !ustk !bstk SDBL _ = pure (ustk, bstk) -{-# INLINE bprim1 #-} - -bprim2 :: - Stack 'UN -> - Stack 'BX -> - BPrim2 -> - Int -> - Int -> - IO (Stack 'UN, Stack 'BX) -bprim2 !ustk !bstk EQLU i j = do - x <- peekOff bstk i - y <- peekOff bstk j - ustk <- bump ustk - poke ustk $ if universalEq (==) x y then 1 else 0 - pure (ustk, bstk) -bprim2 !ustk !bstk IXOT i j = do - x <- peekOffBi bstk i - y <- peekOffBi bstk j - case Util.Text.indexOf x y of - Nothing -> do - ustk <- bump ustk - poke ustk 0 - pure (ustk, bstk) - Just i -> do - ustk <- bumpn ustk 2 - poke ustk 1 - pokeOffN ustk 1 i - pure (ustk, bstk) -bprim2 !ustk !bstk IXOB i j = do - x <- peekOffBi bstk i - y <- peekOffBi bstk j - case By.indexOf x y of - Nothing -> do - ustk <- bump ustk - poke ustk 0 - pure (ustk, bstk) - Just i -> do - ustk <- bumpn ustk 2 - poke ustk 1 - pokeOffN ustk 1 i - pure (ustk, bstk) -bprim2 !ustk !bstk DRPT i j = do - n <- peekOff ustk i - t <- peekOffBi bstk j - bstk <- bump bstk - -- Note; if n < 0, the Nat argument was greater than the maximum - -- signed integer. As an approximation, just return the empty - -- string, as a string larger than this would require an absurd - -- amount of memory. - pokeBi bstk $ if n < 0 then Util.Text.empty else Util.Text.drop n t - pure (ustk, bstk) -bprim2 !ustk !bstk CATT i j = do - x <- peekOffBi bstk i - y <- peekOffBi bstk j - bstk <- bump bstk - pokeBi bstk $ (x <> y :: Util.Text.Text) - pure (ustk, bstk) -bprim2 !ustk !bstk TAKT i j = do - n <- peekOff ustk i - t <- peekOffBi bstk j - bstk <- bump bstk - -- Note: if n < 0, the Nat argument was greater than the maximum - -- signed integer. As an approximation, we just return the original - -- string, because it's unlikely such a large string exists. - pokeBi bstk $ if n < 0 then t else Util.Text.take n t - pure (ustk, bstk) -bprim2 !ustk !bstk EQLT i j = do - x <- peekOffBi @Util.Text.Text bstk i - y <- peekOffBi bstk j - ustk <- bump ustk - poke ustk $ if x == y then 1 else 0 - pure (ustk, bstk) -bprim2 !ustk !bstk LEQT i j = do - x <- peekOffBi @Util.Text.Text bstk i - y <- peekOffBi bstk j - ustk <- bump ustk - poke ustk $ if x <= y then 1 else 0 - pure (ustk, bstk) -bprim2 !ustk !bstk LEST i j = do - x <- peekOffBi @Util.Text.Text bstk i - y <- peekOffBi bstk j - ustk <- bump ustk - poke ustk $ if x < y then 1 else 0 - pure (ustk, bstk) -bprim2 !ustk !bstk DRPS i j = do - n <- peekOff ustk i - s <- peekOffS bstk j - bstk <- bump bstk - -- Note: if n < 0, then the Nat argument was larger than the largest - -- signed integer. Seq actually doesn't handle this well, despite it - -- being possible to build (lazy) sequences this large. So, - -- approximate by yielding the empty sequence. - pokeS bstk $ if n < 0 then Sq.empty else Sq.drop n s - pure (ustk, bstk) -bprim2 !ustk !bstk TAKS i j = do - n <- peekOff ustk i - s <- peekOffS bstk j - bstk <- bump bstk - -- Note: if n < 0, then the Nat argument was greater than the - -- largest signed integer. It is possible to build such large - -- sequences, but the internal size will actually be wrong then. So, - -- we just return the original sequence as an approximation. - pokeS bstk $ if n < 0 then s else Sq.take n s - pure (ustk, bstk) -bprim2 !ustk !bstk CONS i j = do - x <- peekOff bstk i - s <- peekOffS bstk j - bstk <- bump bstk - pokeS bstk $ x Sq.<| s - pure (ustk, bstk) -bprim2 !ustk !bstk SNOC i j = do - s <- peekOffS bstk i - x <- peekOff bstk j - bstk <- bump bstk - pokeS bstk $ s Sq.|> x - pure (ustk, bstk) -bprim2 !ustk !bstk CATS i j = do - x <- peekOffS bstk i - y <- peekOffS bstk j - bstk <- bump bstk - pokeS bstk $ x Sq.>< y - pure (ustk, bstk) -bprim2 !ustk !bstk IDXS i j = do - n <- peekOff ustk i - s <- peekOffS bstk j - case Sq.lookup n s of - Nothing -> do - ustk <- bump ustk - poke ustk 0 - pure (ustk, bstk) - Just x -> do - ustk <- bump ustk - poke ustk 1 - bstk <- bump bstk - poke bstk x - pure (ustk, bstk) -bprim2 !ustk !bstk SPLL i j = do - n <- peekOff ustk i - s <- peekOffS bstk j - if Sq.length s < n - then do - ustk <- bump ustk - poke ustk 0 - pure (ustk, bstk) - else do - ustk <- bump ustk - poke ustk 1 - bstk <- bumpn bstk 2 - let (l, r) = Sq.splitAt n s - pokeOffS bstk 1 r - pokeS bstk l - pure (ustk, bstk) -bprim2 !ustk !bstk SPLR i j = do - n <- peekOff ustk i - s <- peekOffS bstk j - if Sq.length s < n - then do - ustk <- bump ustk - poke ustk 0 - pure (ustk, bstk) - else do - ustk <- bump ustk - poke ustk 1 - bstk <- bumpn bstk 2 - let (l, r) = Sq.splitAt (Sq.length s - n) s - pokeOffS bstk 1 r - pokeS bstk l - pure (ustk, bstk) -bprim2 !ustk !bstk TAKB i j = do - n <- peekOff ustk i - b <- peekOffBi bstk j - bstk <- bump bstk - -- If n < 0, the Nat argument was larger than the maximum signed - -- integer. Building a value this large would reuire an absurd - -- amount of memory, so just assume n is larger. - pokeBi bstk $ if n < 0 then b else By.take n b - pure (ustk, bstk) -bprim2 !ustk !bstk DRPB i j = do - n <- peekOff ustk i - b <- peekOffBi bstk j - bstk <- bump bstk - -- See above for n < 0 - pokeBi bstk $ if n < 0 then By.empty else By.drop n b - pure (ustk, bstk) -bprim2 !ustk !bstk IDXB i j = do - n <- peekOff ustk i - b <- peekOffBi bstk j - ustk <- bump ustk - ustk <- case By.at n b of - Nothing -> ustk <$ poke ustk 0 - Just x -> do - poke ustk $ fromIntegral x - ustk <- bump ustk - ustk <$ poke ustk 1 - pure (ustk, bstk) -bprim2 !ustk !bstk CATB i j = do - l <- peekOffBi bstk i - r <- peekOffBi bstk j - bstk <- bump bstk - pokeBi bstk (l <> r :: By.Bytes) - pure (ustk, bstk) -bprim2 !ustk !bstk THRO _ _ = pure (ustk, bstk) -- impossible -bprim2 !ustk !bstk TRCE _ _ = pure (ustk, bstk) -- impossible -bprim2 !ustk !bstk CMPU _ _ = pure (ustk, bstk) -- impossible -bprim2 !ustk !bstk SDBX _ _ = pure (ustk, bstk) -- impossible -bprim2 !ustk !bstk SDBV _ _ = pure (ustk, bstk) -- impossible -{-# INLINE bprim2 #-} - -yield :: - CCache -> - DEnv -> - ActiveThreads -> - Stack 'UN -> - Stack 'BX -> - K -> - IO () -yield !env !denv !activeThreads !ustk !bstk !k = leap denv k - where - leap !denv0 (Mark ua ba ps cs k) = do - let denv = cs <> EC.withoutKeys denv0 ps - clo = denv0 EC.! EC.findMin ps - poke bstk . DataB1 Rf.effectRef 0 =<< peek bstk - ustk <- adjustArgs ustk ua - bstk <- adjustArgs bstk ba - apply env denv activeThreads ustk bstk k False (BArg1 0) clo - leap !denv (Push ufsz bfsz uasz basz cix k) = do - Lam _ _ uf bf nx <- combSection env cix - ustk <- restoreFrame ustk ufsz uasz - bstk <- restoreFrame bstk bfsz basz - ustk <- ensure ustk uf - bstk <- ensure bstk bf - eval env denv activeThreads ustk bstk k (combRef cix) nx - leap _ (CB (Hook f)) = f ustk bstk - leap _ KE = pure () -{-# INLINE yield #-} - -selectTextBranch :: - Util.Text.Text -> Section -> M.Map Util.Text.Text Section -> Section -selectTextBranch t df cs = M.findWithDefault df t cs -{-# INLINE selectTextBranch #-} - -selectBranch :: Tag -> Branch -> Section -selectBranch t (Test1 u y n) - | t == u = y - | otherwise = n -selectBranch t (Test2 u cu v cv e) - | t == u = cu - | t == v = cv - | otherwise = e -selectBranch t (TestW df cs) = lookupWithDefault df t cs -selectBranch _ (TestT {}) = error "impossible" -{-# INLINE selectBranch #-} - --- Splits off a portion of the continuation up to a given prompt. --- --- The main procedure walks along the 'code' stack `k`, keeping track of how --- many cells of the data stacks need to be captured. Then the `finish` function --- performs the actual splitting of the data stacks together with some tweaking. --- --- Some special attention is required for pending arguments for over-applied --- functions. They are part of the continuation, so how many there are at the --- time of capture is recorded in the `Captured` closure, so that information --- can be restored later. Also, the `Mark` frame that is popped off as part of --- this operation potentially exposes pending arguments beyond the delimited --- region, so those are restored in the `finish` function. -splitCont :: - DEnv -> - Stack 'UN -> - Stack 'BX -> - K -> - Word64 -> - IO (Closure, DEnv, Stack 'UN, Stack 'BX, K) -splitCont !denv !ustk !bstk !k !p = - walk denv uasz basz KE k - where - uasz = asize ustk - basz = asize bstk - walk !denv !usz !bsz !ck KE = - die "fell off stack" >> finish denv usz bsz 0 0 ck KE - walk !denv !usz !bsz !ck (CB _) = - die "fell off stack" >> finish denv usz bsz 0 0 ck KE - walk !denv !usz !bsz !ck (Mark ua ba ps cs k) - | EC.member p ps = finish denv' usz bsz ua ba ck k - | otherwise = walk denv' (usz + ua) (bsz + ba) (Mark ua ba ps cs' ck) k - where - denv' = cs <> EC.withoutKeys denv ps - cs' = EC.restrictKeys denv ps - walk !denv !usz !bsz !ck (Push un bn ua ba br k) = - walk denv (usz + un + ua) (bsz + bn + ba) (Push un bn ua ba br ck) k - - finish !denv !usz !bsz !ua !ba !ck !k = do - (useg, ustk) <- grab ustk usz - (bseg, bstk) <- grab bstk bsz - ustk <- adjustArgs ustk ua - bstk <- adjustArgs bstk ba - return (Captured ck uasz basz useg bseg, denv, ustk, bstk, k) -{-# INLINE splitCont #-} - -discardCont :: - DEnv -> - Stack 'UN -> - Stack 'BX -> - K -> - Word64 -> - IO (DEnv, Stack 'UN, Stack 'BX, K) -discardCont denv ustk bstk k p = - splitCont denv ustk bstk k p - <&> \(_, denv, ustk, bstk, k) -> (denv, ustk, bstk, k) -{-# INLINE discardCont #-} - -resolve :: CCache -> DEnv -> Stack 'BX -> Ref -> IO Closure -resolve env _ _ (Env n i) = - readTVarIO (combRefs env) >>= \rs -> case EC.lookup n rs of - Just r -> pure $ PAp (CIx r n i) unull bnull - Nothing -> die $ "resolve: missing reference for comb: " ++ show n -resolve _ _ bstk (Stk i) = peekOff bstk i -resolve env denv _ (Dyn i) = case EC.lookup i denv of - Just clo -> pure clo - Nothing -> unhandledErr "resolve" env i - -unhandledErr :: String -> CCache -> Word64 -> IO a -unhandledErr fname env i = - readTVarIO (tagRefs env) >>= \rs -> case EC.lookup i rs of - Just r -> bomb (show r) - Nothing -> bomb (show i) - where - bomb sh = die $ fname ++ ": unhandled ability request: " ++ sh - -combSection :: (HasCallStack) => CCache -> CombIx -> IO Comb -combSection env (CIx _ n i) = - readTVarIO (combs env) >>= \cs -> case EC.lookup n cs of - Just cmbs -> case EC.lookup i cmbs of - Just cmb -> pure cmb - Nothing -> - die $ - "unknown section `" - ++ show i - ++ "` of combinator `" - ++ show n - ++ "`." - Nothing -> die $ "unknown combinator `" ++ show n ++ "`." - -dummyRef :: Reference -dummyRef = Builtin (DTx.pack "dummy") - -reserveIds :: Word64 -> TVar Word64 -> IO Word64 -reserveIds n free = atomically . stateTVar free $ \i -> (i, i + n) - -updateMap :: (Semigroup s) => s -> TVar s -> STM s -updateMap new0 r = do - new <- evaluateSTM new0 - stateTVar r $ \old -> - let total = new <> old in (total, total) - -refLookup :: String -> M.Map Reference Word64 -> Reference -> Word64 -refLookup s m r - | Just w <- M.lookup r m = w - | otherwise = - error $ "refLookup:" ++ s ++ ": unknown reference: " ++ show r - -decodeCacheArgument :: - Sq.Seq Closure -> IO [(Reference, SuperGroup Symbol)] -decodeCacheArgument s = for (toList s) $ \case - DataB2 _ _ (Foreign x) (DataB2 _ _ (Foreign y) _) -> - case unwrapForeign x of - Ref r -> pure (r, unwrapForeign y) - _ -> die "decodeCacheArgument: Con reference" - _ -> die "decodeCacheArgument: unrecognized value" - -decodeSandboxArgument :: Sq.Seq Closure -> IO [Reference] -decodeSandboxArgument s = fmap join . for (toList s) $ \case - Foreign x -> case unwrapForeign x of - Ref r -> pure [r] - _ -> pure [] -- constructor - _ -> die "decodeSandboxArgument: unrecognized value" - -encodeSandboxListResult :: [Reference] -> Sq.Seq Closure -encodeSandboxListResult = - Sq.fromList . fmap (Foreign . Wrap Rf.termLinkRef . Ref) - -encodeSandboxResult :: Either [Reference] [Reference] -> Closure -encodeSandboxResult (Left rfs) = - encodeLeft . Foreign . Wrap Rf.listRef $ encodeSandboxListResult rfs -encodeSandboxResult (Right rfs) = - encodeRight . Foreign . Wrap Rf.listRef $ encodeSandboxListResult rfs - -encodeLeft :: Closure -> Closure -encodeLeft = DataB1 Rf.eitherRef leftTag - -encodeRight :: Closure -> Closure -encodeRight = DataB1 Rf.eitherRef rightTag - -addRefs :: - TVar Word64 -> - TVar (M.Map Reference Word64) -> - TVar (EnumMap Word64 Reference) -> - S.Set Reference -> - STM (M.Map Reference Word64) -addRefs vfrsh vfrom vto rs = do - from0 <- readTVar vfrom - let new = S.filter (`M.notMember` from0) rs - sz = fromIntegral $ S.size new - frsh <- stateTVar vfrsh $ \i -> (i, i + sz) - let newl = S.toList new - from = M.fromList (zip newl [frsh ..]) <> from0 - nto = mapFromList (zip [frsh ..] newl) - writeTVar vfrom from - modifyTVar vto (nto <>) - pure from - -codeValidate :: - [(Reference, SuperGroup Symbol)] -> - CCache -> - IO (Maybe (Failure Closure)) -codeValidate tml cc = do - rty0 <- readTVarIO (refTy cc) - fty <- readTVarIO (freshTy cc) - let f b r - | b, M.notMember r rty0 = S.singleton r - | otherwise = mempty - ntys0 = (foldMap . foldMap) (foldGroupLinks f) tml - ntys = M.fromList $ zip (S.toList ntys0) [fty ..] - rty = ntys <> rty0 - ftm <- readTVarIO (freshTm cc) - rtm0 <- readTVarIO (refTm cc) - let rs = fst <$> tml - rtm = rtm0 `M.withoutKeys` S.fromList rs - rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) - combinate (n, (r, g)) = evaluate $ emitCombs rns r n g - (Nothing <$ traverse_ combinate (zip [ftm ..] tml)) - `catch` \(CE cs perr) -> - let msg = Util.Text.pack $ toPlainUnbroken perr - extra = Foreign . Wrap Rf.textRef . Util.Text.pack $ show cs - in pure . Just $ Failure ioFailureRef msg extra - -sandboxList :: CCache -> Referent -> IO [Reference] -sandboxList cc (Ref r) = do - sands <- readTVarIO $ sandbox cc - pure . maybe [] S.toList $ M.lookup r sands -sandboxList _ _ = pure [] - -checkSandboxing :: - CCache -> - [Reference] -> - Closure -> - IO Bool -checkSandboxing cc allowed0 c = do - sands <- readTVarIO $ sandbox cc - let f r - | Just rs <- M.lookup r sands = - rs `S.difference` allowed - | otherwise = mempty - pure $ S.null (closureTermRefs f c) - where - allowed = S.fromList allowed0 - --- Checks a Value for sandboxing. A Left result indicates that some --- dependencies of the Value are unknown. A Right result indicates --- builtins transitively referenced by the Value that are disallowed. -checkValueSandboxing :: - CCache -> - [Reference] -> - ANF.Value -> - IO (Either [Reference] [Reference]) -checkValueSandboxing cc allowed0 v = do - sands <- readTVarIO $ sandbox cc - have <- readTVarIO $ intermed cc - let f False r - | Nothing <- M.lookup r have, - not (isBuiltin r) = - (S.singleton r, mempty) - | Just rs <- M.lookup r sands = - (mempty, rs `S.difference` allowed) - f _ _ = (mempty, mempty) - case valueLinks f v of - (miss, sbx) - | S.null miss -> pure . Right $ S.toList sbx - | otherwise -> pure . Left $ S.toList miss - where - allowed = S.fromList allowed0 - --- Just evaluating to force exceptions. Shouldn't actually be that --- unsafe. -evaluateSTM :: a -> STM a -evaluateSTM x = unsafeIOToSTM (evaluate x) - -cacheAdd0 :: - S.Set Reference -> - [(Reference, SuperGroup Symbol)] -> - [(Reference, Set Reference)] -> - CCache -> - IO () -cacheAdd0 ntys0 tml sands cc = atomically $ do - have <- readTVar (intermed cc) - let new = M.difference toAdd have - sz = fromIntegral $ M.size new - rgs = M.toList new - rs = fst <$> rgs - int <- writeTVar (intermed cc) (have <> new) - rty <- addRefs (freshTy cc) (refTy cc) (tagRefs cc) ntys0 - ntm <- stateTVar (freshTm cc) $ \i -> (i, i + sz) - rtm <- updateMap (M.fromList $ zip rs [ntm ..]) (refTm cc) - -- check for missing references - let rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) - combinate n (r, g) = (n, emitCombs rns r n g) - nrs <- updateMap (mapFromList $ zip [ntm ..] rs) (combRefs cc) - ncs <- updateMap (mapFromList $ zipWith combinate [ntm ..] rgs) (combs cc) - nsn <- updateMap (M.fromList sands) (sandbox cc) - pure $ int `seq` rtm `seq` nrs `seq` ncs `seq` nsn `seq` () - where - toAdd = M.fromList tml - -expandSandbox :: - Map Reference (Set Reference) -> - [(Reference, SuperGroup Symbol)] -> - [(Reference, Set Reference)] -expandSandbox sand0 groups = fixed mempty - where - f sand False r = fromMaybe mempty $ M.lookup r sand - f _ True _ = mempty - - h sand (r, foldGroupLinks (f sand) -> s) - | S.null s = Nothing - | otherwise = Just (r, s) - - fixed extra - | extra == extra' = new - | otherwise = fixed extra' - where - new = mapMaybe (h $ extra <> sand0) groups - extra' = M.fromList new - -cacheAdd :: - [(Reference, SuperGroup Symbol)] -> - CCache -> - IO [Reference] -cacheAdd l cc = do - rtm <- readTVarIO (refTm cc) - rty <- readTVarIO (refTy cc) - sand <- readTVarIO (sandbox cc) - let known = M.keysSet rtm <> S.fromList (fst <$> l) - f b r - | not b, S.notMember r known = Const (S.singleton r, mempty) - | b, M.notMember r rty = Const (mempty, S.singleton r) - | otherwise = Const (mempty, mempty) - (missing, tys) = getConst $ (foldMap . foldMap) (foldGroupLinks f) l - l' = filter (\(r, _) -> M.notMember r rtm) l - if S.null missing - then [] <$ cacheAdd0 tys l' (expandSandbox sand l') cc - else pure $ S.toList missing - -reflectValue :: EnumMap Word64 Reference -> Closure -> IO ANF.Value -reflectValue rty = goV - where - err s = "reflectValue: cannot prepare value for serialization: " ++ s - refTy w - | Just r <- EC.lookup w rty = pure r - | otherwise = - die $ err "unknown type reference" - - goIx (CIx r _ i) = ANF.GR r i - - goV (PApV cix ua ba) = - ANF.Partial (goIx cix) (fromIntegral <$> ua) <$> traverse goV ba - goV (DataC _ t [w] []) = ANF.BLit <$> reflectUData t w - goV (DataC r t us bs) = - ANF.Data r (maskTags t) (fromIntegral <$> us) <$> traverse goV bs - goV (CapV k _ _ us bs) = - ANF.Cont (fromIntegral <$> us) <$> traverse goV bs <*> goK k - goV (Foreign f) = ANF.BLit <$> goF f - goV BlackHole = die $ err "black hole" - - goK (CB _) = die $ err "callback continuation" - goK KE = pure ANF.KE - goK (Mark ua ba ps de k) = do - ps <- traverse refTy (EC.setToList ps) - de <- traverse (\(k, v) -> (,) <$> refTy k <*> goV v) (mapToList de) - ANF.Mark (fromIntegral ua) (fromIntegral ba) ps (M.fromList de) <$> goK k - goK (Push uf bf ua ba cix k) = - ANF.Push - (fromIntegral uf) - (fromIntegral bf) - (fromIntegral ua) - (fromIntegral ba) - (goIx cix) - <$> goK k - - goF f - | Just t <- maybeUnwrapBuiltin f = - pure (ANF.Text t) - | Just b <- maybeUnwrapBuiltin f = - pure (ANF.Bytes b) - | Just s <- maybeUnwrapForeign Rf.listRef f = - ANF.List <$> traverse goV s - | Just l <- maybeUnwrapForeign Rf.termLinkRef f = - pure (ANF.TmLink l) - | Just l <- maybeUnwrapForeign Rf.typeLinkRef f = - pure (ANF.TyLink l) - | Just v <- maybeUnwrapForeign Rf.valueRef f = - pure (ANF.Quote v) - | Just g <- maybeUnwrapForeign Rf.codeRef f = - pure (ANF.Code g) - | Just a <- maybeUnwrapForeign Rf.ibytearrayRef f = - pure (ANF.BArr a) - | Just a <- maybeUnwrapForeign Rf.iarrayRef f = - ANF.Arr <$> traverse goV a - | otherwise = die $ err $ "foreign value: " <> (show f) - - reflectUData :: Word64 -> Int -> IO ANF.BLit - reflectUData t v - | t == natTag = pure $ ANF.Pos (fromIntegral v) - | t == charTag = pure $ ANF.Char (toEnum v) - | t == intTag, v >= 0 = pure $ ANF.Pos (fromIntegral v) - | t == intTag, v < 0 = pure $ ANF.Neg (fromIntegral (-v)) - | t == floatTag = pure $ ANF.Float (intToDouble v) - | otherwise = die . err $ "unboxed data: " <> show (t, v) - -reifyValue :: CCache -> ANF.Value -> IO (Either [Reference] Closure) -reifyValue cc val = do - erc <- - atomically $ - readTVar (refTm cc) >>= \rtm -> - case S.toList $ S.filter (`M.notMember` rtm) tmLinks of - [] -> - Right . (,rtm) - <$> addRefs (freshTy cc) (refTy cc) (tagRefs cc) tyLinks - l -> pure (Left l) - traverse (\rfs -> reifyValue0 rfs val) erc - where - f False r = (mempty, S.singleton r) - f True r = (S.singleton r, mempty) - (tyLinks, tmLinks) = valueLinks f val - -reifyValue0 :: - (M.Map Reference Word64, M.Map Reference Word64) -> - ANF.Value -> - IO Closure -reifyValue0 (rty, rtm) = goV - where - err s = "reifyValue: cannot restore value: " ++ s - refTy r - | Just w <- M.lookup r rty = pure w - | otherwise = die . err $ "unknown type reference: " ++ show r - refTm r - | Just w <- M.lookup r rtm = pure w - | otherwise = die . err $ "unknown term reference: " ++ show r - goIx (ANF.GR r i) = refTm r <&> \n -> CIx r n i - - goV (ANF.Partial gr ua ba) = - pap <$> (goIx gr) <*> traverse goV ba - where - pap i = PApV i (fromIntegral <$> ua) - goV (ANF.Data r t0 us bs) = do - t <- flip packTags (fromIntegral t0) . fromIntegral <$> refTy r - DataC r t (fromIntegral <$> us) <$> traverse goV bs - goV (ANF.Cont us bs k) = cv <$> goK k <*> traverse goV bs - where - cv k bs = CapV k ua ba (fromIntegral <$> us) bs - where - (uksz, bksz) = frameDataSize k - ua = fromIntegral $ length us - uksz - ba = fromIntegral $ length bs - bksz - goV (ANF.BLit l) = goL l - - goK ANF.KE = pure KE - goK (ANF.Mark ua ba ps de k) = - mrk - <$> traverse refTy ps - <*> traverse (\(k, v) -> (,) <$> refTy k <*> goV v) (M.toList de) - <*> goK k - where - mrk ps de k = - Mark (fromIntegral ua) (fromIntegral ba) (setFromList ps) (mapFromList de) k - goK (ANF.Push uf bf ua ba gr k) = - Push - (fromIntegral uf) - (fromIntegral bf) - (fromIntegral ua) - (fromIntegral ba) - <$> (goIx gr) - <*> goK k - - goL (ANF.Text t) = pure . Foreign $ Wrap Rf.textRef t - goL (ANF.List l) = Foreign . Wrap Rf.listRef <$> traverse goV l - goL (ANF.TmLink r) = pure . Foreign $ Wrap Rf.termLinkRef r - goL (ANF.TyLink r) = pure . Foreign $ Wrap Rf.typeLinkRef r - goL (ANF.Bytes b) = pure . Foreign $ Wrap Rf.bytesRef b - goL (ANF.Quote v) = pure . Foreign $ Wrap Rf.valueRef v - goL (ANF.Code g) = pure . Foreign $ Wrap Rf.codeRef g - goL (ANF.BArr a) = pure . Foreign $ Wrap Rf.ibytearrayRef a - goL (ANF.Char c) = pure $ DataU1 Rf.charRef charTag (fromEnum c) - goL (ANF.Pos w) = - pure $ DataU1 Rf.natRef natTag (fromIntegral w) - goL (ANF.Neg w) = - pure $ DataU1 Rf.intRef intTag (-fromIntegral w) - goL (ANF.Float d) = - pure $ DataU1 Rf.floatRef floatTag (doubleToInt d) - goL (ANF.Arr a) = Foreign . Wrap Rf.iarrayRef <$> traverse goV a - -doubleToInt :: Double -> Int -doubleToInt d = indexByteArray (BA.byteArrayFromList [d]) 0 - -intToDouble :: Int -> Double -intToDouble w = indexByteArray (BA.byteArrayFromList [w]) 0 - --- Universal comparison functions - -closureNum :: Closure -> Int -closureNum PAp {} = 0 -closureNum DataC {} = 1 -closureNum Captured {} = 2 -closureNum Foreign {} = 3 -closureNum BlackHole {} = error "BlackHole" - -universalEq :: - (Foreign -> Foreign -> Bool) -> - Closure -> - Closure -> - Bool -universalEq frn = eqc - where - eql cm l r = length l == length r && and (zipWith cm l r) - eqc (DataC _ ct1 [w1] []) (DataC _ ct2 [w2] []) = - matchTags ct1 ct2 && w1 == w2 - eqc (DataC _ ct1 us1 bs1) (DataC _ ct2 us2 bs2) = - ct1 == ct2 - && eql (==) us1 us2 - && eql eqc bs1 bs2 - eqc (PApV i1 us1 bs1) (PApV i2 us2 bs2) = - i1 == i2 - && eql (==) us1 us2 - && eql eqc bs1 bs2 - eqc (CapV k1 ua1 ba1 us1 bs1) (CapV k2 ua2 ba2 us2 bs2) = - k1 == k2 - && ua1 == ua2 - && ba1 == ba2 - && eql (==) us1 us2 - && eql eqc bs1 bs2 - eqc (Foreign fl) (Foreign fr) - | Just al <- maybeUnwrapForeign Rf.iarrayRef fl, - Just ar <- maybeUnwrapForeign Rf.iarrayRef fr = - arrayEq eqc al ar - | Just sl <- maybeUnwrapForeign Rf.listRef fl, - Just sr <- maybeUnwrapForeign Rf.listRef fr = - length sl == length sr && and (Sq.zipWith eqc sl sr) - | otherwise = frn fl fr - eqc c d = closureNum c == closureNum d - - -- serialization doesn't necessarily preserve Int tags, so be - -- more accepting for those. - matchTags ct1 ct2 = - ct1 == ct2 - || (ct1 == intTag && ct2 == natTag) - || (ct1 == natTag && ct2 == intTag) - -arrayEq :: (Closure -> Closure -> Bool) -> PA.Array Closure -> PA.Array Closure -> Bool -arrayEq eqc l r - | PA.sizeofArray l /= PA.sizeofArray r = False - | otherwise = go (PA.sizeofArray l - 1) - where - go i - | i < 0 = True - | otherwise = eqc (PA.indexArray l i) (PA.indexArray r i) && go (i - 1) - --- IEEE floating point layout is such that comparison as integers --- somewhat works. Positive floating values map to positive integers --- and negatives map to negatives. The corner cases are: --- --- 1. If both numbers are negative, ordering is flipped. --- 2. There is both +0 and -0, with -0 being represented as the --- minimum signed integer. --- 3. NaN does weird things. --- --- So, the strategy here is to compare normally if one argument is --- positive, since positive numbers compare normally to others. --- Otherwise, the sign bit is cleared and the numbers are compared --- backwards. Clearing the sign bit maps -0 to +0 and maps a negative --- number to its absolute value (including infinities). The multiple --- NaN values are just handled according to bit patterns, rather than --- IEEE specified behavior. --- --- Transitivity is somewhat non-obvious for this implementation. --- --- if i <= j and j <= k --- if j > 0 then k > 0, so all 3 comparisons use `compare` --- if k > 0 then k > i, since i <= j <= 0 --- if all 3 are <= 0, all 3 comparisons use the alternate --- comparison, which is transitive via `compare` -compareAsFloat :: Int -> Int -> Ordering -compareAsFloat i j - | i > 0 || j > 0 = compare i j - | otherwise = compare (clear j) (clear i) - where - clear k = clearBit k 64 - -compareAsNat :: Int -> Int -> Ordering -compareAsNat i j = compare ni nj - where - ni, nj :: Word - ni = fromIntegral i - nj = fromIntegral j - -floatTag :: Word64 -floatTag - | Just n <- M.lookup Rf.floatRef builtinTypeNumbering, - rt <- toEnum (fromIntegral n) = - packTags rt 0 - | otherwise = error "internal error: floatTag" - -natTag :: Word64 -natTag - | Just n <- M.lookup Rf.natRef builtinTypeNumbering, - rt <- toEnum (fromIntegral n) = - packTags rt 0 - | otherwise = error "internal error: natTag" - -intTag :: Word64 -intTag - | Just n <- M.lookup Rf.intRef builtinTypeNumbering, - rt <- toEnum (fromIntegral n) = - packTags rt 0 - | otherwise = error "internal error: intTag" - -charTag :: Word64 -charTag - | Just n <- M.lookup Rf.charRef builtinTypeNumbering, - rt <- toEnum (fromIntegral n) = - packTags rt 0 - | otherwise = error "internal error: charTag" - -unitTag :: Word64 -unitTag - | Just n <- M.lookup Rf.unitRef builtinTypeNumbering, - rt <- toEnum (fromIntegral n) = - packTags rt 0 - | otherwise = error "internal error: unitTag" - -leftTag, rightTag :: Word64 -(leftTag, rightTag) - | Just n <- M.lookup Rf.eitherRef builtinTypeNumbering, - et <- toEnum (fromIntegral n), - lt <- toEnum (fromIntegral Rf.eitherLeftId), - rt <- toEnum (fromIntegral Rf.eitherRightId) = - (packTags et lt, packTags et rt) - | otherwise = error "internal error: either tags" - -universalCompare :: - (Foreign -> Foreign -> Ordering) -> - Closure -> - Closure -> - Ordering -universalCompare frn = cmpc False - where - cmpl cm l r = - compare (length l) (length r) <> fold (zipWith cm l r) - cmpc _ (DataC _ ct1 [i] []) (DataC _ ct2 [j] []) - | ct1 == floatTag, ct2 == floatTag = compareAsFloat i j - | ct1 == natTag, ct2 == natTag = compareAsNat i j - | ct1 == intTag, ct2 == natTag = compare i j - | ct1 == natTag, ct2 == intTag = compare i j - cmpc tyEq (DataC rf1 ct1 us1 bs1) (DataC rf2 ct2 us2 bs2) = - (if tyEq && ct1 /= ct2 then compare rf1 rf2 else EQ) - <> compare (maskTags ct1) (maskTags ct2) - <> cmpl compare us1 us2 - -- when comparing corresponding `Any` values, which have - -- existentials inside check that type references match - <> cmpl (cmpc $ tyEq || rf1 == Rf.anyRef) bs1 bs2 - cmpc tyEq (PApV i1 us1 bs1) (PApV i2 us2 bs2) = - compare i1 i2 - <> cmpl compare us1 us2 - <> cmpl (cmpc tyEq) bs1 bs2 - cmpc _ (CapV k1 ua1 ba1 us1 bs1) (CapV k2 ua2 ba2 us2 bs2) = - compare k1 k2 - <> compare ua1 ua2 - <> compare ba1 ba2 - <> cmpl compare us1 us2 - <> cmpl (cmpc True) bs1 bs2 - cmpc tyEq (Foreign fl) (Foreign fr) - | Just sl <- maybeUnwrapForeign Rf.listRef fl, - Just sr <- maybeUnwrapForeign Rf.listRef fr = - fold (Sq.zipWith (cmpc tyEq) sl sr) - <> compare (length sl) (length sr) - | Just al <- maybeUnwrapForeign Rf.iarrayRef fl, - Just ar <- maybeUnwrapForeign Rf.iarrayRef fr = - arrayCmp (cmpc tyEq) al ar - | otherwise = frn fl fr - cmpc _ c d = comparing closureNum c d - -arrayCmp :: - (Closure -> Closure -> Ordering) -> - PA.Array Closure -> - PA.Array Closure -> - Ordering -arrayCmp cmpc l r = - comparing PA.sizeofArray l r <> go (PA.sizeofArray l - 1) - where - go i - | i < 0 = EQ - | otherwise = cmpc (PA.indexArray l i) (PA.indexArray r i) <> go (i - 1) diff --git a/parser-typechecker/src/Unison/Runtime/Serialize.hs b/parser-typechecker/src/Unison/Runtime/Serialize.hs deleted file mode 100644 index 622fc11e79..0000000000 --- a/parser-typechecker/src/Unison/Runtime/Serialize.hs +++ /dev/null @@ -1,537 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Unison.Runtime.Serialize where - -import Control.Applicative (liftA2) -import Control.Monad (replicateM) -import Data.Bits (Bits) -import Data.ByteString qualified as B -import Data.Bytes.Get hiding (getBytes) -import Data.Bytes.Get qualified as Ser -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Bytes.Signed (Unsigned) -import Data.Bytes.VarInt -import Data.Foldable (traverse_) -import Data.Int (Int64) -import Data.Map.Strict as Map (Map, fromList, toList) -import Data.Primitive qualified as PA -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Vector.Primitive qualified as BA -import Data.Word (Word64, Word8) -import GHC.Exts as IL (IsList (..)) -import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) -import Unison.ConstructorType qualified as CT -import Unison.Hash (Hash) -import Unison.Hash qualified as Hash -import Unison.Reference (Id' (..), Reference, Reference' (Builtin, DerivedId), pattern Derived) -import Unison.Referent (Referent, pattern Con, pattern Ref) -import Unison.Runtime.Exception -import Unison.Runtime.MCode - ( BPrim1 (..), - BPrim2 (..), - UPrim1 (..), - UPrim2 (..), - ) -import Unison.Util.Bytes qualified as Bytes -import Unison.Util.EnumContainers as EC - -unknownTag :: (MonadGet m) => String -> Word8 -> m a -unknownTag t w = - remaining >>= \r -> - exn $ - "unknown " - ++ t - ++ " word: " - ++ show w - ++ " (" - ++ show (fromIntegral @_ @Int r) - ++ " bytes remaining)" - -class Tag t where - tag2word :: t -> Word8 - word2tag :: (MonadGet m) => Word8 -> m t - -putTag :: (MonadPut m) => (Tag t) => t -> m () -putTag = putWord8 . tag2word - -getTag :: (MonadGet m) => (Tag t) => m t -getTag = word2tag =<< getWord8 - --- Some basics, moved over from V1 serialization -putChar :: (MonadPut m) => Char -> m () -putChar = serialize . VarInt . fromEnum - -getChar :: (MonadGet m) => m Char -getChar = toEnum . unVarInt <$> deserialize - -putFloat :: (MonadPut m) => Double -> m () -putFloat = serializeBE - -getFloat :: (MonadGet m) => m Double -getFloat = deserializeBE - -putBool :: (MonadPut m) => Bool -> m () -putBool b = putWord8 (if b then 1 else 0) - -getBool :: (MonadGet m) => m Bool -getBool = d =<< getWord8 - where - d 0 = pure False - d 1 = pure True - d n = exn $ "getBool: bad tag: " ++ show n - -putNat :: (MonadPut m) => Word64 -> m () -putNat = putWord64be - -getNat :: (MonadGet m) => m Word64 -getNat = getWord64be - -putInt :: (MonadPut m) => Int64 -> m () -putInt = serializeBE - -getInt :: (MonadGet m) => m Int64 -getInt = deserializeBE - -putLength :: - ( MonadPut m, - Integral n, - Integral (Unsigned n), - Bits n, - Bits (Unsigned n) - ) => - n -> - m () -putLength = serialize . VarInt - -getLength :: - ( MonadGet m, - Integral n, - Integral (Unsigned n), - Bits n, - Bits (Unsigned n) - ) => - m n -getLength = unVarInt <$> deserialize - --- Checks for negatives, in case you put an Integer, which does not --- behave properly for negative numbers. -putPositive :: - MonadPut m => - Bits n => - Bits (Unsigned n) => - Integral n => - Integral (Unsigned n) => - n -> - m () -putPositive n - | n < 0 = exn $ "putPositive: negative number: " ++ show (toInteger n) - | otherwise = serialize (VarInt n) - --- Reads as an Integer, then checks that the result will fit in the --- result type. -getPositive :: - forall m n. - Bounded n => - Integral n => - MonadGet m => - m n -getPositive = validate . unVarInt =<< deserialize - where - mx0 :: n - mx0 = maxBound - mx :: Integer - mx = fromIntegral mx0 - - validate :: Integer -> m n - validate n - | n <= mx = pure $ fromIntegral n - | otherwise = fail $ "getPositive: overflow: " ++ show n - -putFoldable :: - (Foldable f, MonadPut m) => (a -> m ()) -> f a -> m () -putFoldable putA as = do - putLength (length as) - traverse_ putA as - -putMap :: (MonadPut m) => (a -> m ()) -> (b -> m ()) -> Map a b -> m () -putMap putA putB m = putFoldable (putPair putA putB) (Map.toList m) - -getList :: (MonadGet m) => m a -> m [a] -getList a = getLength >>= (`replicateM` a) - -getMap :: (MonadGet m, Ord a) => m a -> m b -> m (Map a b) -getMap getA getB = Map.fromList <$> getList (getPair getA getB) - -putEnumMap :: - (MonadPut m) => - (EnumKey k) => - (k -> m ()) -> - (v -> m ()) -> - EnumMap k v -> - m () -putEnumMap pk pv m = putFoldable (putPair pk pv) (mapToList m) - -getEnumMap :: (MonadGet m) => (EnumKey k) => m k -> m v -> m (EnumMap k v) -getEnumMap gk gv = mapFromList <$> getList (getPair gk gv) - -putEnumSet :: (MonadPut m) => (EnumKey k) => (k -> m ()) -> EnumSet k -> m () -putEnumSet pk s = putLength (setSize s) *> traverseSet_ pk s - -getEnumSet :: (MonadGet m) => (EnumKey k) => m k -> m (EnumSet k) -getEnumSet gk = setFromList <$> getList gk - -putMaybe :: (MonadPut m) => Maybe a -> (a -> m ()) -> m () -putMaybe Nothing _ = putWord8 0 -putMaybe (Just a) putA = putWord8 1 *> putA a - -getMaybe :: (MonadGet m) => m a -> m (Maybe a) -getMaybe getA = - getWord8 >>= \tag -> case tag of - 0 -> pure Nothing - 1 -> Just <$> getA - _ -> unknownTag "Maybe" tag - -putPair :: (MonadPut m) => (a -> m ()) -> (b -> m ()) -> (a, b) -> m () -putPair putA putB (a, b) = putA a *> putB b - -getPair :: (MonadGet m) => m a -> m b -> m (a, b) -getPair = liftA2 (,) - -getBytes :: (MonadGet m) => m Bytes.Bytes -getBytes = Bytes.fromChunks <$> getList getBlock - -putBytes :: (MonadPut m) => Bytes.Bytes -> m () -putBytes = putFoldable putBlock . Bytes.chunks - -getByteArray :: (MonadGet m) => m PA.ByteArray -getByteArray = PA.byteArrayFromList <$> getList getWord8 - -putByteArray :: (MonadPut m) => PA.ByteArray -> m () -putByteArray a = putFoldable putWord8 (IL.toList a) - -getBlock :: (MonadGet m) => m Bytes.Chunk -getBlock = getLength >>= fmap Bytes.byteStringToChunk . getByteString - -putBlock :: (MonadPut m) => Bytes.Chunk -> m () -putBlock b = putLength (BA.length b) *> putByteString (Bytes.chunkToByteString b) - -putHash :: (MonadPut m) => Hash -> m () -putHash h = do - let bs = Hash.toByteString h - putLength (B.length bs) - putByteString bs - -getHash :: (MonadGet m) => m Hash -getHash = do - len <- getLength - bs <- B.copy <$> Ser.getBytes len - pure $ Hash.fromByteString bs - -putReferent :: (MonadPut m) => Referent -> m () -putReferent = \case - Ref r -> do - putWord8 0 - putReference r - Con r ct -> do - putWord8 1 - putConstructorReference r - putConstructorType ct - -getReferent :: (MonadGet m) => m Referent -getReferent = do - tag <- getWord8 - case tag of - 0 -> Ref <$> getReference - 1 -> Con <$> getConstructorReference <*> getConstructorType - _ -> unknownTag "getReferent" tag - -getConstructorType :: (MonadGet m) => m CT.ConstructorType -getConstructorType = - getWord8 >>= \case - 0 -> pure CT.Data - 1 -> pure CT.Effect - t -> unknownTag "getConstructorType" t - -putConstructorType :: (MonadPut m) => CT.ConstructorType -> m () -putConstructorType = \case - CT.Data -> putWord8 0 - CT.Effect -> putWord8 1 - -putText :: (MonadPut m) => Text -> m () -putText text = do - let bs = encodeUtf8 text - putLength $ B.length bs - putByteString bs - -getText :: (MonadGet m) => m Text -getText = do - len <- getLength - bs <- B.copy <$> Ser.getBytes len - pure $ decodeUtf8 bs - -putReference :: (MonadPut m) => Reference -> m () -putReference r = case r of - Builtin name -> do - putWord8 0 - putText name - Derived hash i -> do - putWord8 1 - putHash hash - putLength i - -getReference :: (MonadGet m) => m Reference -getReference = do - tag <- getWord8 - case tag of - 0 -> Builtin <$> getText - 1 -> DerivedId <$> (Id <$> getHash <*> getLength) - _ -> unknownTag "Reference" tag - -putConstructorReference :: (MonadPut m) => ConstructorReference -> m () -putConstructorReference (ConstructorReference r i) = do - putReference r - putLength i - -getConstructorReference :: (MonadGet m) => m ConstructorReference -getConstructorReference = - ConstructorReference <$> getReference <*> getLength - -instance Tag UPrim1 where - tag2word DECI = 0 - tag2word INCI = 1 - tag2word NEGI = 2 - tag2word SGNI = 3 - tag2word LZRO = 4 - tag2word TZRO = 5 - tag2word COMN = 6 - tag2word POPC = 7 - tag2word ABSF = 8 - tag2word EXPF = 9 - tag2word LOGF = 10 - tag2word SQRT = 11 - tag2word COSF = 12 - tag2word ACOS = 13 - tag2word COSH = 14 - tag2word ACSH = 15 - tag2word SINF = 16 - tag2word ASIN = 17 - tag2word SINH = 18 - tag2word ASNH = 19 - tag2word TANF = 20 - tag2word ATAN = 21 - tag2word TANH = 22 - tag2word ATNH = 23 - tag2word ITOF = 24 - tag2word NTOF = 25 - tag2word CEIL = 26 - tag2word FLOR = 27 - tag2word TRNF = 28 - tag2word RNDF = 29 - - word2tag 0 = pure DECI - word2tag 1 = pure INCI - word2tag 2 = pure NEGI - word2tag 3 = pure SGNI - word2tag 4 = pure LZRO - word2tag 5 = pure TZRO - word2tag 6 = pure COMN - word2tag 7 = pure POPC - word2tag 8 = pure ABSF - word2tag 9 = pure EXPF - word2tag 10 = pure LOGF - word2tag 11 = pure SQRT - word2tag 12 = pure COSF - word2tag 13 = pure ACOS - word2tag 14 = pure COSH - word2tag 15 = pure ACSH - word2tag 16 = pure SINF - word2tag 17 = pure ASIN - word2tag 18 = pure SINH - word2tag 19 = pure ASNH - word2tag 20 = pure TANF - word2tag 21 = pure ATAN - word2tag 22 = pure TANH - word2tag 23 = pure ATNH - word2tag 24 = pure ITOF - word2tag 25 = pure NTOF - word2tag 26 = pure CEIL - word2tag 27 = pure FLOR - word2tag 28 = pure TRNF - word2tag 29 = pure RNDF - word2tag n = unknownTag "UPrim1" n - -instance Tag UPrim2 where - tag2word ADDI = 0 - tag2word SUBI = 1 - tag2word MULI = 2 - tag2word DIVI = 3 - tag2word MODI = 4 - tag2word DIVN = 5 - tag2word MODN = 6 - tag2word SHLI = 7 - tag2word SHRI = 8 - tag2word SHRN = 9 - tag2word POWI = 10 - tag2word EQLI = 11 - tag2word LEQI = 12 - tag2word LEQN = 13 - tag2word ANDN = 14 - tag2word IORN = 15 - tag2word XORN = 16 - tag2word EQLF = 17 - tag2word LEQF = 18 - tag2word ADDF = 19 - tag2word SUBF = 20 - tag2word MULF = 21 - tag2word DIVF = 22 - tag2word ATN2 = 23 - tag2word POWF = 24 - tag2word LOGB = 25 - tag2word MAXF = 26 - tag2word MINF = 27 - - word2tag 0 = pure ADDI - word2tag 1 = pure SUBI - word2tag 2 = pure MULI - word2tag 3 = pure DIVI - word2tag 4 = pure MODI - word2tag 5 = pure DIVN - word2tag 6 = pure MODN - word2tag 7 = pure SHLI - word2tag 8 = pure SHRI - word2tag 9 = pure SHRN - word2tag 10 = pure POWI - word2tag 11 = pure EQLI - word2tag 12 = pure LEQI - word2tag 13 = pure LEQN - word2tag 14 = pure ANDN - word2tag 15 = pure IORN - word2tag 16 = pure XORN - word2tag 17 = pure EQLF - word2tag 18 = pure LEQF - word2tag 19 = pure ADDF - word2tag 20 = pure SUBF - word2tag 21 = pure MULF - word2tag 22 = pure DIVF - word2tag 23 = pure ATN2 - word2tag 24 = pure POWF - word2tag 25 = pure LOGB - word2tag 26 = pure MAXF - word2tag 27 = pure MINF - word2tag n = unknownTag "UPrim2" n - -instance Tag BPrim1 where - tag2word SIZT = 0 - tag2word USNC = 1 - tag2word UCNS = 2 - tag2word ITOT = 3 - tag2word NTOT = 4 - tag2word FTOT = 5 - tag2word TTOI = 6 - tag2word TTON = 7 - tag2word TTOF = 8 - tag2word PAKT = 9 - tag2word UPKT = 10 - tag2word VWLS = 11 - tag2word VWRS = 12 - tag2word SIZS = 13 - tag2word PAKB = 14 - tag2word UPKB = 15 - tag2word SIZB = 16 - tag2word FLTB = 17 - tag2word MISS = 18 - tag2word CACH = 19 - tag2word LKUP = 20 - tag2word LOAD = 21 - tag2word CVLD = 22 - tag2word VALU = 23 - tag2word TLTT = 24 - tag2word DBTX = 25 - tag2word SDBL = 26 - - word2tag 0 = pure SIZT - word2tag 1 = pure USNC - word2tag 2 = pure UCNS - word2tag 3 = pure ITOT - word2tag 4 = pure NTOT - word2tag 5 = pure FTOT - word2tag 6 = pure TTOI - word2tag 7 = pure TTON - word2tag 8 = pure TTOF - word2tag 9 = pure PAKT - word2tag 10 = pure UPKT - word2tag 11 = pure VWLS - word2tag 12 = pure VWRS - word2tag 13 = pure SIZS - word2tag 14 = pure PAKB - word2tag 15 = pure UPKB - word2tag 16 = pure SIZB - word2tag 17 = pure FLTB - word2tag 18 = pure MISS - word2tag 19 = pure CACH - word2tag 20 = pure LKUP - word2tag 21 = pure LOAD - word2tag 22 = pure CVLD - word2tag 23 = pure VALU - word2tag 24 = pure TLTT - word2tag 25 = pure DBTX - word2tag 26 = pure SDBL - word2tag n = unknownTag "BPrim1" n - -instance Tag BPrim2 where - tag2word EQLU = 0 - tag2word CMPU = 1 - tag2word DRPT = 2 - tag2word CATT = 3 - tag2word TAKT = 4 - tag2word EQLT = 5 - tag2word LEQT = 6 - tag2word LEST = 7 - tag2word DRPS = 8 - tag2word CATS = 9 - tag2word TAKS = 10 - tag2word CONS = 11 - tag2word SNOC = 12 - tag2word IDXS = 13 - tag2word SPLL = 14 - tag2word SPLR = 15 - tag2word TAKB = 16 - tag2word DRPB = 17 - tag2word IDXB = 18 - tag2word CATB = 19 - tag2word THRO = 20 - tag2word TRCE = 21 - tag2word SDBX = 22 - tag2word IXOT = 23 - tag2word IXOB = 24 - tag2word SDBV = 25 - - word2tag 0 = pure EQLU - word2tag 1 = pure CMPU - word2tag 2 = pure DRPT - word2tag 3 = pure CATT - word2tag 4 = pure TAKT - word2tag 5 = pure EQLT - word2tag 6 = pure LEQT - word2tag 7 = pure LEST - word2tag 8 = pure DRPS - word2tag 9 = pure CATS - word2tag 10 = pure TAKS - word2tag 11 = pure CONS - word2tag 12 = pure SNOC - word2tag 13 = pure IDXS - word2tag 14 = pure SPLL - word2tag 15 = pure SPLR - word2tag 16 = pure TAKB - word2tag 17 = pure DRPB - word2tag 18 = pure IDXB - word2tag 19 = pure CATB - word2tag 20 = pure THRO - word2tag 21 = pure TRCE - word2tag 22 = pure SDBX - word2tag 23 = pure IXOT - word2tag 24 = pure IXOB - word2tag 25 = pure SDBV - word2tag n = unknownTag "BPrim2" n diff --git a/parser-typechecker/src/Unison/Runtime/Stack.hs b/parser-typechecker/src/Unison/Runtime/Stack.hs deleted file mode 100644 index ebfe67f85a..0000000000 --- a/parser-typechecker/src/Unison/Runtime/Stack.hs +++ /dev/null @@ -1,725 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Runtime.Stack - ( K (..), - Closure (.., DataC, PApV, CapV), - Callback (..), - Augment (..), - Dump (..), - MEM (..), - Stack (..), - Off, - SZ, - FP, - traceK, - frameDataSize, - marshalToForeign, - unull, - bnull, - peekD, - peekOffD, - pokeD, - pokeOffD, - peekN, - peekOffN, - pokeN, - pokeOffN, - peekBi, - peekOffBi, - pokeBi, - pokeOffBi, - peekOffS, - pokeS, - pokeOffS, - frameView, - uscount, - bscount, - closureTermRefs, - ) -where - -import Control.Monad (when) -import Control.Monad.Primitive -import Data.Foldable as F (for_) -import Data.Kind qualified as Kind -import Data.Sequence (Seq) -import Data.Word -import GHC.Exts as L (IsList (..)) -import GHC.Stack (HasCallStack) -import Unison.Reference (Reference) -import Unison.Runtime.ANF as ANF (Mem (..)) -import Unison.Runtime.Array -import Unison.Runtime.Foreign -import Unison.Runtime.MCode -import Unison.Type qualified as Ty -import Unison.Util.EnumContainers as EC -import Prelude hiding (words) - -newtype Callback = Hook (Stack 'UN -> Stack 'BX -> IO ()) - -instance Eq Callback where _ == _ = True - -instance Ord Callback where compare _ _ = EQ - --- Evaluation stack -data K - = KE - | -- callback hook - CB Callback - | -- mark continuation with a prompt - Mark - !Int -- pending unboxed args - !Int -- pending boxed args - !(EnumSet Word64) - !(EnumMap Word64 Closure) - !K - | -- save information about a frame for later resumption - Push - !Int -- unboxed frame size - !Int -- boxed frame size - !Int -- pending unboxed args - !Int -- pending boxed args - !CombIx -- local continuation reference - !K - deriving (Eq, Ord) - -data Closure - = PAp - {-# UNPACK #-} !CombIx -- reference - {-# UNPACK #-} !(Seg 'UN) -- unboxed args - {- unpack -} - !(Seg 'BX) -- boxed args - | Enum !Reference !Word64 - | DataU1 !Reference !Word64 !Int - | DataU2 !Reference !Word64 !Int !Int - | DataB1 !Reference !Word64 !Closure - | DataB2 !Reference !Word64 !Closure !Closure - | DataUB !Reference !Word64 !Int !Closure - | DataG !Reference !Word64 !(Seg 'UN) !(Seg 'BX) - | -- code cont, u/b arg size, u/b data stacks - Captured !K !Int !Int {-# UNPACK #-} !(Seg 'UN) !(Seg 'BX) - | Foreign !Foreign - | BlackHole - deriving (Show, Eq, Ord) - -traceK :: Reference -> K -> [(Reference, Int)] -traceK begin = dedup (begin, 1) - where - dedup p (Mark _ _ _ _ k) = dedup p k - dedup p@(cur, n) (Push _ _ _ _ (CIx r _ _) k) - | cur == r = dedup (cur, 1 + n) k - | otherwise = p : dedup (r, 1) k - dedup p _ = [p] - -splitData :: Closure -> Maybe (Reference, Word64, [Int], [Closure]) -splitData (Enum r t) = Just (r, t, [], []) -splitData (DataU1 r t i) = Just (r, t, [i], []) -splitData (DataU2 r t i j) = Just (r, t, [i, j], []) -splitData (DataB1 r t x) = Just (r, t, [], [x]) -splitData (DataB2 r t x y) = Just (r, t, [], [x, y]) -splitData (DataUB r t i y) = Just (r, t, [i], [y]) -splitData (DataG r t us bs) = Just (r, t, ints us, bsegToList bs) -splitData _ = Nothing - --- | Converts an unboxed segment to a list of integers for a more interchangeable --- representation. The segments are stored in backwards order, so this reverses --- the contents. -ints :: ByteArray -> [Int] -ints ba = fmap (indexByteArray ba) [n - 1, n - 2 .. 0] - where - n = sizeofByteArray ba `div` 8 - --- | Converts a list of integers representing an unboxed segment back into the --- appropriate segment. Segments are stored backwards in the runtime, so this --- reverses the list. -useg :: [Int] -> Seg 'UN -useg ws = case L.fromList $ reverse ws of - PrimArray ba -> ByteArray ba - --- | Converts a boxed segment to a list of closures. The segments are stored --- backwards, so this reverses the contents. -bsegToList :: Seg 'BX -> [Closure] -bsegToList = reverse . L.toList - --- | Converts a list of closures back to a boxed segment. Segments are stored --- backwards, so this reverses the contents. -bseg :: [Closure] -> Seg 'BX -bseg = L.fromList . reverse - -formData :: Reference -> Word64 -> [Int] -> [Closure] -> Closure -formData r t [] [] = Enum r t -formData r t [i] [] = DataU1 r t i -formData r t [i, j] [] = DataU2 r t i j -formData r t [] [x] = DataB1 r t x -formData r t [] [x, y] = DataB2 r t x y -formData r t [i] [x] = DataUB r t i x -formData r t us bs = DataG r t (useg us) (bseg bs) - -frameDataSize :: K -> (Int, Int) -frameDataSize = go 0 0 - where - go usz bsz KE = (usz, bsz) - go usz bsz (CB _) = (usz, bsz) - go usz bsz (Mark ua ba _ _ k) = go (usz + ua) (bsz + ba) k - go usz bsz (Push uf bf ua ba _ k) = go (usz + uf + ua) (bsz + bf + ba) k - -pattern DataC :: Reference -> Word64 -> [Int] -> [Closure] -> Closure -pattern DataC rf ct us bs <- - (splitData -> Just (rf, ct, us, bs)) - where - DataC rf ct us bs = formData rf ct us bs - -pattern PApV :: CombIx -> [Int] -> [Closure] -> Closure -pattern PApV ic us bs <- - PAp ic (ints -> us) (bsegToList -> bs) - where - PApV ic us bs = PAp ic (useg us) (bseg bs) - -pattern CapV :: K -> Int -> Int -> [Int] -> [Closure] -> Closure -pattern CapV k ua ba us bs <- - Captured k ua ba (ints -> us) (bsegToList -> bs) - where - CapV k ua ba us bs = Captured k ua ba (useg us) (bseg bs) - -{-# COMPLETE DataC, PAp, Captured, Foreign, BlackHole #-} - -{-# COMPLETE DataC, PApV, Captured, Foreign, BlackHole #-} - -{-# COMPLETE DataC, PApV, CapV, Foreign, BlackHole #-} - -marshalToForeign :: (HasCallStack) => Closure -> Foreign -marshalToForeign (Foreign x) = x -marshalToForeign c = - error $ "marshalToForeign: unhandled closure: " ++ show c - -type Off = Int - -type SZ = Int - -type FP = Int - -type UA = MutableByteArray (PrimState IO) - -type BA = MutableArray (PrimState IO) Closure - -words :: Int -> Int -words n = n `div` 8 - -bytes :: Int -> Int -bytes n = n * 8 - -uargOnto :: UA -> Off -> UA -> Off -> Args' -> IO Int -uargOnto stk sp cop cp0 (Arg1 i) = do - (x :: Int) <- readByteArray stk (sp - i) - writeByteArray cop cp x - pure cp - where - cp = cp0 + 1 -uargOnto stk sp cop cp0 (Arg2 i j) = do - (x :: Int) <- readByteArray stk (sp - i) - (y :: Int) <- readByteArray stk (sp - j) - writeByteArray cop cp x - writeByteArray cop (cp - 1) y - pure cp - where - cp = cp0 + 2 -uargOnto stk sp cop cp0 (ArgN v) = do - buf <- - if overwrite - then newByteArray $ bytes sz - else pure cop - let loop i - | i < 0 = return () - | otherwise = do - (x :: Int) <- readByteArray stk (sp - indexPrimArray v i) - writeByteArray buf (boff - i) x - loop $ i - 1 - loop $ sz - 1 - when overwrite $ - copyMutableByteArray cop (bytes $ cp + 1) buf 0 (bytes sz) - pure cp - where - cp = cp0 + sz - sz = sizeofPrimArray v - overwrite = sameMutableByteArray stk cop - boff | overwrite = sz - 1 | otherwise = cp0 + sz -uargOnto stk sp cop cp0 (ArgR i l) = do - moveByteArray cop cbp stk sbp (bytes l) - pure $ cp0 + l - where - cbp = bytes $ cp0 + 1 - sbp = bytes $ sp - i - l + 1 - -bargOnto :: BA -> Off -> BA -> Off -> Args' -> IO Int -bargOnto stk sp cop cp0 (Arg1 i) = do - x <- readArray stk (sp - i) - writeArray cop cp x - pure cp - where - cp = cp0 + 1 -bargOnto stk sp cop cp0 (Arg2 i j) = do - x <- readArray stk (sp - i) - y <- readArray stk (sp - j) - writeArray cop cp x - writeArray cop (cp - 1) y - pure cp - where - cp = cp0 + 2 -bargOnto stk sp cop cp0 (ArgN v) = do - buf <- - if overwrite - then newArray sz BlackHole - else pure cop - let loop i - | i < 0 = return () - | otherwise = do - x <- readArray stk $ sp - indexPrimArray v i - writeArray buf (boff - i) x - loop $ i - 1 - loop $ sz - 1 - - when overwrite $ - copyMutableArray cop (cp0 + 1) buf 0 sz - pure cp - where - cp = cp0 + sz - sz = sizeofPrimArray v - overwrite = stk == cop - boff | overwrite = sz - 1 | otherwise = cp0 + sz -bargOnto stk sp cop cp0 (ArgR i l) = do - copyMutableArray cop (cp0 + 1) stk (sp - i - l + 1) l - pure $ cp0 + l - -data Dump = A | F Int Int | S - -dumpAP :: Int -> Int -> Int -> Dump -> Int -dumpAP _ fp sz d@(F _ a) = dumpFP fp sz d - a -dumpAP ap _ _ _ = ap - -dumpFP :: Int -> Int -> Dump -> Int -dumpFP fp _ S = fp -dumpFP fp sz A = fp + sz -dumpFP fp sz (F n _) = fp + sz - n - --- closure augmentation mode --- instruction, kontinuation, call -data Augment = I | K | C - -class MEM (b :: Mem) where - data Stack b :: Kind.Type - type Elem b :: Kind.Type - type Seg b :: Kind.Type - alloc :: IO (Stack b) - peek :: Stack b -> IO (Elem b) - peekOff :: Stack b -> Off -> IO (Elem b) - poke :: Stack b -> Elem b -> IO () - pokeOff :: Stack b -> Off -> Elem b -> IO () - grab :: Stack b -> SZ -> IO (Seg b, Stack b) - ensure :: Stack b -> SZ -> IO (Stack b) - bump :: Stack b -> IO (Stack b) - bumpn :: Stack b -> SZ -> IO (Stack b) - duplicate :: Stack b -> IO (Stack b) - discardFrame :: Stack b -> IO (Stack b) - saveFrame :: Stack b -> IO (Stack b, SZ, SZ) - saveArgs :: Stack b -> IO (Stack b, SZ) - restoreFrame :: Stack b -> SZ -> SZ -> IO (Stack b) - prepareArgs :: Stack b -> Args' -> IO (Stack b) - acceptArgs :: Stack b -> Int -> IO (Stack b) - frameArgs :: Stack b -> IO (Stack b) - augSeg :: Augment -> Stack b -> Seg b -> Maybe Args' -> IO (Seg b) - dumpSeg :: Stack b -> Seg b -> Dump -> IO (Stack b) - adjustArgs :: Stack b -> SZ -> IO (Stack b) - fsize :: Stack b -> SZ - asize :: Stack b -> SZ - -instance MEM 'UN where - data Stack 'UN = - -- Note: uap <= ufp <= usp - US - { uap :: !Int, -- arg pointer - ufp :: !Int, -- frame pointer - usp :: !Int, -- stack pointer - ustk :: {-# UNPACK #-} !(MutableByteArray (PrimState IO)) - } - type Elem 'UN = Int - type Seg 'UN = ByteArray - alloc = US (-1) (-1) (-1) <$> newByteArray 4096 - {-# INLINE alloc #-} - peek (US _ _ sp stk) = readByteArray stk sp - {-# INLINE peek #-} - peekOff (US _ _ sp stk) i = readByteArray stk (sp - i) - {-# INLINE peekOff #-} - poke (US _ _ sp stk) n = writeByteArray stk sp n - {-# INLINE poke #-} - pokeOff (US _ _ sp stk) i n = writeByteArray stk (sp - i) n - {-# INLINE pokeOff #-} - - -- Eats up arguments - grab (US _ fp sp stk) sze = do - mut <- newByteArray sz - copyMutableByteArray mut 0 stk (bfp - sz) sz - seg <- unsafeFreezeByteArray mut - moveByteArray stk (bfp - sz) stk bfp fsz - pure (seg, US (fp - sze) (fp - sze) (sp - sze) stk) - where - sz = bytes sze - bfp = bytes $ fp + 1 - fsz = bytes $ sp - fp - {-# INLINE grab #-} - - ensure stki@(US ap fp sp stk) sze - | sze <= 0 || bytes (sp + sze + 1) < ssz = pure stki - | otherwise = do - stk' <- resizeMutableByteArray stk (ssz + ext) - pure $ US ap fp sp stk' - where - ssz = sizeofMutableByteArray stk - ext - | bytes sze > 10240 = bytes sze + 4096 - | otherwise = 10240 - {-# INLINE ensure #-} - - bump (US ap fp sp stk) = pure $ US ap fp (sp + 1) stk - {-# INLINE bump #-} - - bumpn (US ap fp sp stk) n = pure $ US ap fp (sp + n) stk - {-# INLINE bumpn #-} - - duplicate (US ap fp sp stk) = - US ap fp sp <$> do - b <- newByteArray sz - copyMutableByteArray b 0 stk 0 sz - pure b - where - sz = sizeofMutableByteArray stk - {-# INLINE duplicate #-} - - discardFrame (US ap fp _ stk) = pure $ US ap fp fp stk - {-# INLINE discardFrame #-} - - saveFrame (US ap fp sp stk) = pure (US sp sp sp stk, sp - fp, fp - ap) - {-# INLINE saveFrame #-} - - saveArgs (US ap fp sp stk) = pure (US fp fp sp stk, fp - ap) - {-# INLINE saveArgs #-} - - restoreFrame (US _ fp0 sp stk) fsz asz = pure $ US ap fp sp stk - where - fp = fp0 - fsz - ap = fp - asz - {-# INLINE restoreFrame #-} - - prepareArgs (US ap fp sp stk) (ArgR i l) - | fp + l + i == sp = pure $ US ap (sp - i) (sp - i) stk - prepareArgs (US ap fp sp stk) args = do - sp <- uargOnto stk sp stk fp args - pure $ US ap sp sp stk - {-# INLINE prepareArgs #-} - - acceptArgs (US ap fp sp stk) n = pure $ US ap (fp - n) sp stk - {-# INLINE acceptArgs #-} - - frameArgs (US ap _ sp stk) = pure $ US ap ap sp stk - {-# INLINE frameArgs #-} - - augSeg mode (US ap fp sp stk) seg margs = do - cop <- newByteArray $ ssz + psz + asz - copyByteArray cop soff seg 0 ssz - copyMutableByteArray cop 0 stk (bytes $ ap + 1) psz - for_ margs $ uargOnto stk sp cop (words poff + pix - 1) - unsafeFreezeByteArray cop - where - ssz = sizeofByteArray seg - pix | I <- mode = 0 | otherwise = fp - ap - (poff, soff) - | K <- mode = (ssz, 0) - | otherwise = (0, psz + asz) - psz = bytes pix - asz = case margs of - Nothing -> 0 - Just (Arg1 _) -> 8 - Just (Arg2 _ _) -> 16 - Just (ArgN v) -> bytes $ sizeofPrimArray v - Just (ArgR _ l) -> bytes l - {-# INLINE augSeg #-} - - dumpSeg (US ap fp sp stk) seg mode = do - copyByteArray stk bsp seg 0 ssz - pure $ US ap' fp' sp' stk - where - bsp = bytes $ sp + 1 - ssz = sizeofByteArray seg - sz = words ssz - sp' = sp + sz - fp' = dumpFP fp sz mode - ap' = dumpAP ap fp sz mode - {-# INLINE dumpSeg #-} - - adjustArgs (US ap fp sp stk) sz = pure $ US (ap - sz) fp sp stk - {-# INLINE adjustArgs #-} - - fsize (US _ fp sp _) = sp - fp - {-# INLINE fsize #-} - - asize (US ap fp _ _) = fp - ap - {-# INLINE asize #-} - -peekN :: Stack 'UN -> IO Word64 -peekN (US _ _ sp stk) = readByteArray stk sp -{-# INLINE peekN #-} - -peekD :: Stack 'UN -> IO Double -peekD (US _ _ sp stk) = readByteArray stk sp -{-# INLINE peekD #-} - -peekOffN :: Stack 'UN -> Int -> IO Word64 -peekOffN (US _ _ sp stk) i = readByteArray stk (sp - i) -{-# INLINE peekOffN #-} - -peekOffD :: Stack 'UN -> Int -> IO Double -peekOffD (US _ _ sp stk) i = readByteArray stk (sp - i) -{-# INLINE peekOffD #-} - -pokeN :: Stack 'UN -> Word64 -> IO () -pokeN (US _ _ sp stk) n = writeByteArray stk sp n -{-# INLINE pokeN #-} - -pokeD :: Stack 'UN -> Double -> IO () -pokeD (US _ _ sp stk) d = writeByteArray stk sp d -{-# INLINE pokeD #-} - -pokeOffN :: Stack 'UN -> Int -> Word64 -> IO () -pokeOffN (US _ _ sp stk) i n = writeByteArray stk (sp - i) n -{-# INLINE pokeOffN #-} - -pokeOffD :: Stack 'UN -> Int -> Double -> IO () -pokeOffD (US _ _ sp stk) i d = writeByteArray stk (sp - i) d -{-# INLINE pokeOffD #-} - -pokeBi :: (BuiltinForeign b) => Stack 'BX -> b -> IO () -pokeBi bstk x = poke bstk (Foreign $ wrapBuiltin x) -{-# INLINE pokeBi #-} - -pokeOffBi :: (BuiltinForeign b) => Stack 'BX -> Int -> b -> IO () -pokeOffBi bstk i x = pokeOff bstk i (Foreign $ wrapBuiltin x) -{-# INLINE pokeOffBi #-} - -peekBi :: (BuiltinForeign b) => Stack 'BX -> IO b -peekBi bstk = unwrapForeign . marshalToForeign <$> peek bstk -{-# INLINE peekBi #-} - -peekOffBi :: (BuiltinForeign b) => Stack 'BX -> Int -> IO b -peekOffBi bstk i = unwrapForeign . marshalToForeign <$> peekOff bstk i -{-# INLINE peekOffBi #-} - -peekOffS :: Stack 'BX -> Int -> IO (Seq Closure) -peekOffS bstk i = - unwrapForeign . marshalToForeign <$> peekOff bstk i -{-# INLINE peekOffS #-} - -pokeS :: Stack 'BX -> Seq Closure -> IO () -pokeS bstk s = poke bstk (Foreign $ Wrap Ty.listRef s) -{-# INLINE pokeS #-} - -pokeOffS :: Stack 'BX -> Int -> Seq Closure -> IO () -pokeOffS bstk i s = pokeOff bstk i (Foreign $ Wrap Ty.listRef s) -{-# INLINE pokeOffS #-} - -unull :: Seg 'UN -unull = byteArrayFromListN 0 ([] :: [Int]) - -bnull :: Seg 'BX -bnull = fromListN 0 [] - -instance Show (Stack 'BX) where - show (BS ap fp sp _) = - "BS " ++ show ap ++ " " ++ show fp ++ " " ++ show sp - -instance Show (Stack 'UN) where - show (US ap fp sp _) = - "US " ++ show ap ++ " " ++ show fp ++ " " ++ show sp - -instance Show K where - show k = "[" ++ go "" k - where - go _ KE = "]" - go _ (CB _) = "]" - go com (Push uf bf ua ba ci k) = - com ++ show (uf, bf, ua, ba, ci) ++ go "," k - go com (Mark ua ba ps _ k) = - com ++ "M " ++ show ua ++ " " ++ show ba ++ " " ++ show ps ++ go "," k - -instance MEM 'BX where - data Stack 'BX = BS - { bap :: !Int, - bfp :: !Int, - bsp :: !Int, - bstk :: {-# UNPACK #-} !(MutableArray (PrimState IO) Closure) - } - type Elem 'BX = Closure - type Seg 'BX = Array Closure - - alloc = BS (-1) (-1) (-1) <$> newArray 512 BlackHole - {-# INLINE alloc #-} - - peek (BS _ _ sp stk) = readArray stk sp - {-# INLINE peek #-} - - peekOff (BS _ _ sp stk) i = readArray stk (sp - i) - {-# INLINE peekOff #-} - - poke (BS _ _ sp stk) x = writeArray stk sp x - {-# INLINE poke #-} - - pokeOff (BS _ _ sp stk) i x = writeArray stk (sp - i) x - {-# INLINE pokeOff #-} - - grab (BS _ fp sp stk) sz = do - seg <- unsafeFreezeArray =<< cloneMutableArray stk (fp + 1 - sz) sz - copyMutableArray stk (fp + 1 - sz) stk (fp + 1) fsz - pure (seg, BS (fp - sz) (fp - sz) (sp - sz) stk) - where - fsz = sp - fp - {-# INLINE grab #-} - - ensure stki@(BS ap fp sp stk) sz - | sz <= 0 = pure stki - | sp + sz + 1 < ssz = pure stki - | otherwise = do - stk' <- newArray (ssz + ext) BlackHole - copyMutableArray stk' 0 stk 0 (sp + 1) - pure $ BS ap fp sp stk' - where - ssz = sizeofMutableArray stk - ext - | sz > 1280 = sz + 512 - | otherwise = 1280 - {-# INLINE ensure #-} - - bump (BS ap fp sp stk) = pure $ BS ap fp (sp + 1) stk - {-# INLINE bump #-} - - bumpn (BS ap fp sp stk) n = pure $ BS ap fp (sp + n) stk - {-# INLINE bumpn #-} - - duplicate (BS ap fp sp stk) = - BS ap fp sp <$> cloneMutableArray stk 0 (sizeofMutableArray stk) - {-# INLINE duplicate #-} - - discardFrame (BS ap fp _ stk) = pure $ BS ap fp fp stk - {-# INLINE discardFrame #-} - - saveFrame (BS ap fp sp stk) = pure (BS sp sp sp stk, sp - fp, fp - ap) - {-# INLINE saveFrame #-} - - saveArgs (BS ap fp sp stk) = pure (BS fp fp sp stk, fp - ap) - {-# INLINE saveArgs #-} - - restoreFrame (BS _ fp0 sp stk) fsz asz = pure $ BS ap fp sp stk - where - fp = fp0 - fsz - ap = fp - asz - {-# INLINE restoreFrame #-} - - prepareArgs (BS ap fp sp stk) (ArgR i l) - | fp + i + l == sp = pure $ BS ap (sp - i) (sp - i) stk - prepareArgs (BS ap fp sp stk) args = do - sp <- bargOnto stk sp stk fp args - pure $ BS ap sp sp stk - {-# INLINE prepareArgs #-} - - acceptArgs (BS ap fp sp stk) n = pure $ BS ap (fp - n) sp stk - {-# INLINE acceptArgs #-} - - frameArgs (BS ap _ sp stk) = pure $ BS ap ap sp stk - {-# INLINE frameArgs #-} - - augSeg mode (BS ap fp sp stk) seg margs = do - cop <- newArray (ssz + psz + asz) BlackHole - copyArray cop soff seg 0 ssz - copyMutableArray cop poff stk (ap + 1) psz - for_ margs $ bargOnto stk sp cop (poff + psz - 1) - unsafeFreezeArray cop - where - ssz = sizeofArray seg - psz | I <- mode = 0 | otherwise = fp - ap - (poff, soff) - | K <- mode = (ssz, 0) - | otherwise = (0, psz + asz) - asz = case margs of - Nothing -> 0 - Just (Arg1 _) -> 1 - Just (Arg2 _ _) -> 2 - Just (ArgN v) -> sizeofPrimArray v - Just (ArgR _ l) -> l - {-# INLINE augSeg #-} - - dumpSeg (BS ap fp sp stk) seg mode = do - copyArray stk (sp + 1) seg 0 sz - pure $ BS ap' fp' sp' stk - where - sz = sizeofArray seg - sp' = sp + sz - fp' = dumpFP fp sz mode - ap' = dumpAP ap fp sz mode - {-# INLINE dumpSeg #-} - - adjustArgs (BS ap fp sp stk) sz = pure $ BS (ap - sz) fp sp stk - {-# INLINE adjustArgs #-} - - fsize (BS _ fp sp _) = sp - fp - {-# INLINE fsize #-} - - asize (BS ap fp _ _) = fp - ap - -frameView :: (MEM b) => (Show (Elem b)) => Stack b -> IO () -frameView stk = putStr "|" >> gof False 0 - where - fsz = fsize stk - asz = asize stk - gof delim n - | n >= fsz = putStr "|" >> goa False 0 - | otherwise = do - when delim $ putStr "," - putStr . show =<< peekOff stk n - gof True (n + 1) - goa delim n - | n >= asz = putStrLn "|.." - | otherwise = do - when delim $ putStr "," - putStr . show =<< peekOff stk (fsz + n) - goa True (n + 1) - -uscount :: Seg 'UN -> Int -uscount seg = words $ sizeofByteArray seg - -bscount :: Seg 'BX -> Int -bscount seg = sizeofArray seg - -closureTermRefs :: (Monoid m) => (Reference -> m) -> (Closure -> m) -closureTermRefs f (PAp (CIx r _ _) _ cs) = - f r <> foldMap (closureTermRefs f) cs -closureTermRefs f (DataB1 _ _ c) = closureTermRefs f c -closureTermRefs f (DataB2 _ _ c1 c2) = - closureTermRefs f c1 <> closureTermRefs f c2 -closureTermRefs f (DataUB _ _ _ c) = - closureTermRefs f c -closureTermRefs f (Captured k _ _ _ cs) = - contTermRefs f k <> foldMap (closureTermRefs f) cs -closureTermRefs f (Foreign fo) - | Just (cs :: Seq Closure) <- maybeUnwrapForeign Ty.listRef fo = - foldMap (closureTermRefs f) cs -closureTermRefs _ _ = mempty - -contTermRefs :: (Monoid m) => (Reference -> m) -> K -> m -contTermRefs f (Mark _ _ _ m k) = - foldMap (closureTermRefs f) m <> contTermRefs f k -contTermRefs f (Push _ _ _ _ (CIx r _ _) k) = - f r <> contTermRefs f k -contTermRefs _ _ = mempty diff --git a/parser-typechecker/src/Unison/Syntax/DeclParser.hs b/parser-typechecker/src/Unison/Syntax/DeclParser.hs index 38b5d0d2a8..1f2e4f564e 100644 --- a/parser-typechecker/src/Unison/Syntax/DeclParser.hs +++ b/parser-typechecker/src/Unison/Syntax/DeclParser.hs @@ -1,17 +1,18 @@ module Unison.Syntax.DeclParser - ( declarations, + ( synDeclsP, + SynDecl (..), + synDeclConstructors, + synDeclName, + SynDataDecl (..), + SynEffectDecl (..), ) where import Control.Lens -import Control.Monad.Reader (MonadReader (..)) import Data.List.NonEmpty (pattern (:|)) import Data.List.NonEmpty qualified as NonEmpty -import Data.Map qualified as Map -import Text.Megaparsec qualified as P import Unison.ABT qualified as ABT -import Unison.DataDeclaration (DataDeclaration, EffectDeclaration) -import Unison.DataDeclaration qualified as DD +import Unison.DataDeclaration qualified as DataDeclaration import Unison.Name qualified as Name import Unison.Parser.Ann (Ann) import Unison.Prelude @@ -27,45 +28,47 @@ import Unison.Var (Var) import Unison.Var qualified as Var (name, named) import Prelude hiding (readFile) --- The parsed form of record accessors, as in: --- --- type Additive a = { zero : a, (+) : a -> a -> a } --- --- The `Token v` is the variable name and location (here `zero` and `(+)`) of --- each field, and the type is the type of that field -type Accessors v = [(L.Token v, [(L.Token v, Type v Ann)])] +data SynDecl v + = SynDecl'Data !(SynDataDecl v) + | SynDecl'Effect !(SynEffectDecl v) -declarations :: - (Monad m, Var v) => - P - v - m - ( Map v (DataDeclaration v Ann), - Map v (EffectDeclaration v Ann), - Accessors v - ) -declarations = do - declarations <- many $ declaration <* optional semi - let (dataDecls0, effectDecls) = partitionEithers declarations - dataDecls = [(a, b) | (a, b, _) <- dataDecls0] - multimap :: (Ord k) => [(k, v)] -> Map k [v] - multimap = foldl' mi Map.empty - mi m (k, v) = Map.insertWith (++) k [v] m - mds = multimap dataDecls - mes = multimap effectDecls - mdsBad = Map.filter (\xs -> length xs /= 1) mds - mesBad = Map.filter (\xs -> length xs /= 1) mes - if Map.null mdsBad && Map.null mesBad - then - pure - ( Map.fromList dataDecls, - Map.fromList effectDecls, - join . map (view _3) $ dataDecls0 - ) - else - P.customFailure . DuplicateTypeNames $ - [(v, DD.annotation <$> ds) | (v, ds) <- Map.toList mdsBad] - <> [(v, DD.annotation . DD.toDataDecl <$> es) | (v, es) <- Map.toList mesBad] +instance Annotated (SynDecl v) where + ann = \case + SynDecl'Data decl -> decl.annotation + SynDecl'Effect decl -> decl.annotation + +synDeclConstructors :: SynDecl v -> [(Ann, v, Type v Ann)] +synDeclConstructors = \case + SynDecl'Data decl -> decl.constructors + SynDecl'Effect decl -> decl.constructors + +synDeclName :: SynDecl v -> L.Token v +synDeclName = \case + SynDecl'Data decl -> decl.name + SynDecl'Effect decl -> decl.name + +data SynDataDecl v = SynDataDecl + { annotation :: !Ann, + constructors :: ![(Ann, v, Type v Ann)], + fields :: !(Maybe [(L.Token v, Type v Ann)]), + modifier :: !DataDeclaration.Modifier, + name :: !(L.Token v), + tyvars :: ![v] + } + deriving stock (Generic) + +data SynEffectDecl v = SynEffectDecl + { annotation :: !Ann, + constructors :: ![(Ann, v, Type v Ann)], + modifier :: !DataDeclaration.Modifier, + name :: !(L.Token v), + tyvars :: ![v] + } + deriving stock (Generic) + +synDeclsP :: (Monad m, Var v) => P v m [SynDecl v] +synDeclsP = + many (synDeclP <* optional semi) -- | When we first walk over the modifier, it may be a `unique`, in which case we want to use a function in the parsing -- environment to map the type's name (which we haven't parsed yet) to a GUID to reuse (if any). @@ -75,80 +78,32 @@ declarations = do data UnresolvedModifier = UnresolvedModifier'Structural | UnresolvedModifier'UniqueWithGuid !Text - | -- The Text here is a random GUID that we *may not end up using*, as in the case when we instead have a GUID to - -- reuse (which we will discover soon, once we parse this unique type's name and pass it into the `uniqueTypeGuid` - -- function in the parser environment). - -- - -- However, we generate this GUID anyway for backwards-compatibility with *transcripts*. Since the GUID we assign - -- is a function of the current source location in the parser state, if we generate it later (after moving a few - -- tokens ahead to the type's name), then we'll get a different value. - -- - -- This is only done to make the transcript diff smaller and easier to review, as the PR that adds this GUID-reuse - -- feature ought not to change any hashes. However, at any point after it lands in trunk, this Text could be - -- removed from this constructor, the generation of these GUIDs could be delayed until we actually need them, and - -- the transcripts could all be re-generated. - UnresolvedModifier'UniqueWithoutGuid !Text - -resolveUnresolvedModifier :: (Monad m, Var v) => L.Token UnresolvedModifier -> v -> P v m (L.Token DD.Modifier) -resolveUnresolvedModifier unresolvedModifier var = - case L.payload unresolvedModifier of - UnresolvedModifier'Structural -> pure (DD.Structural <$ unresolvedModifier) - UnresolvedModifier'UniqueWithGuid guid -> pure (DD.Unique guid <$ unresolvedModifier) - UnresolvedModifier'UniqueWithoutGuid guid0 -> do - unique <- resolveUniqueModifier var guid0 - pure $ unique <$ unresolvedModifier - -resolveUniqueModifier :: (Monad m, Var v) => v -> Text -> P v m DD.Modifier -resolveUniqueModifier var guid0 = do - ParsingEnv {uniqueTypeGuid} <- ask - guid <- fromMaybe guid0 <$> lift (lift (uniqueTypeGuid (Name.unsafeParseVar var))) - pure $ DD.Unique guid - -defaultUniqueModifier :: (Monad m, Var v) => v -> P v m DD.Modifier -defaultUniqueModifier var = - uniqueName 32 >>= resolveUniqueModifier var + | UnresolvedModifier'UniqueWithoutGuid -- unique[someguid] type Blah = ... -modifier :: (Monad m, Var v) => P v m (Maybe (L.Token UnresolvedModifier)) -modifier = do +modifierP :: (Monad m, Var v) => P v m (Maybe (L.Token UnresolvedModifier)) +modifierP = do optional (unique <|> structural) where unique = do tok <- openBlockWith "unique" optional (openBlockWith "[" *> importWordyId <* closeBlock) >>= \case - Nothing -> do - guid <- uniqueName 32 - pure (UnresolvedModifier'UniqueWithoutGuid guid <$ tok) + Nothing -> pure (UnresolvedModifier'UniqueWithoutGuid <$ tok) Just guid -> pure (UnresolvedModifier'UniqueWithGuid (Name.toText (L.payload guid)) <$ tok) structural = do tok <- openBlockWith "structural" pure (UnresolvedModifier'Structural <$ tok) -declaration :: - (Monad m, Var v) => - P - v - m - ( Either - (v, DataDeclaration v Ann, Accessors v) - (v, EffectDeclaration v Ann) - ) -declaration = do - mod <- modifier - fmap Right (effectDeclaration mod) <|> fmap Left (dataDeclaration mod) +synDeclP :: (Monad m, Var v) => P v m (SynDecl v) +synDeclP = do + modifier <- modifierP + SynDecl'Effect <$> synEffectDeclP modifier <|> SynDecl'Data <$> synDataDeclP modifier -dataDeclaration :: - forall m v. - (Monad m, Var v) => - Maybe (L.Token UnresolvedModifier) -> - P v m (v, DataDeclaration v Ann, Accessors v) -dataDeclaration maybeUnresolvedModifier = do +synDataDeclP :: forall m v. (Monad m, Var v) => Maybe (L.Token UnresolvedModifier) -> P v m (SynDataDecl v) +synDataDeclP modifier0 = do typeToken <- fmap void (reserved "type") <|> openBlockWith "type" - (name, typeArgs) <- - (,) - <$> TermParser.verifyRelativeVarName prefixDefinitionName - <*> many (TermParser.verifyRelativeVarName prefixDefinitionName) - let typeArgVs = L.payload <$> typeArgs + (name, typeArgs) <- (,) <$> prefixVar <*> many prefixVar + let tyvars = L.payload <$> typeArgs eq <- reserved "=" let -- go gives the type of the constructor, given the types of -- the constructor arguments, e.g. Cons becomes forall a . a -> List a -> List a @@ -161,127 +116,115 @@ dataDeclaration maybeUnresolvedModifier = do -- ctorType e.g. `a -> Optional a` -- or just `Optional a` in the case of `None` ctorType = foldr arrow ctorReturnType ctorArgs - ctorAnn = ann ctorName <> maybe (ann ctorName) ann (lastMay ctorArgs) + ctorAnn = ann ctorName <> maybe mempty ann (lastMay ctorArgs) in ( ctorAnn, ( ann ctorName, Var.namespaced (L.payload name :| [L.payload ctorName]), - Type.foralls ctorAnn typeArgVs ctorType + Type.foralls ctorAnn tyvars ctorType ) ) - prefixVar = TermParser.verifyRelativeVarName prefixDefinitionName - dataConstructor :: P v m (Ann, (Ann, v, Type v Ann)) - dataConstructor = go <$> prefixVar <*> many TypeParser.valueTypeLeaf - record :: P v m ([(Ann, (Ann, v, Type v Ann))], [(L.Token v, [(L.Token v, Type v Ann)])], Ann) + record :: P v m ((Ann, v, Type v Ann), Maybe [(L.Token v, Type v Ann)], Ann) record = do _ <- openBlockWith "{" let field :: P v m [(L.Token v, Type v Ann)] field = do f <- liftA2 (,) (prefixVar <* reserved ":") TypeParser.valueType - optional (reserved ",") - >>= ( \case - Nothing -> pure [f] - Just _ -> maybe [f] (f :) <$> (optional semi *> optional field) - ) + optional (reserved ",") >>= \case + Nothing -> pure [f] + Just _ -> maybe [f] (f :) <$> (optional semi *> optional field) fields <- field closingToken <- closeBlock let lastSegment = name <&> (\v -> Var.named (Name.toText $ Name.unqualified (Name.unsafeParseVar v))) - pure ([go lastSegment (snd <$> fields)], [(name, fields)], ann closingToken) - (constructors, accessors, closingAnn) <- - msum [Left <$> record, Right <$> sepBy (reserved "|") dataConstructor] <&> \case - Left (constructors, accessors, closingAnn) -> (constructors, accessors, closingAnn) - Right constructors -> do - let closingAnn :: Ann - closingAnn = NonEmpty.last (ann eq NonEmpty.:| ((\(constrSpanAnn, _) -> constrSpanAnn) <$> constructors)) - in (constructors, [], closingAnn) - _ <- closeBlock - case maybeUnresolvedModifier of + pure (snd (go lastSegment (snd <$> fields)), Just fields, ann closingToken) + optional record >>= \case Nothing -> do - modifier <- defaultUniqueModifier (L.payload name) - -- ann spanning the whole Decl. - let declSpanAnn = ann typeToken <> closingAnn + constructors <- sepBy (reserved "|") (go <$> prefixVar <*> many TypeParser.valueTypeLeaf) + _ <- closeBlock + let closingAnn :: Ann + closingAnn = NonEmpty.last (ann eq NonEmpty.:| ((\(constrSpanAnn, _) -> constrSpanAnn) <$> constructors)) + modifier <- resolveModifier name modifier0 pure - ( L.payload name, - DD.mkDataDecl' modifier declSpanAnn typeArgVs (snd <$> constructors), - accessors - ) - Just unresolvedModifier -> do - modifier <- resolveUnresolvedModifier unresolvedModifier (L.payload name) - -- ann spanning the whole Decl. - -- Technically the typeToken is redundant here, but this is more future proof. - let declSpanAnn = ann typeToken <> ann modifier <> closingAnn + SynDataDecl + { annotation = maybe (ann typeToken) ann modifier0 <> closingAnn, + constructors = snd <$> constructors, + fields = Nothing, + modifier, + name, + tyvars + } + Just (constructor, fields, closingAnn) -> do + _ <- closeBlock + modifier <- resolveModifier name modifier0 pure - ( L.payload name, - DD.mkDataDecl' (L.payload modifier) declSpanAnn typeArgVs (snd <$> constructors), - accessors - ) + SynDataDecl + { annotation = maybe (ann typeToken) ann modifier0 <> closingAnn, + constructors = [constructor], + fields, + modifier, + name, + tyvars + } + where + prefixVar :: P v m (L.Token v) + prefixVar = + TermParser.verifyRelativeVarName prefixDefinitionName -effectDeclaration :: - forall m v. - (Monad m, Var v) => - Maybe (L.Token UnresolvedModifier) -> - P v m (v, EffectDeclaration v Ann) -effectDeclaration maybeUnresolvedModifier = do +synEffectDeclP :: forall m v. (Monad m, Var v) => Maybe (L.Token UnresolvedModifier) -> P v m (SynEffectDecl v) +synEffectDeclP modifier0 = do abilityToken <- fmap void (reserved "ability") <|> openBlockWith "ability" name <- TermParser.verifyRelativeVarName prefixDefinitionName typeArgs <- many (TermParser.verifyRelativeVarName prefixDefinitionName) - let typeArgVs = L.payload <$> typeArgs blockStart <- openBlockWith "where" - constructors <- sepBy semi (constructor typeArgs name) + constructors <- sepBy semi (effectConstructorP typeArgs name) -- `ability` opens a block, as does `where` _ <- closeBlock <* closeBlock let closingAnn = last $ ann blockStart : ((\(_, _, t) -> ann t) <$> constructors) + modifier <- resolveModifier name modifier0 + pure + SynEffectDecl + { annotation = maybe (ann abilityToken) ann modifier0 <> closingAnn, + constructors, + modifier, + name, + tyvars = L.payload <$> typeArgs + } - case maybeUnresolvedModifier of - Nothing -> do - modifier <- defaultUniqueModifier (L.payload name) - -- ann spanning the whole ability declaration. - let abilitySpanAnn = ann abilityToken <> closingAnn - pure - ( L.payload name, - DD.mkEffectDecl' modifier abilitySpanAnn typeArgVs constructors - ) - Just unresolvedModifier -> do - modifier <- resolveUnresolvedModifier unresolvedModifier (L.payload name) - -- ann spanning the whole ability declaration. - -- Technically the abilityToken is redundant here, but this is more future proof. - let abilitySpanAnn = ann abilityToken <> ann modifier <> closingAnn - pure - ( L.payload name, - DD.mkEffectDecl' - (L.payload modifier) - abilitySpanAnn - typeArgVs - constructors +effectConstructorP :: (Monad m, Var v) => [L.Token v] -> L.Token v -> P v m (Ann, v, Type v Ann) +effectConstructorP typeArgs name = + explodeToken + <$> TermParser.verifyRelativeVarName prefixDefinitionName + <* reserved ":" + <*> ( Type.generalizeLowercase mempty + . ensureEffect + <$> TypeParser.computationType ) where - constructor :: [L.Token v] -> L.Token v -> P v m (Ann, v, Type v Ann) - constructor typeArgs name = - explodeToken - <$> TermParser.verifyRelativeVarName prefixDefinitionName - <* reserved ":" - <*> ( Type.generalizeLowercase mempty - . ensureEffect - <$> TypeParser.computationType - ) - where - explodeToken v t = (ann v, Var.namespaced (L.payload name :| [L.payload v]), t) - -- If the effect is not syntactically present in the constructor types, - -- add them after parsing. - ensureEffect t = case t of - Type.Effect' _ _ -> modEffect t - x -> Type.editFunctionResult modEffect x - modEffect t = case t of - Type.Effect' es t -> go es t - t -> go [] t - toTypeVar t = Type.av' (ann t) (Var.name $ L.payload t) - headIs t v = case t of - Type.Apps' (Type.Var' x) _ -> x == v - Type.Var' x -> x == v - _ -> False - go es t = - let es' = - if any (`headIs` L.payload name) es - then es - else Type.apps' (toTypeVar name) (toTypeVar <$> typeArgs) : es - in Type.cleanupAbilityLists $ Type.effect (ABT.annotation t) es' t + explodeToken v t = (ann v, Var.namespaced (L.payload name :| [L.payload v]), t) + -- If the effect is not syntactically present in the constructor types, + -- add them after parsing. + ensureEffect t = case t of + Type.Effect' _ _ -> modEffect t + x -> Type.editFunctionResult modEffect x + modEffect t = case t of + Type.Effect' es t -> go es t + t -> go [] t + toTypeVar t = Type.av' (ann t) (Var.name $ L.payload t) + headIs t v = case t of + Type.Apps' (Type.Var' x) _ -> x == v + Type.Var' x -> x == v + _ -> False + go es t = + let es' = + if any (`headIs` L.payload name) es + then es + else Type.apps' (toTypeVar name) (toTypeVar <$> typeArgs) : es + in Type.cleanupAbilityLists $ Type.effect (ABT.annotation t) es' t + +resolveModifier :: (Monad m, Var v) => L.Token v -> Maybe (L.Token UnresolvedModifier) -> P v m DataDeclaration.Modifier +resolveModifier name modifier = + case L.payload <$> modifier of + Just UnresolvedModifier'Structural -> pure DataDeclaration.Structural + Just (UnresolvedModifier'UniqueWithGuid guid) -> pure (DataDeclaration.Unique guid) + Just UnresolvedModifier'UniqueWithoutGuid -> resolveUniqueTypeGuid name.payload + Nothing -> resolveUniqueTypeGuid name.payload diff --git a/parser-typechecker/src/Unison/Syntax/FileParser.hs b/parser-typechecker/src/Unison/Syntax/FileParser.hs index 9d2c7f23f3..65c217a2cb 100644 --- a/parser-typechecker/src/Unison/Syntax/FileParser.hs +++ b/parser-typechecker/src/Unison/Syntax/FileParser.hs @@ -5,33 +5,34 @@ where import Control.Lens import Control.Monad.Reader (asks, local) +import Data.Foldable (foldlM) import Data.List qualified as List -import Data.List.NonEmpty (pattern (:|)) import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text import Text.Megaparsec qualified as P import Unison.ABT qualified as ABT -import Unison.DataDeclaration (DataDeclaration, EffectDeclaration) -import Unison.DataDeclaration qualified as DD +import Unison.DataDeclaration (DataDeclaration (..), EffectDeclaration) +import Unison.DataDeclaration qualified as DataDeclaration import Unison.DataDeclaration.Records (generateRecordAccessors) import Unison.Name qualified as Name import Unison.NameSegment qualified as NameSegment import Unison.Names qualified as Names import Unison.Names.ResolutionResult qualified as Names -import Unison.NamesWithHistory qualified as Names import Unison.Parser.Ann (Ann) import Unison.Parser.Ann qualified as Ann import Unison.Prelude import Unison.Reference (TypeReferenceId) -import Unison.Syntax.DeclParser (declarations) +import Unison.Syntax.DeclParser (SynDataDecl (..), SynDecl (..), SynEffectDecl (..), synDeclConstructors, synDeclName, synDeclsP) import Unison.Syntax.Lexer qualified as L -import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar) +import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar) import Unison.Syntax.Parser import Unison.Syntax.TermParser qualified as TermParser -import Unison.Syntax.Var qualified as Var (namespaced) -import Unison.Term (Term) +import Unison.Syntax.Var qualified as Var (namespaced, namespaced2) +import Unison.Term (Term, Term2) import Unison.Term qualified as Term +import Unison.Type (Type) +import Unison.Type qualified as Type import Unison.UnisonFile (UnisonFile (..)) import Unison.UnisonFile.Env qualified as UF import Unison.UnisonFile.Names qualified as UFN @@ -42,40 +43,117 @@ import Unison.WatchKind (WatchKind) import Unison.WatchKind qualified as UF import Prelude hiding (readFile) -resolutionFailures :: (Ord v) => [Names.ResolutionFailure v Ann] -> P v m x +resolutionFailures :: (Ord v) => [Names.ResolutionFailure Ann] -> P v m x resolutionFailures es = P.customFailure (ResolutionFailures es) file :: forall m v. (Monad m, Var v) => P v m (UnisonFile v Ann) file = do _ <- openBlock + + -- Parse an optional directive like "namespace foo.bar" + maybeNamespace :: Maybe Name.Name <- + optional (reserved "namespace") >>= \case + Nothing -> pure Nothing + Just _ -> do + namespace <- importWordyId <|> importSymbolyId + void (optional semi) + pure (Just namespace.payload) + let maybeNamespaceVar = Name.toVar <$> maybeNamespace + -- The file may optionally contain top-level imports, -- which are parsed and applied to the type decls and term stanzas (namesStart, imports) <- TermParser.imports <* optional semi - (dataDecls, effectDecls, parsedAccessors) <- declarations - env <- case UFN.environmentFor namesStart dataDecls effectDecls of - Right (Right env) -> pure env - Right (Left es) -> P.customFailure $ TypeDeclarationErrors es - Left es -> resolutionFailures (toList es) - let accessors :: [[(v, Ann, Term v Ann)]] + + -- Parse all syn decls. The namespace in the parsing environment is required here in order to avoid unique type churn. + unNamespacedSynDecls <- local (\e -> e {maybeNamespace}) synDeclsP + + -- Sanity check: bail if there's a duplicate name among them + unNamespacedSynDecls + & List.map (\decl -> (L.payload (synDeclName decl), decl)) + & List.multimap + & Map.toList + & mapMaybe \case + (name, decls@(_ : _ : _)) -> Just (name, map ann decls) + _ -> Nothing + & \case + [] -> pure () + dupes -> P.customFailure (DuplicateTypeNames dupes) + + -- Apply the namespace directive (if there is one) to the decls + let synDecls = maybe id applyNamespaceToSynDecls maybeNamespaceVar unNamespacedSynDecls + + -- Compute an environment from the decls that we use to parse terms + env <- do + -- Make real data/effect decls from the "syntactic" ones + (dataDecls, effectDecls) <- synDeclsToDecls synDecls + result <- UFN.environmentFor namesStart dataDecls effectDecls & onLeft \errs -> resolutionFailures (toList errs) + result & onLeft \errs -> P.customFailure (TypeDeclarationErrors errs) + + -- Generate the record accessors with *un-namespaced* names below, because we need to know these names in order to + -- perform rewriting. As an example, + -- + -- namespace foo + -- type Bar = { baz : Nat } + -- term = ... Bar.baz ... + -- + -- we want to rename `Bar.baz` to `foo.Bar.baz`, and it seems easier to first generate un-namespaced accessors like + -- `Bar.baz`, rather than rip off the namespace from accessors like `foo.Bar.baz` (though not by much). + let unNamespacedAccessors :: [(v, Ann, Term v Ann)] + unNamespacedAccessors = + foldMap + ( \case + SynDecl'Data decl + | Just fields <- decl.fields, + Just (ref, _) <- + Map.lookup (maybe id Var.namespaced2 maybeNamespaceVar decl.name.payload) (UF.datas env) -> + generateRecordAccessors + Var.namespaced + Ann.GeneratedFrom + (toPair <$> fields) + decl.name.payload + ref + _ -> [] + ) + unNamespacedSynDecls + where + toPair (tok, typ) = (tok.payload, ann tok <> ann typ) + + let accessors :: [(v, Ann, Term v Ann)] accessors = - [ generateRecordAccessors Var.namespaced Ann.GeneratedFrom (toPair <$> fields) (L.payload typ) r - | (typ, fields) <- parsedAccessors, - Just (r, _) <- [Map.lookup (L.payload typ) (UF.datas env)] - ] - toPair (tok, typ) = (L.payload tok, ann tok <> ann typ) - let importNames = [(Name.unsafeParseVar v, Name.unsafeParseVar v2) | (v, v2) <- imports] - let locals = Names.importing importNames (UF.names env) + unNamespacedAccessors + & case maybeNamespaceVar of + Nothing -> id + Just namespace -> over (mapped . _1) (Var.namespaced2 namespace) + -- At this stage of the file parser, we've parsed all the type and ability - -- declarations. The `push locals` here has the effect - -- of making suffix-based name resolution prefer type and constructor names coming - -- from the local file. - -- - -- There's some more complicated logic below to have suffix-based name resolution - -- make use of _terms_ from the local file. - local (\e -> e {names = Names.push locals namesStart}) do + -- declarations. + let updateEnvForTermParsing e = + e + { names = Names.shadowing (UF.names env) namesStart, + maybeNamespace, + localNamespacePrefixedTypesAndConstructors = UF.names env + } + local updateEnvForTermParsing do names <- asks names - stanzas0 <- sepBy semi stanza - let stanzas = fmap (TermParser.substImports names imports) <$> stanzas0 + stanzas <- do + unNamespacedStanzas0 <- sepBy semi stanza + let unNamespacedStanzas = fmap (TermParser.substImports names imports) <$> unNamespacedStanzas0 + pure $ + unNamespacedStanzas + & case maybeNamespaceVar of + Nothing -> id + Just namespace -> + let unNamespacedTermNamespaceNames :: Set v + unNamespacedTermNamespaceNames = + Set.unions + [ -- The vars parsed from the stanzas themselves (before applying namespace directive) + Set.fromList (unNamespacedStanzas >>= getVars), + -- The un-namespaced constructor names (from the *originally-parsed* data and effect decls) + foldMap (Set.fromList . map (view _2) . synDeclConstructors) unNamespacedSynDecls, + -- The un-namespaced accessors + Set.fromList (map (view _1) unNamespacedAccessors) + ] + in map (applyNamespaceToStanza namespace unNamespacedTermNamespaceNames) _ <- closeBlock let (termsr, watchesr) = foldl' go ([], []) stanzas go (terms, watches) s = case s of @@ -89,28 +167,13 @@ file = do -- All locally declared term variables, running example: -- [foo.alice, bar.alice, zonk.bob] fqLocalTerms :: [v] - fqLocalTerms = (stanzas0 >>= getVars) <> (view _1 <$> join accessors) - -- suffixified local term bindings shadow any same-named thing from the outer codebase scope - -- example: `foo.bar` in local file scope will shadow `foo.bar` and `bar` in codebase scope - let (curNames, resolveLocals) = - ( Names.shadowTerms locals names, - resolveLocals - ) - where - -- Each unique suffix mapped to its fully qualified name - canonicalVars :: Map v v - canonicalVars = UFN.variableCanonicalizer fqLocalTerms - - -- All unique local term name suffixes - these we want to - -- avoid resolving to a term that's in the codebase - locals :: [Name.Name] - locals = (Name.unsafeParseVar <$> Map.keys canonicalVars) - - -- A function to replace unique local term suffixes with their - -- fully qualified name - replacements = [(v, Term.var () v2) | (v, v2) <- Map.toList canonicalVars, v /= v2] - resolveLocals = ABT.substsInheritAnnotation replacements - let bindNames = Term.bindSomeNames Name.unsafeParseVar (Set.fromList fqLocalTerms) curNames . resolveLocals + fqLocalTerms = (stanzas >>= getVars) <> (view _1 <$> accessors) + let bindNames = + Term.bindNames + Name.unsafeParseVar + Name.toVar + (Set.fromList fqLocalTerms) + (Names.shadowTerms (map Name.unsafeParseVar fqLocalTerms) names) terms <- case List.validate (traverseOf _3 bindNames) terms of Left es -> resolutionFailures (toList es) Right terms -> pure terms @@ -120,12 +183,109 @@ file = do validateUnisonFile (UF.datasId env) (UF.effectsId env) - (terms <> join accessors) + (terms <> accessors) (List.multimap watches) +-- | Suppose a data declaration `Foo` has a constructor `A` with fields `B` and `C`, where `B` is locally-bound and `C` +-- is not: +-- +-- @ +-- type B +-- +-- type Foo +-- constructor Foo.A : B -> C -> Foo +-- @ +-- +-- Then, this function applies a namespace "namespace" to the data declaration `Foo` by prefixing each of its +-- constructors and references to locally-bound types with "namespace": +-- +-- @ +-- type Foo +-- constructor namespace.Foo.A : namespace.B -> C -> foo.Foo +-- ^^^^^^^^^^ ^^^^^^^^^^ ^^^^ +-- @ +-- +-- (note that the name for the data declaration itself is not prefixed within this function, because a data declaration +-- does not contain its own name). +applyNamespaceToSynDecls :: forall v. (Var v) => v -> [SynDecl v] -> [SynDecl v] +applyNamespaceToSynDecls namespace decls = + map + ( \case + SynDecl'Data decl -> + SynDecl'Data + ( decl + & over (#constructors . mapped) applyToConstructor + & over (#name . mapped) (Var.namespaced2 namespace) + ) + SynDecl'Effect decl -> + SynDecl'Effect + ( decl + & over (#constructors . mapped) applyToConstructor + & over (#name . mapped) (Var.namespaced2 namespace) + ) + ) + decls + where + applyToConstructor :: (Ann, v, Type v Ann) -> (Ann, v, Type v Ann) + applyToConstructor (ann, name, typ) = + ( ann, + Var.namespaced2 namespace name, + ABT.substsInheritAnnotation typeReplacements typ + ) + + -- Replace var "Foo" with var "namespace.Foo" + typeReplacements :: [(v, Type v ())] + typeReplacements = + decls + & List.foldl' (\acc decl -> Set.insert (L.payload (synDeclName decl)) acc) Set.empty + & Set.toList + & map (\v -> (v, Type.var () (Var.namespaced2 namespace v))) + +synDeclsToDecls :: (Monad m, Var v) => [SynDecl v] -> P v m (Map v (DataDeclaration v Ann), Map v (EffectDeclaration v Ann)) +synDeclsToDecls = do + foldlM + ( \(datas, effects) -> \case + SynDecl'Data decl -> do + let decl1 = DataDeclaration decl.modifier decl.annotation decl.tyvars decl.constructors + let !datas1 = Map.insert decl.name.payload decl1 datas + pure (datas1, effects) + SynDecl'Effect decl -> do + let decl1 = DataDeclaration.mkEffectDecl' decl.modifier decl.annotation decl.tyvars decl.constructors + let !effects1 = Map.insert decl.name.payload decl1 effects + pure (datas, effects1) + ) + (Map.empty, Map.empty) + +applyNamespaceToStanza :: + forall a v. + (Var v) => + v -> + Set v -> + Stanza v (Term v a) -> + Stanza v (Term v a) +applyNamespaceToStanza namespace locallyBoundTerms = \case + Binding x -> Binding (goBinding x) + Bindings xs -> Bindings (map goBinding xs) + WatchBinding wk ann x -> WatchBinding wk ann (goBinding x) + WatchExpression wk guid ann term -> WatchExpression wk guid ann (goTerm term) + where + goBinding :: ((Ann, v), Term v a) -> ((Ann, v), Term v a) + goBinding ((ann, name), term) = + ((ann, Var.namespaced2 namespace name), goTerm term) + + goTerm :: Term v a -> Term v a + goTerm = + ABT.substsInheritAnnotation replacements + + replacements :: [(v, Term2 v a a v ())] + replacements = + locallyBoundTerms + & Set.toList + & map (\v -> (v, Term.var () (Var.namespaced2 namespace v))) + -- | Final validations and sanity checks to perform before finishing parsing. validateUnisonFile :: - Ord v => + (Ord v) => Map v (TypeReferenceId, DataDeclaration v Ann) -> Map v (TypeReferenceId, EffectDeclaration v Ann) -> [(v, Ann, Term v Ann)] -> @@ -139,7 +299,7 @@ validateUnisonFile datas effects terms watches = -- constructors and verify that no duplicates exist in the file, triggering an error if needed. checkForDuplicateTermsAndConstructors :: forall m v. - Ord v => + (Ord v) => Map v (TypeReferenceId, DataDeclaration v Ann) -> Map v (TypeReferenceId, EffectDeclaration v Ann) -> [(v, Ann, Term v Ann)] -> @@ -162,13 +322,13 @@ checkForDuplicateTermsAndConstructors datas effects terms watches = do } where effectDecls :: [DataDeclaration v Ann] - effectDecls = Map.elems . fmap (DD.toDataDecl . snd) $ effects + effectDecls = Map.elems . fmap (DataDeclaration.toDataDecl . snd) $ effects dataDecls :: [DataDeclaration v Ann] dataDecls = fmap snd $ Map.elems datas allConstructors :: [(v, Ann)] allConstructors = (dataDecls <> effectDecls) - & foldMap DD.constructors' + & foldMap DataDeclaration.constructors' & fmap (\(ann, v, _typ) -> (v, ann)) allTerms :: [(v, Ann)] allTerms = @@ -237,7 +397,7 @@ stanza = watchExpression <|> unexpectedAction <|> binding binding@((_, v), _) <- TermParser.binding pure $ case doc of Nothing -> Binding binding - Just (spanAnn, doc) -> Bindings [((spanAnn, Var.namespaced (v :| [Var.named "doc"])), doc), binding] + Just (spanAnn, doc) -> Bindings [((spanAnn, Var.namespaced2 v (Var.named "doc")), doc), binding] watched :: (Monad m, Var v) => P v m (UF.WatchKind, Text, Ann) watched = P.try do diff --git a/parser-typechecker/src/Unison/Syntax/FilePrinter.hs b/parser-typechecker/src/Unison/Syntax/FilePrinter.hs new file mode 100644 index 0000000000..0c0d3b0443 --- /dev/null +++ b/parser-typechecker/src/Unison/Syntax/FilePrinter.hs @@ -0,0 +1,97 @@ +module Unison.Syntax.FilePrinter + ( renderDefnsForUnisonFile, + ) +where + +import Control.Lens (mapped, _1) +import Control.Monad.Writer (Writer) +import Control.Monad.Writer qualified as Writer +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Unison.Builtin.Decls qualified as Builtin.Decls +import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) +import Unison.DataDeclaration (Decl) +import Unison.DeclNameLookup (DeclNameLookup, expectConstructorNames) +import Unison.HashQualified qualified as HQ +import Unison.HashQualifiedPrime qualified as HQ' +import Unison.Name (Name) +import Unison.Prelude +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..)) +import Unison.Reference (TypeReferenceId) +import Unison.Reference qualified as Reference +import Unison.Referent (Referent) +import Unison.Referent qualified as Referent +import Unison.Syntax.DeclPrinter (AccessorName) +import Unison.Syntax.DeclPrinter qualified as DeclPrinter +import Unison.Syntax.TermPrinter qualified as TermPrinter +import Unison.Term (Term) +import Unison.Type (Type) +import Unison.Typechecker qualified as Typechecker +import Unison.Util.Defns (Defns (..), DefnsF) +import Unison.Util.Pretty (ColorText, Pretty) +import Unison.Util.Pretty qualified as Pretty +import Unison.Var (Var) + +-- | Render definitions destined for a Unison file. +-- +-- This first renders the types (discovering which record accessors will be generated upon parsing), then renders the +-- terms (being careful not to render any record accessors, since those would cause duplicate binding errors upon +-- parsing). +renderDefnsForUnisonFile :: + forall a v. + (Var v, Monoid a) => + DeclNameLookup -> + PrettyPrintEnvDecl -> + DefnsF (Map Name) (Term v a, Type v a) (TypeReferenceId, Decl v a) -> + DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText) +renderDefnsForUnisonFile declNameLookup ppe defns = + let (types, accessorNames) = Writer.runWriter (Map.traverseWithKey renderType defns.types) + in Defns + { terms = Map.mapMaybeWithKey (renderTerm accessorNames) defns.terms, + types + } + where + renderType :: Name -> (TypeReferenceId, Decl v a) -> Writer (Set AccessorName) (Pretty ColorText) + renderType name (ref, typ) = + fmap Pretty.syntaxToColor $ + DeclPrinter.prettyDeclW + -- Sort of a hack; since the decl printer looks in the PPE for names of constructors, + -- we just delete all term names out and add back the constructors... + -- probably no need to wipe out the suffixified side but we do it anyway + (setPpedToConstructorNames declNameLookup name ref ppe) + (Reference.fromId ref) + (HQ.NameOnly name) + typ + + renderTerm :: Set Name -> Name -> (Term v a, Type v a) -> Maybe (Pretty ColorText) + renderTerm accessorNames name (term, typ) = do + guard (not (Set.member name accessorNames)) + let hqName = HQ.NameOnly name + let rendered + | Typechecker.isEqual (Builtin.Decls.testResultListType mempty) typ = + "test> " <> TermPrinter.prettyBindingWithoutTypeSignature ppe.suffixifiedPPE hqName term + | otherwise = TermPrinter.prettyBinding ppe.suffixifiedPPE hqName term + Just (Pretty.syntaxToColor rendered) + +setPpedToConstructorNames :: DeclNameLookup -> Name -> TypeReferenceId -> PrettyPrintEnvDecl -> PrettyPrintEnvDecl +setPpedToConstructorNames declNameLookup name ref = + set (#unsuffixifiedPPE . #termNames) referentNames + . set (#suffixifiedPPE . #termNames) referentNames + where + constructorNameMap :: Map ConstructorReference Name + constructorNameMap = + Map.fromList + ( name + & expectConstructorNames declNameLookup + & List.zip [0 ..] + & over (mapped . _1) (ConstructorReference (Reference.fromId ref)) + ) + + referentNames :: Referent -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)] + referentNames = \case + Referent.Con conRef _ -> + case Map.lookup conRef constructorNameMap of + Nothing -> [] + Just conName -> let hqConName = HQ'.NameOnly conName in [(hqConName, hqConName)] + Referent.Ref _ -> [] diff --git a/parser-typechecker/src/Unison/Syntax/NamePrinter.hs b/parser-typechecker/src/Unison/Syntax/NamePrinter.hs index ab51847469..8c3a70708d 100644 --- a/parser-typechecker/src/Unison/Syntax/NamePrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/NamePrinter.hs @@ -2,7 +2,7 @@ module Unison.Syntax.NamePrinter where import Data.Text qualified as Text import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.LabeledDependency (LabeledDependency) import Unison.LabeledDependency qualified as LD import Unison.Name (Name) diff --git a/parser-typechecker/src/Unison/Syntax/Precedence.hs b/parser-typechecker/src/Unison/Syntax/Precedence.hs new file mode 100644 index 0000000000..2a74b1181f --- /dev/null +++ b/parser-typechecker/src/Unison/Syntax/Precedence.hs @@ -0,0 +1,71 @@ +module Unison.Syntax.Precedence where + +import Data.Map qualified as Map +import Unison.Prelude + +-- Precedence rules for infix operators. +-- Lower number means higher precedence (tighter binding). +-- Operators not in this list have no precedence and will simply be parsed +-- left-to-right. +infixRules :: Map Text Precedence +infixRules = + Map.fromList do + (ops, prec) <- zip infixLevels (map (InfixOp . Level) [0 ..]) + map (,prec) ops + +-- | Indicates this is the RHS of a top-level definition. +isTopLevelPrecedence :: Precedence -> Bool +isTopLevelPrecedence i = i == Basement + +increment :: Precedence -> Precedence +increment = \case + Basement -> Bottom + Bottom -> Annotation + Annotation -> Statement + Statement -> Control + Control -> InfixOp Lowest + InfixOp Lowest -> InfixOp (Level 0) + InfixOp (Level n) -> InfixOp (Level (n + 1)) + InfixOp Highest -> Application + Application -> Prefix + Prefix -> Top + Top -> Top + +data Precedence + = -- | The lowest precedence, used for top-level bindings + Basement + | -- | Used for terms that never need parentheses + Bottom + | -- | Type annotations + Annotation + | -- | A statement in a block + Statement + | -- | Control flow constructs like `if`, `match`, `case` + Control + | -- | Infix operators + InfixOp InfixPrecedence + | -- | Function application + Application + | -- | Prefix operators like `'`, `!` + Prefix + | -- | The highest precedence, used for let bindings and blocks + Top + deriving (Eq, Ord, Show) + +data InfixPrecedence = Lowest | Level Int | Highest + deriving (Eq, Ord, Show) + +infixLevels :: [[Text]] +infixLevels = + [ ["||", "|"], + ["&&", "&"], + ["==", "!==", "!=", "==="], + ["<", ">", ">=", "<="], + ["+", "-"], + ["*", "/", "%"], + ["^", "^^", "**"] + ] + +-- | Returns the precedence of an infix operator, if it has one. +operatorPrecedence :: Text -> Maybe Precedence +operatorPrecedence op = Map.lookup op infixRules diff --git a/parser-typechecker/src/Unison/Syntax/TermParser.hs b/parser-typechecker/src/Unison/Syntax/TermParser.hs index 8c91633700..97914aabfa 100644 --- a/parser-typechecker/src/Unison/Syntax/TermParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TermParser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PartialTypeSignatures #-} module Unison.Syntax.TermParser @@ -12,7 +13,9 @@ module Unison.Syntax.TermParser ) where +import Control.Comonad.Trans.Cofree (CofreeF ((:<))) import Control.Monad.Reader (asks, local) +import Data.Bitraversable (bitraverse) import Data.Char qualified as Char import Data.Foldable (foldrM) import Data.List qualified as List @@ -25,30 +28,36 @@ import Data.Set qualified as Set import Data.Text qualified as Text import Data.Tuple.Extra qualified as TupleE import Text.Megaparsec qualified as P +import U.Codebase.Reference (ReferenceType (..)) import U.Core.ABT qualified as ABT import Unison.ABT qualified as ABT import Unison.Builtin.Decls qualified as DD import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) import Unison.ConstructorType qualified as CT import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Names qualified as Names +import Unison.Names.ResolutionResult (ResolutionError (..), ResolutionFailure (..)) import Unison.NamesWithHistory qualified as Names -import Unison.Parser.Ann (Ann) +import Unison.Parser.Ann (Ann (Ann)) +import Unison.Parser.Ann qualified as Ann import Unison.Pattern (Pattern) import Unison.Pattern qualified as Pattern import Unison.Prelude -import Unison.Reference (Reference) +import Unison.Reference (TypeReference) import Unison.Referent (Referent) -import Unison.Syntax.Lexer qualified as L +import Unison.Referent qualified as Referent +import Unison.Syntax.Lexer.Unison qualified as L import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar) import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Syntax.Parser hiding (seq) import Unison.Syntax.Parser qualified as Parser (seq, uniqueName) +import Unison.Syntax.Parser.Doc.Data qualified as Doc +import Unison.Syntax.Precedence (operatorPrecedence) import Unison.Syntax.TypeParser qualified as TypeParser import Unison.Term (IsTop, Term) import Unison.Term qualified as Term @@ -57,6 +66,7 @@ import Unison.Type qualified as Type import Unison.Typechecker.Components qualified as Components import Unison.Util.Bytes qualified as Bytes import Unison.Util.List (intercalateMapWith, quenchRuns) +import Unison.Util.Recursion import Unison.Var (Var) import Unison.Var qualified as Var import Prelude hiding (and, or, seq) @@ -64,9 +74,9 @@ import Prelude hiding (and, or, seq) {- Precedence of language constructs is identical to Haskell, except that all operators (like +, <*>, or any sequence of non-alphanumeric characters) are -left-associative and equal precedence, and operators must have surrounding -whitespace (a + b, not a+b) to distinguish from identifiers that may contain -operator characters (like empty? or fold-left). +left-associative and equal precedence (with a few exceptions), and operators +must have surrounding whitespace (a + b, not a+b) to distinguish from +identifiers that may contain operator characters (like empty? or fold-left). Sections / partial application of infix operators is not implemented. -} @@ -100,7 +110,7 @@ rewriteBlock = do rewriteTermlike kw mk = do kw <- quasikeyword kw lhs <- term - (_spanAnn, rhs) <- block "==>" + (_spanAnn, rhs) <- layoutBlock "==>" pure (mk (ann kw <> ann rhs) lhs rhs) rewriteTerm = rewriteTermlike "term" DD.rewriteTerm rewriteCase = rewriteTermlike "case" DD.rewriteCase @@ -111,14 +121,19 @@ rewriteBlock = do rhs <- openBlockWith "==>" *> TypeParser.computationType <* closeBlock pure (DD.rewriteType (ann kw <> ann rhs) (L.payload <$> vs) lhs rhs) -typeLink' :: (Monad m, Var v) => P v m (L.Token Reference) -typeLink' = do - id <- hqPrefixId - ns <- asks names - case Names.lookupHQType Names.IncludeSuffixes (L.payload id) ns of - s - | Set.size s == 1 -> pure $ const (Set.findMin s) <$> id - | otherwise -> customFailure $ UnknownType id s +typeLink' :: (Monad m, Var v) => P v m (L.Token TypeReference) +typeLink' = findUniqueType =<< hqPrefixId + +findUniqueType :: (Monad m, Var v) => L.Token (HQ.HashQualified Name) -> P v m (L.Token TypeReference) +findUniqueType id = + resolveToLocalNamespacedType id >>= \case + Nothing -> do + ns <- asks names + case Names.lookupHQType Names.IncludeSuffixes (L.payload id) ns of + s + | Set.size s == 1 -> pure (Set.findMin s <$ id) + | otherwise -> customFailure $ UnknownType id s + Just ref -> pure (ref <$ id) termLink' :: (Monad m, Var v) => P v m (L.Token Referent) termLink' = do @@ -129,27 +144,46 @@ termLink' = do | Set.size s == 1 -> pure $ const (Set.findMin s) <$> id | otherwise -> customFailure $ UnknownTerm id s -link' :: (Monad m, Var v) => P v m (Either (L.Token Reference) (L.Token Referent)) +link' :: (Monad m, Var v) => P v m (Either (L.Token TypeReference) (L.Token Referent)) link' = do id <- hqPrefixId ns <- asks names - case (Names.lookupHQTerm Names.IncludeSuffixes (L.payload id) ns, Names.lookupHQType Names.IncludeSuffixes (L.payload id) ns) of - (s, s2) | Set.size s == 1 && Set.null s2 -> pure . Right $ const (Set.findMin s) <$> id - (s, s2) | Set.size s2 == 1 && Set.null s -> pure . Left $ const (Set.findMin s2) <$> id - (s, s2) -> customFailure $ UnknownId id s s2 + let s = Names.lookupHQTerm Names.IncludeSuffixes (L.payload id) ns + let s2 = Names.lookupHQType Names.IncludeSuffixes (L.payload id) ns + if + | Set.size s == 1 && Set.null s2 -> pure . Right $ Set.findMin s <$ id + | Set.size s2 == 1 && Set.null s -> pure . Left $ Set.findMin s2 <$ id + | True -> customFailure $ UnknownId id s s2 link :: (Monad m, Var v) => TermP v m link = termLink <|> typeLink where typeLink = do - _ <- P.try (reserved "typeLink") -- type opens a block, gotta use something else + _ <- reserved "typeLink" -- type opens a block, gotta use something else tok <- typeLink' pure $ Term.typeLink (ann tok) (L.payload tok) termLink = do - _ <- P.try (reserved "termLink") + _ <- reserved "termLink" tok <- termLink' pure $ Term.termLink (ann tok) (L.payload tok) +resolveToLocalNamespacedType :: (Monad m, Ord v) => L.Token (HQ.HashQualified Name) -> P v m (Maybe TypeReference) +resolveToLocalNamespacedType tok = + case L.payload tok of + HQ.NameOnly name -> + asks maybeNamespace >>= \case + Nothing -> pure Nothing + Just namespace -> do + localNames <- asks localNamespacePrefixedTypesAndConstructors + pure case Names.lookupHQType Names.ExactName (HQ.NameOnly (Name.joinDot namespace name)) localNames of + refs + | Set.null refs -> Nothing + -- 2+ name case is impossible: we looked up exact names in the locally-bound names. Two bindings + -- with the same name would have been a parse error. So, just take the minimum element from the set, + -- which we know is a singleton. + | otherwise -> Just (Set.findMin refs) + _ -> pure Nothing + -- We disallow type annotations and lambdas, -- just function application and operators blockTerm :: (Monad m, Var v) => TermP v m @@ -159,27 +193,18 @@ match :: (Monad m, Var v) => TermP v m match = do start <- openBlockWith "match" scrutinee <- term - _ <- closeBlock + _ <- optionalCloseBlock _ <- - P.try (openBlockWith "with") <|> do + openBlockWith "with" <|> do t <- anyToken P.customFailure (ExpectedBlockOpen "with" t) - (_arities, cases) <- NonEmpty.unzip <$> matchCases1 start - _ <- closeBlock - pure $ - Term.match - (ann start <> ann (NonEmpty.last cases)) - scrutinee - (toList cases) - -matchCases1 :: (Monad m, Var v) => L.Token () -> P v m (NonEmpty (Int, Term.MatchCase Ann (Term v Ann))) -matchCases1 start = do - cases <- - (sepBy semi matchCase) - <&> \cases_ -> [(n, c) | (n, cs) <- cases_, c <- cs] - case cases of - [] -> P.customFailure (EmptyMatch start) - (c : cs) -> pure (c NonEmpty.:| cs) + (_arities, cases) <- unzip <$> matchCases + _ <- optionalCloseBlock + let anns = foldr ((<>) . ann) (ann start) $ lastMay cases + pure $ Term.match anns scrutinee cases + +matchCases :: (Monad m, Var v) => P v m [(Int, Term.MatchCase Ann (Term v Ann))] +matchCases = sepBy semi matchCase <&> \cases_ -> [(n, c) | (n, cs) <- cases_, c <- cs] -- Returns the arity of the pattern and the `MatchCase`. Examples: -- @@ -204,13 +229,13 @@ matchCase = do _ <- reserved "|" guard <- asum - [ Nothing <$ P.try (quasikeyword "otherwise"), + [ Nothing <$ quasikeyword "otherwise", Just <$> infixAppOrBooleanOp ] - (_spanAnn, t) <- block "->" + (_spanAnn, t) <- layoutBlock "->" pure (guard, t) let unguardedBlock = label "case match" do - (_spanAnn, t) <- block "->" + (_spanAnn, t) <- layoutBlock "->" pure (Nothing, t) -- a pattern's RHS is either one or more guards, or a single unguarded block. guardsAndBlocks <- guardedBlocks <|> (pure @[] <$> unguardedBlock) @@ -278,41 +303,92 @@ parsePattern = label "pattern" root else pure (Pattern.Var (ann v), [tokenToPair v]) unbound :: P v m (Pattern Ann, [(Ann, v)]) unbound = (\tok -> (Pattern.Unbound (ann tok), [])) <$> blank - ctor :: CT.ConstructorType -> (L.Token (HQ.HashQualified Name) -> Set ConstructorReference -> Error v) -> P v m (L.Token ConstructorReference) - ctor ct err = do + ctor :: CT.ConstructorType -> P v m (L.Token ConstructorReference) + ctor ct = do -- this might be a var, so we avoid consuming it at first - tok <- P.try (P.lookAhead hqPrefixId) - names <- asks names - -- probably should avoid looking up in `names` if `L.payload tok` - -- starts with a lowercase - case Names.lookupHQPattern Names.IncludeSuffixes (L.payload tok) ct names of - s - | Set.null s -> die tok s - | Set.size s > 1 -> die tok s - | otherwise -> -- matched ctor name, consume the token - do _ <- anyToken; pure (Set.findMin s <$ tok) + tok <- P.lookAhead hqPrefixId + + -- First, if: + -- + -- * The token isn't hash-qualified (e.g. "Foo.Bar") + -- * We're under a namespace directive (e.g. "baz") + -- * There's an exact match for a locally-bound constructor (e.g. "baz.Foo.Bar") + -- + -- Then: + -- + -- * Use that constructor reference (duh) + -- + -- Else: + -- + -- * Fall through to the normal logic of looking the constructor name up in all of the names (which includes + -- the locally-bound constructors). + + maybeLocalCtor <- + case L.payload tok of + HQ.NameOnly name -> + asks maybeNamespace >>= \case + Nothing -> pure Nothing + Just namespace -> do + localNames <- asks localNamespacePrefixedTypesAndConstructors + case Names.lookupHQPattern Names.ExactName (HQ.NameOnly (Name.joinDot namespace name)) ct localNames of + refs + | Set.null refs -> pure Nothing + -- 2+ name case is impossible: we looked up exact names in the locally-bound names. Two bindings + -- with the same name would have been a parse error. So, just take the minimum element from the set, + -- which we know is a singleton. + | otherwise -> do + -- matched ctor name, consume the token + _ <- anyToken + pure (Just (Set.findMin refs)) + _ -> pure Nothing + + case maybeLocalCtor of + Just localCtor -> pure (localCtor <$ tok) + Nothing -> do + names <- asks names + case Names.lookupHQPattern Names.IncludeSuffixes (L.payload tok) ct names of + s + | Set.size s == 1 -> do + -- matched ctor name, consume the token + _ <- anyToken + pure (Set.findMin s <$ tok) + | otherwise -> die names tok s where - isLower = Text.all Char.isLower . Text.take 1 . Name.toText - die hq s = case L.payload hq of - -- if token not hash qualified or uppercase, + isLower = Text.all Char.isLower . Text.take 1 . NameSegment.toUnescapedText . Name.lastSegment + isIgnored n = Text.take 1 (Name.toText n) == "_" + die :: Names -> L.Token (HQ.HashQualified Name) -> Set ConstructorReference -> P v m a + die names hq s = case L.payload hq of + -- if token not hash qualified and not uppercase, -- fail w/out consuming it to allow backtracking HQ.NameOnly n | Set.null s - && isLower n -> + && (isLower n || isIgnored n) -> fail $ "not a constructor name: " <> show n - -- it was hash qualified, and wasn't found in the env, that's a failure! - _ -> failCommitted $ err hq s - + -- it was hash qualified and/or uppercase, and was either not found or ambiguous, that's a failure! + _ -> + failCommitted $ + ResolutionFailures + [ TermResolutionFailure + (L.payload hq) + (ann hq) + if Set.null s + then NotFound + else + Ambiguous + names + (Set.map (\ref -> Referent.Con ref ct) s) + -- Eh, here we're saying there are no "local" constructors – they're all from "the namespace". + -- That's not necessarily true, but it doesn't (currently) affect the error message any, and + -- we have already parsed and hashed local constructors (so they aren't really different from + -- namespace constructors). + Set.empty + ] unzipPatterns f elems = case unzip elems of (patterns, vs) -> f patterns (join vs) - effectBind0 = do - tok <- ctor CT.Effect UnknownAbilityConstructor + effectBind = do + tok <- ctor CT.Effect leaves <- many leaf _ <- reserved "->" - pure (tok, leaves) - - effectBind = do - (tok, leaves) <- P.try effectBind0 (cont, vsp) <- parsePattern pure $ let f patterns vs = (Pattern.EffectBind (ann tok <> ann cont) (L.payload tok) patterns cont, vs ++ vsp) @@ -324,17 +400,42 @@ parsePattern = label "pattern" root effect = do start <- openBlockWith "{" - (inner, vs) <- effectBind <|> effectPure - end <- closeBlock + + -- After the opening curly brace, we are expecting either an EffectBind or an EffectPure: + -- + -- EffectBind EffectPure + -- + -- { foo bar -> baz } { qux } + -- ^^^^^^^^^^^^^^ ^^^ + -- + -- We accomplish that as follows: + -- + -- * First try EffectPure + "}" + -- * If that fails, back the parser up and try EffectBind + "}" instaed + -- + -- This won't always result in the best possible error messages, but it's not exactly trivial to do better, + -- requiring more sophisticated look-ahead logic. So, this is how it works for now. + (inner, vs, end) <- + asum + [ P.try do + (inner, vs) <- effectPure + end <- closeBlock + pure (inner, vs, end), + do + (inner, vs) <- effectBind + end <- closeBlock + pure (inner, vs, end) + ] + pure (Pattern.setLoc inner (ann start <> ann end), vs) -- ex: unique type Day = Mon | Tue | ... - nullaryCtor = P.try do - tok <- ctor CT.Data UnknownDataConstructor + nullaryCtor = do + tok <- ctor CT.Data pure (Pattern.Constructor (ann tok) (L.payload tok) [], []) constructor = do - tok <- ctor CT.Data UnknownDataConstructor + tok <- ctor CT.Data let f patterns vs = let loc = foldl (<>) (ann tok) $ map ann patterns in (Pattern.Constructor loc (L.payload tok) patterns, vs) @@ -347,30 +448,33 @@ parsePattern = label "pattern" root lam :: (Var v) => TermP v m -> TermP v m lam p = label "lambda" $ mkLam <$> P.try (some prefixDefinitionName <* reserved "->") <*> p where - mkLam vs b = Term.lam' (ann (head vs) <> ann b) (map L.payload vs) b + mkLam vs b = + let annotatedArgs = vs <&> \v -> (ann v, L.payload v) + in Term.lam' (ann (head vs) <> ann b) annotatedArgs b letBlock, handle, ifthen :: (Monad m, Var v) => TermP v m -letBlock = label "let" $ (snd <$> block "let") +letBlock = label "let" $ (snd <$> layoutBlock "let") handle = label "handle" do (handleSpan, b) <- block "handle" - (_withSpan, handler) <- block "with" + (_withSpan, handler) <- layoutBlock "with" -- We don't use the annotation span from 'with' here because it will -- include a dedent if it's at the end of block. -- Meaning the newline gets overwritten when pretty-printing and it messes things up. pure $ Term.handle (handleSpan <> ann handler) handler b -checkCasesArities :: (Ord v, Annotated a) => NonEmpty (Int, a) -> P v m (Int, NonEmpty a) -checkCasesArities cases@((i, _) NonEmpty.:| rest) = - case List.find (\(j, _) -> j /= i) rest of +checkCasesArities :: (Ord v, Annotated a) => [(Int, a)] -> P v m (Int, [a]) +checkCasesArities = \case + [] -> pure (1, []) + cases@((i, _) : rest) -> case List.find (\(j, _) -> j /= i) rest of Nothing -> pure (i, snd <$> cases) Just (j, a) -> P.customFailure $ PatternArityMismatch i j (ann a) lamCase :: (Monad m, Var v) => TermP v m lamCase = do start <- openBlockWith "cases" - cases <- matchCases1 start + cases <- matchCases (arity, cases) <- checkCasesArities cases - _ <- closeBlock + _ <- optionalCloseBlock lamvars <- replicateM arity (Parser.uniqueName 10) let vars = Var.named <$> [tweak v i | (v, i) <- lamvars `zip` [(1 :: Int) ..]] @@ -380,15 +484,16 @@ lamCase = do lamvarTerm = case lamvarTerms of [e] -> e es -> DD.tupleTerm es - anns = ann start <> ann (NonEmpty.last cases) - matchTerm = Term.match anns lamvarTerm (toList cases) - pure $ Term.lam' anns vars matchTerm + anns = foldr ((<>) . ann) (ann start) $ lastMay cases + matchTerm = Term.match anns lamvarTerm cases + let annotatedVars = (Ann.GeneratedFrom $ ann start,) <$> vars + pure $ Term.lam' anns annotatedVars matchTerm ifthen = label "if" do start <- peekAny (_spanAnn, c) <- block "if" (_spanAnn, t) <- block "then" - (_spanAnn, f) <- block "else" + (_spanAnn, f) <- layoutBlock "else" pure $ Term.iff (ann start <> ann f) c t f text :: (Var v) => TermP v m @@ -408,10 +513,7 @@ list = Parser.seq Term.list hashQualifiedPrefixTerm :: (Monad m, Var v) => TermP v m hashQualifiedPrefixTerm = resolveHashQualified =<< hqPrefixId -hashQualifiedInfixTerm :: (Monad m, Var v) => TermP v m -hashQualifiedInfixTerm = resolveHashQualified =<< hqInfixId - -quasikeyword :: Ord v => Text -> P v m (L.Token ()) +quasikeyword :: (Ord v) => Text -> P v m (L.Token ()) quasikeyword kw = queryToken \case L.WordyId (HQ'.NameOnly n) | nameIsKeyword n kw -> Just () _ -> Nothing @@ -427,19 +529,21 @@ nameIsKeyword name keyword = -- committed if that short hash can't be found in the current environment resolveHashQualified :: (Monad m, Var v) => L.Token (HQ.HashQualified Name) -> TermP v m resolveHashQualified tok = do - names <- asks names case L.payload tok of HQ.NameOnly n -> pure $ Term.var (ann tok) (Name.toVar n) - _ -> case Names.lookupHQTerm Names.IncludeSuffixes (L.payload tok) names of - s - | Set.null s -> failCommitted $ UnknownTerm tok s - | Set.size s > 1 -> failCommitted $ UnknownTerm tok s - | otherwise -> pure $ Term.fromReferent (ann tok) (Set.findMin s) + _ -> do + names <- asks names + case Names.lookupHQTerm Names.IncludeSuffixes (L.payload tok) names of + s + | Set.null s -> failCommitted $ UnknownTerm tok s + | Set.size s > 1 -> failCommitted $ UnknownTerm tok s + | otherwise -> pure $ Term.fromReferent (ann tok) (Set.findMin s) termLeaf :: forall m v. (Monad m, Var v) => TermP v m termLeaf = asum - [ hashQualifiedPrefixTerm, + [ force, + hashQualifiedPrefixTerm, text, char, number, @@ -456,159 +560,183 @@ termLeaf = doc2Block <&> \(spanAnn, trm) -> trm {ABT.annotation = ABT.annotation trm <> spanAnn} ] --- Syntax for documentation v2 blocks, which are surrounded by {{ }}. +-- | Gives a parser an explicit stream to parse, so that it consumes nothing from the original stream when it runs. +-- +-- This is used inside the `Doc` -> `Term` conversion, where we have chunks of Unison code embedded that need to be +-- parsed. It’s a consequence of parsing Doc in the midst of the Unison lexer. +subParse :: (Ord v, Monad m) => P v m a -> [L.Token L.Lexeme] -> P v m a +subParse p toks = do + orig <- P.getInput + P.setInput $ Input toks + result <- p <* P.eof + P.setInput orig + pure result + +-- | Syntax for documentation v2 blocks, which are surrounded by @{{@ @}}@. -- The lexer does most of the heavy lifting so there's not a lot for -- the parser to do. For instance, in -- --- {{ --- Hi there! --- --- goodbye. --- }} +-- > {{ +-- > Hi there! +-- > +-- > goodbye. +-- > }} -- -- the lexer will produce: -- --- [Open "syntax.docUntitledSection", --- Open "syntax.docParagraph", --- Open "syntax.docWord", Textual "Hi", Close, --- Open "syntax.docWord", Textual "there!", Close, --- Close --- Open "syntax.docParagraph", --- Open "syntax.docWord", Textual "goodbye", Close, --- Close --- Close] +-- > [ Doc +-- > ( DocUntitledSection +-- > (DocParagraph (DocWord "Hi" :| [DocWord "there!"])) +-- > (DocParagraph (DocWord "goodbye" :| [])) +-- > ) +-- > ] -- -- The parser will parse this into the Unison expression: -- --- syntax.docUntitledSection [ --- syntax.docParagraph [syntax.docWord "Hi", syntax.docWord "there!"], --- syntax.docParagraph [syntax.docWord "goodbye"] --- ] +-- > syntax.docUntitledSection [ +-- > syntax.docParagraph [syntax.docWord "Hi", syntax.docWord "there!"], +-- > syntax.docParagraph [syntax.docWord "goodbye"] +-- > ] -- --- Where `syntax.doc{Paragraph, UntitledSection,...}` are all ordinary term +-- Where @syntax.doc{Paragraph, UntitledSection,...}@ are all ordinary term -- variables that will be looked up in the environment like anything else. This -- means that the documentation syntax can have its meaning changed by --- overriding what functions the names `syntax.doc*` correspond to. +-- overriding what functions the names @syntax.doc*@ correspond to. doc2Block :: forall m v. (Monad m, Var v) => P v m (Ann {- Annotation for the whole spanning block -}, Term v Ann) doc2Block = do - P.lookAhead (openBlockWith "syntax.docUntitledSection") *> elem + L.Token docContents startDoc endDoc <- doc + let docAnn = Ann startDoc endDoc + (docAnn,) . docUntitledSection (gann docAnn) <$> traverse foldTop docContents where - -- For terms which aren't blocks the spanning annotation is the same as the - -- term annotation. - selfAnnotated :: Term v Ann -> (Ann, Term v Ann) - selfAnnotated t = (ann t, t) - elem :: P v m (Ann {- Annotation for the whole spanning block -}, Term v Ann) - elem = - (selfAnnotated <$> text) <|> do - startTok <- openBlock - let -- here, `t` will be something like `Open "syntax.docWord"` - -- so `f` will be a term var with the name "syntax.docWord". - f = f' startTok - f' t = Term.var (ann t) (Var.nameds (L.payload t)) - - -- follows are some common syntactic forms used for parsing child elements - - -- regular is parsed into `f child1 child2 child3` for however many children - regular = do - cs <- P.many (snd <$> elem) - endTok <- closeBlock - let trm = Term.apps' f cs - pure (ann startTok <> ann endTok, trm) - - -- variadic is parsed into: `f [child1, child2, ...]` - variadic = variadic' f - variadic' f = do - cs <- P.many (snd <$> elem) - endTok <- closeBlock - let trm = Term.apps' f [Term.list (ann cs) cs] - pure (ann startTok <> ann endTok, trm) - - -- sectionLike is parsed into: `f tm [child1, child2, ...]` - sectionLike = do - arg1 <- (snd <$> elem) - cs <- P.many (snd <$> elem) - endTok <- closeBlock - let trm = Term.apps' f [arg1, Term.list (ann cs) cs] - pure (ann startTok <> ann endTok, trm) - - evalLike wrap = do - tm <- term - endTok <- closeBlock - let trm = Term.apps' f [wrap tm] - pure (ann startTok <> ann endTok, trm) - - -- converts `tm` to `'tm` - -- - -- Embedded examples like ``1 + 1`` are represented as terms, - -- but are wrapped in delays so they are left unevaluated for the - -- code which renders documents. (We want the doc display to get - -- the unevaluated expression `1 + 1` and not `2`) - addDelay tm = Term.delay (ann tm) tm - case L.payload startTok of - "syntax.docJoin" -> variadic - "syntax.docUntitledSection" -> variadic - "syntax.docColumn" -> variadic - "syntax.docParagraph" -> variadic - "syntax.docSignature" -> variadic - "syntax.docSource" -> variadic - "syntax.docFoldedSource" -> variadic - "syntax.docBulletedList" -> variadic - "syntax.docSourceAnnotations" -> variadic - "syntax.docSourceElement" -> do - link <- (snd <$> elem) - anns <- P.optional $ reserved "@" *> (snd <$> elem) - endTok <- closeBlock - let trm = Term.apps' f [link, fromMaybe (Term.list (ann link) mempty) anns] - pure (ann startTok <> ann endTok, trm) - "syntax.docNumberedList" -> do - nitems@((n, _) : _) <- P.some nitem - endTok <- closeBlock - let items = snd <$> nitems - let trm = Term.apps' f [n, Term.list (ann items) items] - pure (ann startTok <> ann endTok, trm) - where - nitem = do - n <- number - t <- openBlockWith "syntax.docColumn" - let f = f' ("syntax.docColumn" <$ t) - (_spanAnn, child) <- variadic' f - pure (n, child) - "syntax.docSection" -> sectionLike - -- @source{ type Blah, foo, type Bar } - "syntax.docEmbedTermLink" -> do - tm <- addDelay <$> (hashQualifiedPrefixTerm <|> hashQualifiedInfixTerm) - endTok <- closeBlock - let trm = Term.apps' f [tm] - pure (ann startTok <> ann endTok, trm) - "syntax.docEmbedSignatureLink" -> do - tm <- addDelay <$> (hashQualifiedPrefixTerm <|> hashQualifiedInfixTerm) - endTok <- closeBlock - let trm = Term.apps' f [tm] - pure (ann startTok <> ann endTok, trm) - "syntax.docEmbedTypeLink" -> do - r <- typeLink' - endTok <- closeBlock - let trm = Term.apps' f [Term.typeLink (ann r) (L.payload r)] - pure (ann startTok <> ann endTok, trm) - "syntax.docExample" -> do - trm <- term - endTok <- closeBlock - pure . (ann startTok <> ann endTok,) $ case trm of - tm@(Term.Apps' _ xs) -> - let fvs = List.Extra.nubOrd $ concatMap (toList . Term.freeVars) xs - n = Term.nat (ann tm) (fromIntegral (length fvs)) - lam = addDelay $ Term.lam' (ann tm) fvs tm - in Term.apps' f [n, lam] - tm -> Term.apps' f [Term.nat (ann tm) 0, addDelay tm] - "syntax.docTransclude" -> evalLike id - "syntax.docEvalInline" -> evalLike addDelay - "syntax.docExampleBlock" -> do - (spanAnn, tm) <- block'' False True "syntax.docExampleBlock" (pure (void startTok)) closeBlock - pure $ (spanAnn, Term.apps' f [Term.nat (ann tm) 0, addDelay tm]) - "syntax.docEval" -> do - (spanAnn, tm) <- block' False "syntax.docEval" (pure (void startTok)) closeBlock - pure $ (spanAnn, Term.apps' f [addDelay tm]) - _ -> regular + foldTop = cataM \(a :< top) -> docTop a =<< bitraverse (cataM \(a :< leaf) -> docLeaf a leaf) pure top + + gann :: (Annotated a) => a -> Ann + gann = Ann.GeneratedFrom . ann + + addDelay :: Term v Ann -> Term v Ann + addDelay tm = Term.delay (ann tm) tm + + f :: (Annotated a) => a -> String -> Term v Ann + f a = Term.var (gann a) . Var.nameds . ("syntax.doc" <>) + + docUntitledSection :: Ann -> Doc.UntitledSection (Term v Ann) -> Term v Ann + docUntitledSection ann (Doc.UntitledSection tops) = + Term.app ann (f ann "UntitledSection") $ Term.list (gann tops) tops + + docTop :: Ann -> Doc.Top [L.Token L.Lexeme] (Term v Ann) (Term v Ann) -> TermP v m + docTop d = \case + Doc.Section title body -> pure $ Term.apps' (f d "Section") [docParagraph d title, Term.list (gann body) body] + Doc.Eval code -> + Term.app (gann d) (f d "Eval") . addDelay . snd + <$> subParse (block' False False "syntax.docEval" (pure $ pure ()) $ Ann.External <$ P.eof) code + Doc.ExampleBlock code -> + Term.apps' (f d "ExampleBlock") . (Term.nat (gann d) 0 :) . pure . addDelay . snd + <$> subParse (block' False True "syntax.docExampleBlock" (pure $ pure ()) $ Ann.External <$ P.eof) code + Doc.CodeBlock label body -> + pure $ + Term.apps' + (f d "CodeBlock") + [Term.text d $ Text.pack label, Term.text d $ Text.pack body] + Doc.List' list -> pure $ docList d list + Doc.Paragraph' para -> pure $ docParagraph d para + + docParagraph d leaves = Term.app (gann d) (f d "Paragraph") . Term.list d $ toList leaves + + docList :: Ann -> Doc.List (Term v Ann) -> Term v Ann + docList d = \case + Doc.BulletedList items -> + Term.app (gann d) (f d "BulletedList") . Term.list (gann d) . toList $ docColumn d <$> items + Doc.NumberedList items@((n, _) :| _) -> + Term.apps' + (f d "NumberedList") + [Term.nat (ann d) $ n, Term.list (gann d) . toList $ docColumn d . snd <$> items] + + docColumn :: Ann -> Doc.Column (Term v Ann) -> Term v Ann + docColumn d (Doc.Column para sublist) = + Term.app (gann d) (f d "Column") . Term.list (gann d) $ docParagraph d para : toList (docList d <$> sublist) + + docLeaf :: Ann -> Doc.Leaf (L.Token (ReferenceType, HQ'.HashQualified Name)) [L.Token L.Lexeme] (Term v Ann) -> TermP v m + docLeaf d = \case + Doc.Link link -> Term.app (gann d) (f d "Link") <$> docEmbedLink d link + Doc.NamedLink para group -> pure $ Term.apps' (f d "NamedLink") [docParagraph d para, docGroup d group] + Doc.Example code -> do + trm <- subParse term code + pure . Term.apps' (f d "Example") $ case trm of + tm@(Term.Apps' _ xs) -> + let fvs = List.Extra.nubOrd $ concatMap (toList . Term.freeVars) xs + n = Term.nat (ann tm) (fromIntegral (length fvs)) + lam = addDelay $ Term.lam' (ann tm) ((mempty,) <$> fvs) tm + in [n, lam] + tm -> [Term.nat (ann tm) 0, addDelay tm] + Doc.Transclude' trans -> docTransclude d trans + Doc.Bold para -> pure . Term.app (gann d) (f d "Bold") $ docParagraph d para + Doc.Italic para -> pure . Term.app (gann d) (f d "Italic") $ docParagraph d para + Doc.Strikethrough para -> pure . Term.app (gann d) (f d "Strikethrough") $ docParagraph d para + Doc.Verbatim leaf -> pure . Term.app (gann d) (f d "Verbatim") $ docWord d leaf + Doc.Code leaf -> pure . Term.app (gann d) (f d "Code") $ docWord d leaf + Doc.Source elems -> + Term.app (gann d) (f d "Source") . Term.list d . toList <$> traverse (docSourceElement d) elems + Doc.FoldedSource elems -> + Term.app (gann d) (f d "FoldedSource") . Term.list d . toList <$> traverse (docSourceElement d) elems + Doc.EvalInline code -> Term.app (gann d) (f d "EvalInline") . addDelay <$> subParse term code + Doc.Signature links -> + Term.app (gann d) (f d "Signature") . Term.list d . toList <$> traverse (docEmbedSignatureLink d) links + Doc.SignatureInline link -> Term.app (gann d) (f d "SignatureInline") <$> docEmbedSignatureLink d link + Doc.Word' word -> pure $ docWord d word + Doc.Group' group -> pure $ docGroup d group + + docEmbedLink :: Ann -> Doc.EmbedLink (L.Token (ReferenceType, HQ'.HashQualified Name)) -> TermP v m + docEmbedLink d (Doc.EmbedLink (L.Token (level, ident) start end)) = case level of + RtType -> + Term.app (gann d) (f d "EmbedTypeLink") . Term.typeLink (ann d) . L.payload + <$> findUniqueType (L.Token (HQ'.toHQ ident) start end) + RtTerm -> + Term.app (gann d) (f d "EmbedTermLink") . addDelay <$> resolveHashQualified (L.Token (HQ'.toHQ ident) start end) + + docTransclude :: Ann -> Doc.Transclude [L.Token L.Lexeme] -> TermP v m + docTransclude d (Doc.Transclude code) = Term.app (gann d) (f d "Transclude") <$> subParse term code + + docSourceElement :: + Ann -> + Doc.SourceElement (L.Token (ReferenceType, HQ'.HashQualified Name)) (Doc.Transclude [L.Token L.Lexeme]) -> + TermP v m + docSourceElement d (Doc.SourceElement link anns) = do + link' <- docEmbedLink d link + anns' <- traverse (docEmbedAnnotation d) anns + pure $ Term.apps' (f d "SourceElement") [link', Term.list d anns'] + + docEmbedSignatureLink :: + Ann -> Doc.EmbedSignatureLink (L.Token (ReferenceType, HQ'.HashQualified Name)) -> TermP v m + docEmbedSignatureLink d (Doc.EmbedSignatureLink (L.Token (level, ident) start end)) = case level of + RtType -> P.customFailure . TypeNotAllowed $ L.Token (HQ'.toHQ ident) start end + RtTerm -> + Term.app (gann d) (f d "EmbedSignatureLink") . addDelay + <$> resolveHashQualified (L.Token (HQ'.toHQ ident) start end) + + docEmbedAnnotation :: + Ann -> + Doc.EmbedAnnotation (L.Token (ReferenceType, HQ'.HashQualified Name)) (Doc.Transclude [L.Token L.Lexeme]) -> + TermP v m + docEmbedAnnotation d (Doc.EmbedAnnotation a) = + -- This is the only place I’m not sure we’re doing the right thing. In the lexer, this can be an identifier or a + -- DocLeaf, but here it could be either /text/ or a Doc element. And I don’t think there’s any way the lexemes + -- produced for an identifier and the lexemes consumed for text line up. So, I think this is a bugfix I can’t + -- avoid. + Term.app (gann d) (f d "EmbedAnnotation") + <$> either + ( \(L.Token (level, ident) start end) -> case level of + RtType -> P.customFailure . TypeNotAllowed $ L.Token (HQ'.toHQ ident) start end + RtTerm -> resolveHashQualified $ L.Token (HQ'.toHQ ident) start end + ) + (docTransclude d) + a + + docWord :: Ann -> Doc.Word -> Term v Ann + docWord d (Doc.Word txt) = Term.app (gann d) (f d "Word") . Term.text d $ Text.pack txt + + docGroup :: Ann -> Doc.Group (Term v Ann) -> Term v Ann + docGroup d (Doc.Group (Doc.Join leaves)) = + Term.app d (f d "Group") . Term.app d (f d "Join") . Term.list (ann leaves) $ toList leaves docBlock :: (Monad m, Var v) => TermP v m docBlock = do @@ -978,12 +1106,13 @@ delayQuote :: (Monad m, Var v) => TermP v m delayQuote = P.label "quote" do start <- reserved "'" e <- termLeaf - pure $ DD.delayTerm (ann start <> ann e) e + pure $ DD.delayTerm (ann start <> ann e) (ann start) e delayBlock :: (Monad m, Var v) => P v m (Ann {- Ann spanning the whole block -}, Term v Ann) delayBlock = P.label "do" do - (spanAnn, b) <- block "do" - pure $ (spanAnn, DD.delayTerm (ann b) b) + (spanAnn, b) <- layoutBlock "do" + let argSpan = (ann b {- would be nice to use the annotation for 'do' here, but it's not terribly important -}) + pure $ (spanAnn, DD.delayTerm (ann b) argSpan b) bang :: (Monad m, Var v) => TermP v m bang = P.label "bang" do @@ -991,14 +1120,22 @@ bang = P.label "bang" do e <- termLeaf pure $ DD.forceTerm (ann start <> ann e) (ann start) e +force :: forall m v. (Monad m, Var v) => TermP v m +force = P.label "force" $ P.try do + -- `forkAt pool() blah` parses as `forkAt (pool ()) blah` + -- That is, empty parens immediately (no space) following a symbol + -- is treated as high precedence function application of `Unit` + fn <- hashQualifiedPrefixTerm + tok <- ann <$> openBlockWith "(" + guard (L.column (Ann.start tok) == L.column (Ann.end (ann fn))) + close <- closeBlock + pure $ DD.forceTerm (ann fn <> ann close) (tok <> ann close) fn + seqOp :: (Ord v) => P v m Pattern.SeqOp seqOp = - Pattern.Snoc - <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.snocSegment))) - <|> Pattern.Cons - <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.consSegment))) - <|> Pattern.Concat - <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.concatSegment))) + Pattern.Snoc <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.snocSegment))) + <|> Pattern.Cons <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.consSegment))) + <|> Pattern.Concat <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.concatSegment))) term4 :: (Monad m, Var v) => TermP v m term4 = f <$> some termLeaf @@ -1006,17 +1143,85 @@ term4 = f <$> some termLeaf f (func : args) = Term.apps func ((\a -> (ann func <> ann a, a)) <$> args) f [] = error "'some' shouldn't produce an empty list" +data InfixParse v + = InfixOp (L.Token (HQ.HashQualified Name)) (Term v Ann) (InfixParse v) (InfixParse v) + | InfixAnd (L.Token String) (InfixParse v) (InfixParse v) + | InfixOr (L.Token String) (InfixParse v) (InfixParse v) + | InfixOperand (Term v Ann) + deriving (Show, Eq, Ord) + -- e.g. term4 + term4 - term4 -- or term4 || term4 && term4 -infixAppOrBooleanOp :: (Monad m, Var v) => TermP v m -infixAppOrBooleanOp = chainl1 term4 (or <|> and <|> infixApp) +-- The algorithm works as follows: +-- 1. Parse the expression left-associated +-- 2. Starting at the leftmost operator subexpression, see if the next operator +-- has higher precedence. If so, rotate the expression to the right. +-- e.g. in `a + b * c`, we first parse `(a + b) * c` then rotate to `a + (b * c)`. +-- 3. Perform the algorithm on the right-hand side if necessary, as `b` might be +-- an infix expression with lower precedence than `*`. +-- 4. Proceed to the next operator to the right in the original expression and +-- repeat steps 2-3 until we reach the end. +infixAppOrBooleanOp :: forall m v. (Monad m, Var v) => TermP v m +infixAppOrBooleanOp = do + (p, ps) <- prelimParse + -- traceShowM ("orig" :: String, foldl' (flip ($)) p ps) + let p' = reassociate (p, ps) + -- traceShowM ("reassoc" :: String, p') + return (applyInfixOps p') where - or = orf <$> label "or" (reserved "||") - orf op lhs rhs = Term.or (ann lhs <> ann op <> ann rhs) lhs rhs - and = andf <$> label "and" (reserved "&&") - andf op lhs rhs = Term.and (ann lhs <> ann op <> ann rhs) lhs rhs - infixApp = infixAppf <$> label "infixApp" (hashQualifiedInfixTerm <* optional semi) - infixAppf op lhs rhs = Term.apps' op [lhs, rhs] + -- To handle a mix of infix operators with and without precedence rules, + -- we first parse the expression left-associated, then reassociate it + -- according to the precedence rules. + prelimParse = + chainl1Accum (InfixOperand <$> term4) genericInfixApp + genericInfixApp = + (InfixAnd <$> (label "and" (reserved "&&"))) + <|> (InfixOr <$> (label "or" (reserved "||"))) + <|> (uncurry InfixOp <$> parseInfix) + shouldRotate child parent = case (child, parent) of + (Just p1, Just p2) -> p1 < p2 + _ -> False + parseInfix = label "infixApp" do + op <- hqInfixId <* optional semi + resolved <- resolveHashQualified op + pure (op, resolved) + reassociate (exp, ops) = + foldl' checkOp exp ops + checkOp exp op = fixUp (op exp) + fixUp = \case + InfixOp op tm lhs rhs -> + rotate (unqualified op) (InfixOp op tm) lhs rhs + InfixAnd op lhs rhs -> + rotate "&&" (InfixAnd op) lhs rhs + InfixOr op lhs rhs -> + rotate "||" (InfixOr op) lhs rhs + x -> x + rotate op ctor lhs rhs = + case lhs of + InfixOp lop ltm ll lr + | shouldRotate (operatorPrecedence (unqualified lop)) (operatorPrecedence op) -> + InfixOp lop ltm ll (fixUp (ctor lr rhs)) + InfixAnd lop ll lr + | shouldRotate (operatorPrecedence "&&") (operatorPrecedence op) -> + InfixAnd lop ll (fixUp (ctor lr rhs)) + InfixOr lop ll lr + | shouldRotate (operatorPrecedence "||") (operatorPrecedence op) -> + InfixOr lop ll (fixUp (ctor lr rhs)) + _ -> ctor lhs rhs + unqualified t = Maybe.fromJust $ NameSegment.toEscapedText . Name.lastSegment <$> (HQ.toName $ L.payload t) + applyInfixOps :: InfixParse v -> Term v Ann + applyInfixOps t = case t of + InfixOp _ tm lhs rhs -> + Term.apps' tm [applyInfixOps lhs, applyInfixOps rhs] + InfixOperand tm -> tm + InfixAnd op lhs rhs -> + let lhs' = applyInfixOps lhs + rhs' = applyInfixOps rhs + in Term.and (ann lhs' <> ann op <> ann rhs') lhs' rhs' + InfixOr op lhs rhs -> + let lhs' = applyInfixOps lhs + rhs' = applyInfixOps rhs + in Term.or (ann lhs' <> ann op <> ann rhs') lhs' rhs' typedecl :: (Monad m, Var v) => P v m (L.Token v, Type v Ann) typedecl = @@ -1039,28 +1244,26 @@ verifyRelativeName' name = do -- example: -- (x, y) = foo --- hd +: tl | hd < 10 = [1,2,3] -- stuff -- -- desugars to: -- -- match foo with --- (x,y) -> match [1,2,3] with --- hd +: tl | hd < 10 -> stuff +-- (x,y) -> stuff -- destructuringBind :: forall m v. (Monad m, Var v) => P v m (Ann, Term v Ann -> Term v Ann) destructuringBind = do -- We have to look ahead as far as the `=` to know if this is a bind or -- just an action, for instance: - -- Some 42 + -- (Some 42) -- vs - -- Some 42 = List.head elems + -- (Some 42) = List.head elems (p, boundVars) <- P.try do (p, boundVars) <- parsePattern let boundVars' = snd <$> boundVars _ <- P.lookAhead (openBlockWith "=") pure (p, boundVars') - (_spanAnn, scrute) <- block "=" -- Dwight K. Scrute ("The People's Scrutinee") + (_spanAnn, scrute) <- layoutBlock "=" -- Dwight K. Scrute ("The People's Scrutinee") let guard = Nothing let absChain vs t = foldr (\v t -> ABT.abs' (ann t) v t) t vs thecase t = Term.MatchCase p (fmap (absChain boundVars) guard) $ absChain boundVars t @@ -1121,13 +1324,17 @@ binding = label "binding" do mkBinding :: Ann -> [L.Token v] -> Term.Term v Ann -> Term.Term v Ann mkBinding _lhsLoc [] body = body mkBinding lhsLoc args body = - (Term.lam' (lhsLoc <> ann body) (L.payload <$> args) body) + let annotatedArgs = args <&> \arg -> (ann arg, L.payload arg) + in Term.lam' (lhsLoc <> ann body) annotatedArgs body customFailure :: (P.MonadParsec e s m) => e -> m a customFailure = P.customFailure block :: forall m v. (Monad m, Var v) => String -> P v m (Ann, Term v Ann) -block s = block' False s (openBlockWith s) closeBlock +block s = block' False False s (openBlockWith s) closeBlock + +layoutBlock :: forall m v. (Monad m, Var v) => String -> P v m (Ann, Term v Ann) +layoutBlock s = block' False False s (openBlockWith s) optionalCloseBlock -- example: use Foo.bar.Baz + ++ x -- + ++ and x are called the "suffixes" of the `use` statement, and @@ -1197,35 +1404,27 @@ substImports ns imports = ] block' :: - (Monad m, Var v) => - IsTop -> - String -> - P v m (L.Token ()) -> - P v m (L.Token ()) -> - P v m (Ann {- ann which spans the whole block -}, Term v Ann) -block' isTop = block'' isTop False - -block'' :: forall m v end. (Monad m, Var v, Annotated end) => IsTop -> - Bool -> -- `True` means insert `()` at end of block if it ends with a statement + -- | `True` means insert `()` at end of block if it ends with a statement + Bool -> String -> P v m (L.Token ()) -> P v m end -> P v m (Ann {- ann which spans the whole block -}, Term v Ann) -block'' isTop implicitUnitAtEnd s openBlock closeBlock = do +block' isTop implicitUnitAtEnd s openBlock closeBlock = do open <- openBlock (names, imports) <- imports _ <- optional semi - statements <- local (\e -> e {names = names}) $ sepBy semi statement + statements <- local (\e -> e {names}) $ sepBy semi statement end <- closeBlock body <- substImports names imports <$> go open statements pure (ann open <> ann end, body) where statement = asum [Binding <$> binding, DestructuringBind <$> destructuringBind, Action <$> blockTerm] go :: L.Token () -> [BlockElement v] -> P v m (Term v Ann) - go open bs = + go open = let finish :: Term.Term v Ann -> TermP v m finish tm = case Components.minimize' tm of Left dups -> customFailure $ DuplicateTermNames (toList dups) @@ -1265,7 +1464,7 @@ block'' isTop implicitUnitAtEnd s openBlock closeBlock = do if implicitUnitAtEnd then (toList bs, DD.unitTerm a) else (toList bs, Term.var a (positionalVar a Var.missingResult)) - in toTm bs + in toTm number :: (Var v) => TermP v m number = number' (tok Term.int) (tok Term.nat) (tok Term.float) diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index bc33c43ca2..99969f09a2 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -7,6 +7,7 @@ module Unison.Syntax.TermPrinter prettyBinding, prettyBinding', prettyBindingWithoutTypeSignature, + prettyDoc2, pretty0, runPretty, prettyPattern, @@ -14,13 +15,15 @@ module Unison.Syntax.TermPrinter where import Control.Lens (unsnoc) +import Control.Monad.Reader (ask, local) import Control.Monad.State (evalState) import Control.Monad.State qualified as State import Data.Char (isPrint) +import Data.Foldable qualified as Foldable import Data.List import Data.List qualified as List -import Data.List.NonEmpty qualified as NEL import Data.Map qualified as Map +import Data.Sequence qualified as Seq import Data.Set qualified as Set import Data.Text (unpack) import Data.Text qualified as Text @@ -35,10 +38,9 @@ import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorReference qualified as ConstructorReference import Unison.ConstructorType qualified as CT import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment) import Unison.Pattern (Pattern) import Unison.Pattern qualified as Pattern import Unison.Prelude @@ -51,10 +53,11 @@ import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Syntax.HashQualified qualified as HQ (unsafeFromVar) -import Unison.Syntax.Lexer (showEscapeChar) -import Unison.Syntax.Name qualified as Name (isSymboly, parseText, parseTextEither, toText, unsafeParseText) +import Unison.Syntax.Lexer.Unison (showEscapeChar) +import Unison.Syntax.Name qualified as Name (isSymboly, parseText, parseTextEither, toText, unsafeParseText, unsafeParseVar) import Unison.Syntax.NamePrinter (styleHashQualified'') import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) +import Unison.Syntax.Precedence (InfixPrecedence (..), Precedence (..), increment, isTopLevelPrecedence, operatorPrecedence) import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Term import Unison.Type (Type, pattern ForallsNamed') @@ -92,12 +95,13 @@ data AmbientContext = AmbientContext { -- The operator precedence of the enclosing context (a number from 0 to 11, -- or -1 to render without outer parentheses unconditionally). -- Function application has precedence 10. - precedence :: !Int, -- -2 indicates top level binding, this is occasionally useful + precedence :: !Precedence, blockContext :: !BlockContext, infixContext :: !InfixContext, imports :: !Imports, docContext :: !DocLiteralContext, - elideUnit :: !Bool -- `True` if a `()` at the end of a block should be elided + -- `True` if a `()` at the end of a block should be elided + elideUnit :: !Bool } -- Description of the position of this ABT node, when viewed in the @@ -125,50 +129,58 @@ data DocLiteralContext We illustrate precedence rules as follows. - >=10 - 10f 10x + >=Application + (Application)f (Application)x This example shows that a function application f x is enclosed in - parentheses whenever the ambient precedence around it is >= 10, and that - when printing its two components, an ambient precedence of 10 is used in + parentheses whenever the ambient precedence around it is >= Application, and that + when printing its two components, an ambient precedence of Application is used in both places. The pretty-printer uses the following rules for printing terms. - >=12 - let x = (-1)y - 1z + >=Top + let x = (Bottom)y + (Statement)z - >=11 - ! 11x - ' 11x - 11x ? + >=Prefix + ! (Prefix)x + ' (Prefix)x + (Prefix)x ? - >=10 - 10f 10x 10y ... + >=(Application) + (Application)f (Application)x (Application)y ... termLink t typeLink t - >=3 - x -> 2y - 3x + 3y + ... 3z + >=(Infix +) + (Infix +)x + (Infix +)y + ... (Infix +)z - >=2 - if 0a then 0b else 0c - handle 0b with 0h - case 2x of - a | 2g -> 0b + Printing an infix operator in infix position has the following additional + rule: If the operator has a lower precedence than the ambient precedence, + it is enclosed in parentheses. If the operator has no precedence rule, + its precedence is assumed to be higher than any operator to its right, and + lower than any operator to its left. - >=0 - 10a : 0Int + >(Control) + x -> (Control)y + + >=(Control) + if (Annotation)a then (Annotation)b else (Annotation)c + handle (Annoration)b with (Annotation)h + case (Control)x of + a | (Control)g -> (Control)b + + >=(Annotation) + (Application)a : (Annotation)Int And the following for patterns. - >=11 - x@11p + >=Prefix + x@(Prefix)p - >=10 - Con 10p 10q ... + >=Application + Con (Application)p (Application)q ... -- never any external parens added around the following { p } @@ -191,7 +203,7 @@ pretty0 a tm | isTopLevelPrecedence (precedence a) && not (isBindingSoftHangable -- we allow use clause insertion here even when it otherwise wouldn't be -- (as long as the tm isn't soft hangable, if it gets soft hung then -- adding use clauses beforehand will mess things up) - tmp <- pretty0 (a {imports = im, precedence = -1}) tm + tmp <- pretty0 (a {imports = im, precedence = Bottom}) tm pure $ PP.lines (uses <> [tmp]) where (im, uses) = calcImports (imports a) tm @@ -201,35 +213,37 @@ pretty0 blockContext = bc, infixContext = ic, imports = im, - docContext = doc, - elideUnit = elideUnit + docContext = doc } term = specialCases term \case - Var' v -> pure . parenIfInfix name ic $ styleHashQualified'' (fmt S.Var) name - where - -- OK since all term vars are user specified, any freshening was just added during typechecking - name = elideFQN im $ HQ.unsafeFromVar (Var.reset v) + Var' v -> do + env <- ask + let name = + if Set.member v env.freeTerms && Set.member v env.boundTerms + then HQ.fromName (Name.makeAbsolute (Name.unsafeParseVar v)) + else elideFQN im $ HQ.unsafeFromVar (Var.reset v) + pure . parenIfInfix name ic $ styleHashQualified'' (fmt S.Var) name Ref' r -> do - n <- getPPE - let name = elideFQN im $ PrettyPrintEnv.termName n (Referent.Ref r) + env <- ask + let name = elideFQN im $ PrettyPrintEnv.termName env.ppe (Referent.Ref r) pure . parenIfInfix name ic $ styleHashQualified'' (fmt $ S.TermReference (Referent.Ref r)) name TermLink' r -> do - n <- getPPE - let name = elideFQN im $ PrettyPrintEnv.termName n r - pure . paren (p >= 10) $ + env <- ask + let name = elideFQN im $ PrettyPrintEnv.termName env.ppe r + pure . paren (p >= Application) $ fmt S.LinkKeyword "termLink " <> parenIfInfix name ic (styleHashQualified'' (fmt $ S.TermReference r) name) TypeLink' r -> do - n <- getPPE - let name = elideFQN im $ PrettyPrintEnv.typeName n r - pure . paren (p >= 10) $ + env <- ask + let name = elideFQN im $ PrettyPrintEnv.typeName env.ppe r + pure . paren (p >= Application) $ fmt S.LinkKeyword "typeLink " <> parenIfInfix name ic (styleHashQualified'' (fmt $ S.TypeReference r) name) Ann' tm t -> do - tm' <- pretty0 (ac 10 Normal im doc) tm + tm' <- pretty0 (ac Application Normal im doc) tm tp' <- TypePrinter.pretty0 im 0 t - pure . paren (p >= 0) $ tm' <> PP.hang (fmt S.TypeAscriptionColon " :") tp' + pure . paren (p >= Annotation) $ tm' <> PP.hang (fmt S.TypeAscriptionColon " :") tp' Int' i -> pure . fmt S.NumericLiteral . l $ (if i >= 0 then ("+" ++ show i) else (show i)) Nat' u -> pure . fmt S.NumericLiteral . l $ show u Float' f -> pure . fmt S.NumericLiteral . l $ show f @@ -247,7 +261,7 @@ pretty0 where -- we only use this syntax if we're not wrapped in something else, -- to avoid possible round trip issues if the text ends at an odd column - useRaw _ | p >= 0 = Nothing + useRaw _ | p >= Annotation = Nothing useRaw s | Text.find (== '\n') s == Just '\n' && Text.all ok s = n 3 useRaw _ = Nothing ok ch = isPrint ch || ch == '\n' || ch == '\r' @@ -268,23 +282,23 @@ pretty0 Nothing -> '?' : [c] Blank' id -> pure $ fmt S.Blank $ l "_" <> l (fromMaybe "" (Blank.nameb id)) Constructor' ref -> do - n <- getPPE - let name = elideFQN im $ PrettyPrintEnv.termName n conRef + env <- ask + let name = elideFQN im $ PrettyPrintEnv.termName env.ppe conRef conRef = Referent.Con ref CT.Data pure $ styleHashQualified'' (fmt $ S.TermReference conRef) name Request' ref -> do - n <- getPPE - let name = elideFQN im $ PrettyPrintEnv.termName n conRef + env <- ask + let name = elideFQN im $ PrettyPrintEnv.termName env.ppe conRef conRef = Referent.Con ref CT.Effect pure $ styleHashQualified'' (fmt $ S.TermReference conRef) name Handle' h body -> do - pb <- pretty0 (ac 0 Block im doc) body - ph <- pretty0 (ac 0 Block im doc) h + pb <- pretty0 (ac Annotation Block im doc) body + ph <- pretty0 (ac Annotation Block im doc) h let hangHandler = case h of -- handle ... with cases LamsNamedMatch' [] _ -> \a b -> a <> " " <> b _ -> PP.hang - pure . paren (p >= 2) $ + pure . paren (p >= Control) $ if PP.isMultiLine pb || PP.isMultiLine ph then PP.lines @@ -301,36 +315,36 @@ pretty0 ] Delay' x | Match' _ _ <- x -> do - px <- pretty0 (ac 0 Block im doc) x + px <- pretty0 (ac Annotation Block im doc) x let hang = if isSoftHangable x then PP.softHang else PP.hang - pure . paren (p >= 3) $ + pure . paren (p > Control) $ fmt S.ControlKeyword "do" `hang` px | otherwise -> do let (im0', uses0) = calcImports im x - let allowUses = isLet x || p < 0 + let allowUses = isLet x || (p == Bottom) let im' = if allowUses then im0' else im let uses = if allowUses then uses0 else [] - let soft = isSoftHangable x && null uses && p < 3 + let soft = isSoftHangable x && null uses && p < Annotation let hang = if soft then PP.softHang else PP.hang - px <- pretty0 (ac 0 Block im' doc) x + px <- pretty0 (ac Annotation Block im' doc) x -- this makes sure we get proper indentation if `px` spills onto -- multiple lines, since `do` introduces layout block - let indent = PP.Width (if soft then 2 else 0) + (if soft && p < 3 then 1 else 0) - pure . paren (p >= 3) $ + let indent = PP.Width (if soft then 2 else 0) + (if soft && p < Application then 1 else 0) + pure . paren (p > Control) $ fmt S.ControlKeyword "do" `hang` PP.lines (uses <> [PP.indentNAfterNewline indent px]) List' xs -> do let listLink p = fmt (S.TypeReference Type.listRef) p let comma = listLink ", " `PP.orElse` ("\n" <> listLink ", ") - pelems <- traverse (fmap (PP.indentNAfterNewline 2) . pretty0 (ac 0 Normal im doc)) xs + pelems <- traverse (fmap (PP.indentNAfterNewline 2) . pretty0 (ac Annotation Normal im doc)) xs let open = listLink "[" `PP.orElse` listLink "[ " let close = listLink "]" `PP.orElse` ("\n" <> listLink "]") pure $ PP.group (open <> PP.sep comma pelems <> close) If' cond t f -> do - pcond <- pretty0 (ac 2 Block im doc) cond - pt <- pretty0 (ac 0 Block im doc) t - pf <- pretty0 (ac 0 Block im doc) f - pure . paren (p >= 2) $ + pcond <- pretty0 (ac Control Block im doc) cond + pt <- pretty0 (ac Annotation Block im doc) t + pf <- pretty0 (ac Annotation Block im doc) f + pure . paren (p >= Control) $ if PP.isMultiLine pcond then PP.lines @@ -352,7 +366,7 @@ pretty0 ] LetBlock bs e -> let (im', uses) = calcImports im term - in printLet elideUnit bc bs e im' uses + in printLet a {imports = im'} bc bs e uses -- Some matches are rendered as a destructuring bind, like -- match foo with (a,b) -> blah -- becomes @@ -360,19 +374,19 @@ pretty0 -- blah -- See `isDestructuringBind` definition. Match' scrutinee cs@[MatchCase pat guard (AbsN' vs body)] - | p <= 2 && isDestructuringBind scrutinee cs -> do - n <- getPPE + | p <= Control && isDestructuringBind scrutinee cs -> do + env <- ask let letIntro = case bc of Block -> id Normal -> \x -> fmt S.ControlKeyword "let" `PP.hang` x lhs <- do - let (lhs, _) = prettyPattern n (ac 0 Block im doc) 10 vs pat + let (lhs, _) = prettyPattern env.ppe (ac Annotation Block im doc) Application vs pat guard' <- printGuard guard pure $ PP.group lhs `PP.hang` guard' let eq = fmt S.BindingEquals "=" - rhs <- pretty0 (ac (-1) Block im doc) scrutinee + rhs <- pretty0 (ac Bottom Block im doc) scrutinee letIntro <$> do - prettyBody <- pretty0 (ac (-1) Block im doc) body + prettyBody <- pretty0 (ac Bottom Block im doc) body pure $ PP.lines [ (lhs <> eq) `PP.hang` rhs, @@ -382,13 +396,13 @@ pretty0 printGuard Nothing = pure mempty printGuard (Just g') = do let (_, g) = ABT.unabs g' - prettyg <- pretty0 (ac 2 Normal im doc) g + prettyg <- pretty0 (ac Control Normal im doc) g pure $ fmt S.DelimiterChar "| " <> prettyg Match' scrutinee branches -> do - ps <- pretty0 (ac 2 Normal im doc) scrutinee + ps <- pretty0 (ac Control Normal im doc) scrutinee pbs <- printCase im doc (arity1Branches branches) -- don't print with `cases` syntax - pure . paren (p >= 2) $ + pure . paren (p >= Control) $ if PP.isMultiLine ps then PP.lines @@ -396,57 +410,154 @@ pretty0 fmt S.ControlKeyword " with" `PP.hang` pbs ] else (fmt S.ControlKeyword "match " <> ps <> fmt S.ControlKeyword " with") `PP.hang` pbs - Apps' f args -> paren (p >= 10) <$> (PP.hang <$> goNormal 9 f <*> PP.spacedTraverse (goNormal 10) args) + Apps' f args -> paren (p >= Application) <$> (PP.hang <$> goNormal (InfixOp Highest) f <*> PP.spacedTraverse (goNormal Application) args) t -> pure $ l "error: " <> l (show t) where goNormal prec tm = pretty0 (ac prec Normal im doc) tm specialCases term go = do - doc <- prettyDoc2 a term - case doc of + prettyDoc2 a term >>= \case Just d -> pure d Nothing -> notDoc go where notDoc go = do - n <- getPPE + env <- ask let -- This predicate controls which binary functions we render as infix -- operators. At the moment the policy is just to render symbolic -- operators as infix. binaryOpsPred :: Term3 v PrintAnnotation -> Bool binaryOpsPred = \case - Ref' r -> isSymbolic $ PrettyPrintEnv.termName n (Referent.Ref r) + Ref' r -> isSymbolic $ PrettyPrintEnv.termName env.ppe (Referent.Ref r) Var' v -> isSymbolic $ HQ.unsafeFromVar v _ -> False + -- Gets the precedence of an infix operator, if it has one. + termPrecedence :: Term3 v PrintAnnotation -> Maybe Precedence + termPrecedence = \case + Ref' r -> + HQ.toName (PrettyPrintEnv.termName env.ppe (Referent.Ref r)) + >>= operatorPrecedence + . NameSegment.toEscapedText + . Name.lastSegment + Var' v -> + HQ.toName (HQ.unsafeFromVar v) + >>= operatorPrecedence + . NameSegment.toEscapedText + . Name.lastSegment + _ -> Nothing + prettyBinaryApp ctx term = + case (term, binaryOpsPred) of + BinaryAppPred' f a b -> + let prec = termPrecedence f + p = precedence ctx + im = imports ctx + doc = docContext ctx + in case unBinaryAppsPred' (term, binaryOpsPred) of + -- Only render infix operators as a table + -- if there's more than one of the same + -- operator in a row. + Just (apps@(_ : _ : _), lastArg) -> do + prettyLast <- pretty0 (ac (fromMaybe (InfixOp Highest) prec) Normal im doc) lastArg + prettyApps <- binaryApps apps prettyLast + pure $ paren (p > fromMaybe (InfixOp Lowest) prec) prettyApps + _ -> do + prettyF <- pretty0 (AmbientContext Application Normal Infix im doc False) f + prettyA <- prettyBinaryApp (ac (fromMaybe (InfixOp Lowest) prec) Normal im doc) a + -- We increment the precedence for the right-hand side + -- since we want parens if the right-hand side is an + -- infix operator app with the same precedence as the + -- current operator. + prettyB <- prettyBinaryApp (ac (maybe (InfixOp Highest) increment prec) Normal im doc) b + pure . parenNoGroup (p > fromMaybe (InfixOp Lowest) prec) $ + (prettyA <> " " <> prettyF <> " " <> prettyB) `PP.orElse` (prettyA <> "\n" <> PP.indent " " (prettyF <> " " <> prettyB)) + _ -> pretty0 ctx term + unBinaryAppsPred' :: + ( Term3 v PrintAnnotation, + Term3 v PrintAnnotation -> Bool + ) -> + Maybe + ( [ ( Term3 v PrintAnnotation, + Term3 v PrintAnnotation + ) + ], + Term3 v PrintAnnotation + ) + unBinaryAppsPred' (t, isInfix) = + go t isInfix + where + go t pred = + case unBinaryAppPred (t, pred) of + Just (f, x, y) -> + -- We only chain together infix operators in a table + -- if they are literally the same operator. + let inChain g = isInfix g && (g == f) + l = unBinaryAppsPred' (x, inChain) + in case l of + Just (as, xLast) -> Just ((xLast, f) : as, y) + Nothing -> Just ([(x, f)], y) + Nothing -> Nothing + + -- Render a binary infix operator sequence, like [(a2, f2), (a1, f1)], + -- meaning (a1 `f1` a2) `f2` (a3 rendered by the caller), producing + -- "a1 `f1` a2 `f2`". Except the operators are all symbolic, so we won't + -- produce any backticks. We build the result out from the right, + -- starting at `f2`. + binaryApps :: + [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)] -> + Pretty SyntaxText -> + m (Pretty SyntaxText) + binaryApps xs last = + do + let xs' = reverse xs + psh <- join <$> traverse (uncurry (r (InfixOp Lowest))) (take 1 xs') + pst <- join <$> traverse (uncurry (r (InfixOp Highest))) (drop 1 xs') + let ps = psh <> pst + let unbroken = PP.spaced (ps <> [last]) + broken = PP.hang (head ps) . PP.column2 . psCols $ tail ps <> [last] + pure (unbroken `PP.orElse` broken) + where + psCols ps = case take 2 ps of + [x, y] -> (x, y) : psCols (drop 2 ps) + [x] -> [(x, "")] + [] -> [] + _ -> undefined + r p a f = + sequenceA + [ pretty0 (ac (if isBlock a then Top else fromMaybe p (termPrecedence f)) Normal im doc) a, + pretty0 (AmbientContext Application Normal Infix im doc False) f + ] case (term, binaryOpsPred) of (DD.Doc, _) | doc == MaybeDoc -> if isDocLiteral term - then applyPPE3 prettyDoc im term + then do + env <- ask + pure (prettyDoc env.ppe im term) else pretty0 (a {docContext = NoDoc}) term (TupleTerm' [x], _) -> do let conRef = DD.pairCtorRef - name <- elideFQN im <$> applyPPE2 PrettyPrintEnv.termName conRef + env <- ask + let name = elideFQN im (PrettyPrintEnv.termName env.ppe conRef) let pair = parenIfInfix name ic $ styleHashQualified'' (fmt (S.TermReference conRef)) name - x' <- pretty0 (ac 10 Normal im doc) x - pure . paren (p >= 10) $ + x' <- pretty0 (ac Application Normal im doc) x + pure . paren (p >= Application) $ pair `PP.hang` PP.spaced [x', fmt (S.TermReference DD.unitCtorRef) "()"] (TupleTerm' xs, _) -> do let tupleLink p = fmt (S.TypeReference DD.pairRef) p let comma = tupleLink ", " `PP.orElse` ("\n" <> tupleLink ", ") - pelems <- traverse (fmap (PP.indentNAfterNewline 2) . goNormal 0) xs + pelems <- traverse (fmap (PP.indentNAfterNewline 2) . goNormal Annotation) xs let clist = PP.sep comma pelems let open = tupleLink "(" `PP.orElse` tupleLink "( " let close = tupleLink ")" `PP.orElse` ("\n" <> tupleLink ")") pure $ PP.group (open <> clist <> close) (App' f@(Builtin' "Any.Any") arg, _) -> - paren (p >= 10) <$> (PP.hang <$> goNormal 9 f <*> goNormal 10 arg) + paren (p >= Application) <$> (PP.hang <$> goNormal (InfixOp Highest) f <*> goNormal Application arg) (DD.Rewrites' rs, _) -> do let kw = fmt S.ControlKeyword "@rewrite" arr = fmt S.ControlKeyword "==>" control = fmt S.ControlKeyword - sub kw lhs = PP.sep " " <$> sequence [pure $ control kw, goNormal 0 lhs, pure arr] - go (DD.RewriteTerm' lhs rhs) = PP.hang <$> sub "term" lhs <*> goNormal 0 rhs - go (DD.RewriteCase' lhs rhs) = PP.hang <$> sub "case" lhs <*> goNormal 0 rhs + sub kw lhs = PP.sep " " <$> sequence [pure $ control kw, goNormal Annotation lhs, pure arr] + go (DD.RewriteTerm' lhs rhs) = PP.hang <$> sub "term" lhs <*> goNormal Annotation rhs + go (DD.RewriteCase' lhs rhs) = PP.hang <$> sub "case" lhs <*> goNormal Annotation rhs go (DD.RewriteSignature' vs lhs rhs) = do lhs <- TypePrinter.pretty0 im 0 lhs PP.hang (PP.sep " " (stuff lhs)) <$> TypePrinter.pretty0 im 0 rhs @@ -456,17 +567,29 @@ pretty0 <> [fmt S.Var (PP.text (Var.name v)) | v <- vs] <> (if null vs then [] else [fmt S.TypeOperator "."]) <> [lhs, arr] - go tm = goNormal 10 tm + go tm = goNormal Application tm PP.hang kw <$> fmap PP.lines (traverse go rs) (Bytes' bs, _) -> - pure $ fmt S.BytesLiteral "0xs" <> PP.shown (Bytes.fromWord8s (map fromIntegral bs)) - BinaryAppsPred' apps lastArg -> do - prettyLast <- pretty0 (ac 3 Normal im doc) lastArg - prettyApps <- binaryApps apps prettyLast - pure $ paren (p >= 3) prettyApps - -- Note that && and || are at the same precedence, which can cause - -- confusion, so for clarity we do not want to elide the parentheses in a - -- case like `(x || y) && z`. + pure $ PP.group $ fmt S.BytesLiteral "0xs" <> PP.shown (Bytes.fromWord8s (map fromIntegral bs)) + binApp@(BinaryAppPred' {}) -> do + v <- PP.group <$> prettyBinaryApp a (fst binApp) + pure v + (And' a b, _) -> do + let prec = operatorPrecedence "&&" + prettyF = fmt S.ControlKeyword "&&" + prettyA <- pretty0 (ac (fromMaybe (InfixOp Lowest) prec) Normal im doc) a + prettyB <- pretty0 (ac (fromMaybe (InfixOp Highest) prec) Normal im doc) b + pure . parenNoGroup (p > fromMaybe (InfixOp Lowest) prec) $ + (prettyA <> " " <> prettyF <> " " <> prettyB) + `PP.orElse` (prettyA <> "\n" <> PP.indent " " (prettyF <> " " <> prettyB)) + (Or' a b, _) -> do + let prec = operatorPrecedence "||" + prettyF = fmt S.ControlKeyword "||" + prettyA <- pretty0 (ac (fromMaybe (InfixOp Lowest) prec) Normal im doc) a + prettyB <- pretty0 (ac (fromMaybe (InfixOp Highest) prec) Normal im doc) b + pure . parenNoGroup (p > fromMaybe (InfixOp Lowest) prec) $ + (prettyA <> " " <> prettyF <> " " <> prettyB) + `PP.orElse` (prettyA <> "\n" <> PP.indent " " (prettyF <> " " <> prettyB)) {- When a delayed computation block is passed to a function as the last argument in a context where the ambient precedence is low enough, we can elide parentheses @@ -488,52 +611,36 @@ pretty0 ...) -} (App' x (Constructor' (ConstructorReference DD.UnitRef 0)), _) | isLeaf x -> do - px <- pretty0 (ac (if isBlock x then 0 else 9) Normal im doc) x - pure . paren (p >= 11 || isBlock x && p >= 3) $ - fmt S.DelayForceChar (l "!") <> PP.indentNAfterNewline 1 px + px <- pretty0 (ac (if isBlock x then Annotation else InfixOp Highest) Normal im doc) x + pure . paren (p >= Prefix || isBlock x && p >= (InfixOp Lowest)) $ + px <> fmt S.Unit (l "()") (Apps' f (unsnoc -> Just (args, lastArg)), _) | isSoftHangable lastArg -> do - fun <- goNormal 9 f - args' <- traverse (goNormal 10) args - lastArg' <- goNormal 0 lastArg + fun <- goNormal (InfixOp Highest) f + args' <- traverse (goNormal Application) args + lastArg' <- goNormal Annotation lastArg let softTab = PP.softbreak <> ("" `PP.orElse` " ") - pure . paren (p >= 3) $ + pure . paren (p >= (InfixOp Lowest)) $ PP.group (PP.group (PP.group (PP.sep softTab (fun : args') <> softTab)) <> lastArg') - (Ands' xs lastArg, _) -> - paren (p >= 10) <$> do - lastArg' <- pretty0 (ac 10 Normal im doc) lastArg - booleanOps (fmt S.ControlKeyword "&&") xs lastArg' - (Ors' xs lastArg, _) -> - paren (p >= 10) <$> do - lastArg' <- pretty0 (ac 10 Normal im doc) lastArg - booleanOps (fmt S.ControlKeyword "||") xs lastArg' _other -> case (term, nonForcePred) of - OverappliedBinaryAppPred' f a b r - | binaryOpsPred f -> - -- Special case for overapplied binary op - do - prettyB <- pretty0 (ac 3 Normal im doc) b - prettyR <- PP.spacedTraverse (pretty0 (ac 10 Normal im doc)) r - prettyA <- binaryApps [(f, a)] prettyB - pure $ paren True $ PP.hang prettyA prettyR AppsPred' f args -> - paren (p >= 10) <$> do - f' <- pretty0 (ac 10 Normal im doc) f - args' <- PP.spacedTraverse (pretty0 (ac 10 Normal im doc)) args + paren (p >= Application) <$> do + f' <- pretty0 (ac Application Normal im doc) f + args' <- PP.spacedTraverse (pretty0 (ac Application Normal im doc)) args pure $ f' `PP.hang` args' _other -> case (term, \v -> nonUnitArgPred v && not (isDelay term)) of (LamsNamedMatch' [] branches, _) -> do pbs <- printCase im doc branches - pure . paren (p >= 3) $ + pure . paren (p >= InfixOp Lowest) $ PP.group (fmt S.ControlKeyword "cases") `PP.hang` pbs LamsNamedPred' vs body -> do - prettyBody <- pretty0 (ac 2 Normal im doc) body + prettyBody <- pretty0 (ac Control Normal im doc) body let hang = case body of Delay' (Lets' _ _) -> PP.softHang Lets' _ _ -> PP.softHang Match' _ _ -> PP.softHang _ -> PP.hang - pure . paren (p >= 3) $ + pure . paren (p >= InfixOp Lowest) $ PP.group (varList vs <> fmt S.ControlKeyword " ->") `hang` prettyBody _other -> go term @@ -542,29 +649,6 @@ pretty0 sepList' f sep xs = fold . intersperse sep <$> traverse f xs varList = runIdentity . sepList' (Identity . PP.text . Var.name) PP.softbreak - printLet :: - Bool -> -- elideUnit - BlockContext -> - [(v, Term3 v PrintAnnotation)] -> - Term3 v PrintAnnotation -> - Imports -> - [Pretty SyntaxText] -> - m (Pretty SyntaxText) - printLet elideUnit sc bs e im uses = do - bs <- traverse printBinding bs - body <- body e - pure . paren (sc /= Block && p >= 12) . letIntro $ PP.lines (uses <> bs <> body) - where - body (Constructor' (ConstructorReference DD.UnitRef 0)) | elideUnit = pure [] - body e = (: []) <$> pretty0 (ac 0 Normal im doc) e - printBinding (v, binding) = - if Var.isAction v - then pretty0 (ac (-1) Normal im doc) binding - else renderPrettyBinding <$> prettyBinding0' (ac (-1) Normal im doc) (HQ.unsafeFromVar v) binding - letIntro = case sc of - Block -> id - Normal -> \x -> fmt S.ControlKeyword "let" `PP.hang` x - nonForcePred :: Term3 v PrintAnnotation -> Bool nonForcePred = \case Constructor' (ConstructorReference DD.DocRef _) -> False @@ -573,64 +657,58 @@ pretty0 nonUnitArgPred :: (Var v) => v -> Bool nonUnitArgPred v = Var.name v /= "()" - -- Render a binary infix operator sequence, like [(a2, f2), (a1, f1)], - -- meaning (a1 `f1` a2) `f2` (a3 rendered by the caller), producing - -- "a1 `f1` a2 `f2`". Except the operators are all symbolic, so we won't - -- produce any backticks. We build the result out from the right, - -- starting at `f2`. - binaryApps :: - [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)] -> - Pretty SyntaxText -> - m (Pretty SyntaxText) - binaryApps xs last = - do - ps <- join <$> traverse (uncurry r) (reverse xs) - let unbroken = PP.spaced (ps <> [last]) - broken = PP.hang (head ps) . PP.column2 . psCols $ tail ps <> [last] - pure (unbroken `PP.orElse` broken) - where - psCols ps = case take 2 ps of - [x, y] -> (x, y) : psCols (drop 2 ps) - [x] -> [(x, "")] - [] -> [] - _ -> undefined - r a f = - sequenceA - [ pretty0 (ac (if isBlock a then 12 else 3) Normal im doc) a, - pretty0 (AmbientContext 10 Normal Infix im doc False) f - ] +printLet :: + (MonadPretty v m) => + AmbientContext -> + BlockContext -> + [LetBindings v (Term3 v PrintAnnotation)] -> + Term3 v PrintAnnotation -> + [Pretty SyntaxText] -> + m (Pretty SyntaxText) +printLet context sc bs e uses = do + bs <- traverse (printLetBindings bindingContext) bs + body <- body e + pure . paren (sc /= Block && context.precedence >= Top) . letIntro $ PP.lines (uses <> concat bs <> body) + where + bindingContext :: AmbientContext + bindingContext = + ac Bottom Normal context.imports context.docContext + body = \case + Constructor' (ConstructorReference DD.UnitRef 0) | context.elideUnit -> pure [] + e -> List.singleton <$> pretty0 (ac Annotation Normal context.imports context.docContext) e + letIntro = case sc of + Block -> id + Normal -> (fmt S.ControlKeyword "let" `PP.hang`) + +printLetBindings :: + (MonadPretty v m) => + AmbientContext -> + LetBindings v (Term3 v PrintAnnotation) -> + m [Pretty SyntaxText] +printLetBindings context = \case + LetBindings bindings -> traverse (printLetBinding context) bindings + LetrecBindings bindings -> + let boundVars = map fst bindings + in traverse (printLetrecBinding context boundVars) bindings + +printLetBinding :: (MonadPretty v m) => AmbientContext -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText) +printLetBinding context (v, binding) + | Var.isAction v = pretty0 context binding + | otherwise = + renderPrettyBinding <$> withBoundTerm v (prettyBinding0' context (HQ.unsafeFromVar v1) binding) + where + v1 = Var.reset v - -- Render sequence of infix &&s or ||s, like [x2, x1], - -- meaning (x1 && x2) && (x3 rendered by the caller), producing - -- "x1 && x2 &&". The result is built from the right. - booleanOps :: - Pretty SyntaxText -> - [Term3 v PrintAnnotation] -> - Pretty SyntaxText -> - m (Pretty SyntaxText) - booleanOps op xs last = do - ps <- join <$> traverse r (reverse xs) - let unbroken = PP.spaced (ps <> [last]) - broken = PP.hang (head ps) . PP.column2 . psCols $ tail ps <> [last] - pure (unbroken `PP.orElse` broken) - where - psCols ps = case take 2 ps of - [x, y] -> (x, y) : psCols (drop 2 ps) - [x] -> [(x, "")] - [] -> [] - _ -> undefined - r a = - sequence - [ pretty0 (ac (if isBlock a then 12 else 10) Normal im doc) a, - pure op - ] +printLetrecBinding :: (MonadPretty v m) => AmbientContext -> [v] -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText) +printLetrecBinding context vs (v, binding) = + renderPrettyBinding <$> withBoundTerms vs (prettyBinding0' context (HQ.unsafeFromVar (Var.reset v)) binding) prettyPattern :: forall v loc. (Var v) => PrettyPrintEnv -> AmbientContext -> - Int -> + Precedence -> [v] -> Pattern loc -> (Pretty SyntaxText, [v]) @@ -648,7 +726,7 @@ prettyPattern n c@AmbientContext {imports = im} p vs patt = case patt of Pattern.Unbound _ -> (fmt S.DelimiterChar $ l "_", vs) Pattern.Var _ -> case vs of - (v : tail_vs) -> (fmt S.Var $ l $ Var.nameStr v, tail_vs) + (v : tail_vs) -> (fmt S.Var $ l $ Var.nameStr (Var.reset v), tail_vs) _ -> error "prettyPattern: Expected at least one var" Pattern.Boolean _ b -> (fmt S.BooleanLiteral $ if b then l "true" else l "false", vs) Pattern.Int _ i -> (fmt S.NumericLiteral $ (if i >= 0 then l "+" else mempty) <> l (show i), vs) @@ -657,7 +735,7 @@ prettyPattern n c@AmbientContext {imports = im} p vs patt = case patt of Pattern.Text _ t -> (fmt S.TextLiteral $ l $ show t, vs) TuplePattern pats | length pats /= 1 -> - let (pats_printed, tail_vs) = patterns (-1) vs pats + let (pats_printed, tail_vs) = patterns Bottom vs pats in (PP.parenthesizeCommas pats_printed, tail_vs) Pattern.Constructor _ ref [] -> (styleHashQualified'' (fmt $ S.TermReference conRef) name, vs) @@ -665,10 +743,10 @@ prettyPattern n c@AmbientContext {imports = im} p vs patt = case patt of name = elideFQN im $ PrettyPrintEnv.termName n conRef conRef = Referent.Con ref CT.Data Pattern.Constructor _ ref pats -> - let (pats_printed, tail_vs) = patternsSep 10 PP.softbreak vs pats + let (pats_printed, tail_vs) = patternsSep Application PP.softbreak vs pats name = elideFQN im $ PrettyPrintEnv.termName n conRef conRef = Referent.Con ref CT.Data - in ( paren (p >= 10) $ + in ( paren (p >= Application) $ styleHashQualified'' (fmt $ S.TermReference conRef) name `PP.hang` pats_printed, tail_vs @@ -676,15 +754,15 @@ prettyPattern n c@AmbientContext {imports = im} p vs patt = case patt of Pattern.As _ pat -> case vs of (v : tail_vs) -> - let (printed, eventual_tail) = prettyPattern n c 11 tail_vs pat - in (paren (p >= 11) (fmt S.Var (l $ Var.nameStr v) <> fmt S.DelimiterChar (l "@") <> printed), eventual_tail) + let (printed, eventual_tail) = prettyPattern n c Prefix tail_vs pat + in (paren (p >= Prefix) (fmt S.Var (l $ Var.nameStr (Var.reset v)) <> fmt S.DelimiterChar (l "@") <> printed), eventual_tail) _ -> error "prettyPattern: Expected at least one var" Pattern.EffectPure _ pat -> - let (printed, eventual_tail) = prettyPattern n c (-1) vs pat + let (printed, eventual_tail) = prettyPattern n c Bottom vs pat in (PP.sep " " [fmt S.DelimiterChar "{", printed, fmt S.DelimiterChar "}"], eventual_tail) Pattern.EffectBind _ ref pats k_pat -> - let (pats_printed, tail_vs) = patternsSep 10 PP.softbreak vs pats - (k_pat_printed, eventual_tail) = prettyPattern n c 0 tail_vs k_pat + let (pats_printed, tail_vs) = patternsSep Application PP.softbreak vs pats + (k_pat_printed, eventual_tail) = prettyPattern n c Annotation tail_vs k_pat name = elideFQN im $ PrettyPrintEnv.termName n conRef conRef = Referent.Con ref CT.Effect in ( PP.group @@ -700,16 +778,16 @@ prettyPattern n c@AmbientContext {imports = im} p vs patt = case patt of eventual_tail ) Pattern.SequenceLiteral _ pats -> - let (pats_printed, tail_vs) = patternsSep (-1) (fmt S.DelimiterChar ", ") vs pats + let (pats_printed, tail_vs) = patternsSep Bottom (fmt S.DelimiterChar ", ") vs pats in (fmt S.DelimiterChar "[" <> pats_printed <> fmt S.DelimiterChar "]", tail_vs) Pattern.SequenceOp _ l op r -> let (pl, lvs) = prettyPattern n c p vs l - (pr, rvs) = prettyPattern n c (p + 1) lvs r + (pr, rvs) = prettyPattern n c (increment p) lvs r f i s = (paren (p >= i) (pl <> " " <> fmt (S.Op op) s <> " " <> pr), rvs) in case op of - Pattern.Cons -> f 0 "+:" - Pattern.Snoc -> f 0 ":+" - Pattern.Concat -> f 0 "++" + Pattern.Cons -> f Annotation "+:" + Pattern.Snoc -> f Annotation ":+" + Pattern.Concat -> f Annotation "++" where l :: (IsString s) => String -> s l = fromString @@ -739,28 +817,28 @@ arity1Branches bs = [([pat], guard, body) | MatchCase pat guard body <- bs] groupCases :: (Ord v) => [MatchCase' () (Term3 v ann)] -> - [([Pattern ()], [v], [(Maybe (Term3 v ann), Term3 v ann)])] -groupCases ms = go0 ms + [([Pattern ()], [v], [(Maybe (Term3 v ann), ([v], Term3 v ann))])] +groupCases = \cases + [] -> [] + ms@((p1, _, AbsN' vs1 _) : _) -> go (p1, vs1) [] ms where - go0 [] = [] - go0 ms@((p1, _, AbsN' vs1 _) : _) = go2 (p1, vs1) [] ms - go2 (p0, vs0) acc [] = [(p0, vs0, reverse acc)] - go2 (p0, vs0) acc ms@((p1, g1, AbsN' vs body) : tl) - | p0 == p1 && vs == vs0 = go2 (p0, vs0) ((g1, body) : acc) tl - | otherwise = (p0, vs0, reverse acc) : go0 ms + go (p0, vs0) acc [] = [(p0, vs0, reverse acc)] + go (p0, vs0) acc ms@((p1, g1, AbsN' vs body) : tl) + | p0 == p1 && vs == vs0 = go (p0, vs0) ((g1, (vs, body)) : acc) tl + | otherwise = (p0, vs0, reverse acc) : groupCases ms printCase :: + forall m v. (MonadPretty v m) => Imports -> DocLiteralContext -> [MatchCase' () (Term3 v PrintAnnotation)] -> m (Pretty SyntaxText) -printCase im doc ms0 = +printCase im doc ms = PP.orElse <$> (PP.lines . alignGrid True <$> grid) <*> (PP.lines . alignGrid False <$> grid) where - ms = groupCases ms0 justify rows = zip (fmap fst . PP.align' $ fmap alignPatterns rows) $ fmap gbs rows where @@ -789,19 +867,19 @@ printCase im doc ms0 = ) justified justified = PP.leftJustify $ fmap (\(g, b) -> (g, (arrow, b))) gbs - grid = traverse go ms - patLhs env vs pats = - case pats of - [pat] -> PP.group (fst (prettyPattern env (ac 0 Block im doc) (-1) vs pat)) - pats -> PP.group - . PP.sep (PP.indentAfterNewline " " $ "," <> PP.softbreak) - . (`evalState` vs) - . for pats - $ \pat -> do - vs <- State.get - let (p, rem) = prettyPattern env (ac 0 Block im doc) (-1) vs pat - State.put rem - pure p + grid = traverse go (groupCases ms) + patLhs :: PrettyPrintEnv -> [v] -> [Pattern ()] -> Pretty SyntaxText + patLhs ppe vs = \cases + [pat] -> PP.group (fst (prettyPattern ppe (ac Annotation Block im doc) Bottom vs pat)) + pats -> PP.group + . PP.sep (PP.indentAfterNewline " " $ "," <> PP.softbreak) + . (`evalState` vs) + . for pats + $ \pat -> do + vs <- State.get + let (p, rem) = prettyPattern ppe (ac Annotation Block im doc) Bottom vs pat + State.put rem + pure p arrow = fmt S.ControlKeyword "->" -- If there's multiple guarded cases for this pattern, prints as: -- MyPattern x y @@ -811,8 +889,8 @@ printCase im doc ms0 = go (pats, vs, unzip -> (guards, bodies)) = do guards' <- traverse printGuard guards bodies' <- traverse printBody bodies - ppe <- getPPE - pure (patLhs ppe vs pats, guards', bodies') + env <- ask + pure (patLhs env.ppe vs pats, guards', bodies') where noGuards = all (== Nothing) guards printGuard Nothing | noGuards = pure mempty @@ -822,8 +900,8 @@ printCase im doc ms0 = -- strip off any Abs-chain around the guard, guard variables are rendered -- like any other variable, ex: case Foo x y | x < y -> ... PP.spaceIfNeeded (fmt S.DelimiterChar "|") - <$> pretty0 (ac 2 Normal im doc) g - printBody = pretty0 (ac 0 Block im doc) + <$> pretty0 (ac Control Normal im doc) g + printBody (vs, body) = withBoundTerms vs (pretty0 (ac Annotation Block im doc) body) -- A pretty term binding, split into the type signature (possibly empty) and the term. data PrettyBinding = PrettyBinding @@ -882,7 +960,7 @@ prettyBinding_ :: Term2 v at ap v a -> Pretty SyntaxText prettyBinding_ go ppe n tm = - runPretty (avoidShadowing tm ppe) . fmap go $ prettyBinding0 (ac (-2) Block Map.empty MaybeDoc) n tm + runPretty (avoidShadowing tm ppe) . fmap go $ prettyBinding0 (ac Basement Block Map.empty MaybeDoc) n tm prettyBinding' :: (Var v) => @@ -901,8 +979,8 @@ prettyBinding0 :: Term2 v at ap v a -> m PrettyBinding prettyBinding0 ac v tm = do - ppe <- getPPE - prettyBinding0' ac v (printAnnotate ppe tm) + env <- ask + local (set #freeTerms (ABT.freeVars tm)) (prettyBinding0' ac v (printAnnotate env.ppe tm)) prettyBinding0' :: (MonadPretty v m) => @@ -969,7 +1047,7 @@ prettyBinding0' a@AmbientContext {imports = im, docContext = doc} v term = PP.group $ PP.group (defnLhs v vs <> fmt S.BindingEquals " = ") <> prettyBody - `PP.orElse` ("\n" <> PP.indentN 2 prettyBody) + `PP.orElse` ("\n" <> PP.indentN 2 prettyBody) } _ -> pure $ @@ -1062,8 +1140,11 @@ prettyDoc n im term = spaceUnlessBroken = PP.orElse " " "" paren :: Bool -> Pretty SyntaxText -> Pretty SyntaxText -paren True s = PP.group $ fmt S.Parenthesis "(" <> s <> fmt S.Parenthesis ")" -paren False s = PP.group s +paren b s = PP.group $ parenNoGroup b s + +parenNoGroup :: Bool -> Pretty SyntaxText -> Pretty SyntaxText +parenNoGroup True s = fmt S.Parenthesis "(" <> s <> fmt S.Parenthesis ")" +parenNoGroup False s = s parenIfInfix :: HQ.HashQualified Name -> @@ -1080,12 +1161,12 @@ isSymbolic = maybe False Name.isSymboly . HQ.toName emptyAc :: AmbientContext -emptyAc = ac (-1) Normal Map.empty MaybeDoc +emptyAc = ac Bottom Normal Map.empty MaybeDoc emptyBlockAc :: AmbientContext -emptyBlockAc = ac (-1) Block Map.empty MaybeDoc +emptyBlockAc = ac Bottom Block Map.empty MaybeDoc -ac :: Int -> BlockContext -> Imports -> DocLiteralContext -> AmbientContext +ac :: Precedence -> BlockContext -> Imports -> DocLiteralContext -> AmbientContext ac prec bc im doc = AmbientContext prec bc NonInfix im doc False fmt :: S.Element r -> Pretty (S.SyntaxText' r) -> Pretty (S.SyntaxText' r) @@ -1235,7 +1316,6 @@ instance Monoid PrintAnnotation where suffixCounterTerm :: (Var v) => PrettyPrintEnv -> Set Name -> Set Name -> Term2 v at ap v a -> PrintAnnotation suffixCounterTerm n usedTm usedTy = \case - Var' v -> countHQ mempty $ HQ.unsafeFromVar v Ref' r -> countHQ usedTm $ PrettyPrintEnv.termName n (Referent.Ref r) Constructor' r | noImportRefs (r ^. ConstructorReference.reference_) -> mempty Constructor' r -> countHQ usedTm $ PrettyPrintEnv.termName n (Referent.Con r CT.Data) @@ -1263,7 +1343,7 @@ printAnnotate n tm = Set.fromList [n | v <- ABT.allVars tm, n <- varToName v] usedTypeNames = Set.fromList [n | Ann' _ ty <- ABT.subterms tm, v <- ABT.allVars ty, n <- varToName v] - varToName v = toList (Name.parseText (Var.name v)) + varToName = toList . Name.parseText . Var.name . Var.reset go :: (Ord v) => Term2 v at ap v b -> Term2 v () () v b go = extraMap' id (const ()) (const ()) @@ -1514,14 +1594,18 @@ allInSubBlock tm p s i = -- statement, need to be emitted also by this function, otherwise the `use` -- statement may come out at an enclosing scope instead. immediateChildBlockTerms :: - (Var vt, Var v) => Term2 vt at ap v a -> [Term2 vt at ap v a] + forall a ap at v vt. (Var vt, Var v) => Term2 vt at ap v a -> [Term2 vt at ap v a] immediateChildBlockTerms = \case LetBlock bs e -> concatMap doLet bs ++ handleDelay e _ -> [] where handleDelay (Delay' b) | isLet b = [b] handleDelay _ = [] - doLet (v, Ann' tm _) = doLet (v, tm) + doLet :: LetBindings v (Term2 vt at ap v a) -> [Term2 vt at ap v a] + doLet = \case + LetBindings bindings -> concatMap doLet2 bindings + LetrecBindings bindings -> concatMap doLet2 bindings + doLet2 (v, Ann' tm _) = doLet2 (v, tm) -- we don't consider 'body' to be a place we can insert a `use` -- clause unless it's already a let block. This avoids silliness like: -- x = 1 + 1 @@ -1529,10 +1613,10 @@ immediateChildBlockTerms = \case -- x = -- use Nat + -- 1 + 1 - doLet (v, LamsNamedOpt' _ body) = [body | not (Var.isAction v), isLet body] - doLet t = error (show t) [] + doLet2 (v, LamsNamedOpt' _ body) = [body | not (Var.isAction v), isLet body] + doLet2 t = error (show t) [] -isSoftHangable :: Var v => Term2 vt at ap v a -> Bool +isSoftHangable :: (Var v) => Term2 vt at ap v a -> Bool -- isSoftHangable (Delay' d) = isLet d || isSoftHangable d || case d of -- Match' scrute cases -> isDestructuringBind scrute cases -- _ -> False @@ -1578,51 +1662,142 @@ isDestructuringBind scrutinee [MatchCase pat _ (ABT.AbsN' vs _)] = Pattern.Unbound _ -> False isDestructuringBind _ _ = False -isBlock :: (Ord v) => Term2 vt at ap v a -> Bool +isBlock :: (Var v, Ord v) => Term2 vt at ap v a -> Bool isBlock tm = case tm of If' {} -> True Handle' _ _ -> True Match' _ _ -> True LetBlock _ _ -> True + DDelay' _ -> True + Delay' _ -> True _ -> False +-- A `LetBindings` is either: +-- + +-- * A list of nonrecusrive lets (e.g. let x = ... in let y = ... in let z = ... in ...), where each binding is in + +-- scope for all subsequent bindings. +-- +-- In made-up syntax: +-- +-- let +-- x = ... +-- in +-- let +-- y = ... +-- in +-- let +-- z = ... +-- in +-- body +-- + +-- * A single letrec's bindings, where each binding is in scope for all subsequent bindings. + +-- +-- In made-up syntax: +-- +-- letrec +-- x = ... +-- y = ... +-- z = ... +-- in +-- body +data LetBindings v term + = LetBindings [(v, term)] + | LetrecBindings [(v, term)] + +-- | A group of let bindings (with all bound variables cached at the top level for efficiency). +-- +-- The sequence has an invariant: no two `LetBindings` in a row (that would be a single `LetBindings`). +-- +-- For example, the bindings +-- +-- a = ... +-- b = ... +-- c = ... +-- d = ... +-- e = ... +-- f = ... +-- body +-- +-- might be two lets `a` and `b`, followed by a letrec `c` and `d`, followed by a different letrec `e`, `f`: +-- +-- let +-- a = ... +-- in +-- let +-- b = ... +-- in +-- letrec +-- c = ... +-- d = ... +-- in +-- letrec +-- e = ... +-- f = ... +-- in +-- body +data LetBindingsGroups v term + = LetBindingsGroups (Set v) (Seq (LetBindings v term)) + +instance (Ord v) => Semigroup (LetBindingsGroups v term) where + LetBindingsGroups vs1 bs1 <> LetBindingsGroups vs2 bs2 = + LetBindingsGroups (Set.union vs1 vs2) (bs1 <> bs2) + +letBindingsToLetBindingsGroups :: (Ord v) => [(v, term)] -> LetBindingsGroups v term +letBindingsToLetBindingsGroups bindings = + LetBindingsGroups (Set.fromList (map fst bindings)) (Seq.singleton (LetBindings bindings)) + +letrecBindingsToLetBindingsGroups :: (Ord v) => [(v, term)] -> LetBindingsGroups v term +letrecBindingsToLetBindingsGroups bindings = + LetBindingsGroups (Set.fromList (map fst bindings)) (Seq.singleton (LetrecBindings bindings)) + pattern LetBlock :: (Ord v) => - [(v, Term2 vt at ap v a)] -> + [LetBindings v (Term2 vt at ap v a)] -> Term2 vt at ap v a -> Term2 vt at ap v a -pattern LetBlock bindings body <- (unLetBlock -> Just (bindings, body)) +pattern LetBlock bindings body <- + (unLetBlock -> Just (LetBindingsGroups _ (Foldable.toList @Seq -> bindings), body)) -- Collects nested let/let rec blocks into one minimally nested block. -- Handy because `let` and `let rec` blocks get rendered the same way. -- We preserve nesting when the inner block shadows definitions in the -- outer block. unLetBlock :: + forall a ap at v vt. (Ord v) => Term2 vt at ap v a -> - Maybe ([(v, Term2 vt at ap v a)], Term2 vt at ap v a) -unLetBlock t = rec t + Maybe (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a) +unLetBlock = rec where - dontIntersect v1s v2s = - all (`Set.notMember` v2set) (fst <$> v1s) - where - v2set = Set.fromList (fst <$> v2s) + dontIntersect :: LetBindingsGroups v term -> LetBindingsGroups v term -> Bool + dontIntersect (LetBindingsGroups xs _) (LetBindingsGroups ys _) = + Set.disjoint xs ys + + rec :: Term2 vt at ap v a -> Maybe (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a) rec t = case unLetRecNamed t of Nothing -> nonrec t - Just (_isTop, bindings, body) -> case rec body of - Just (innerBindings, innerBody) - | dontIntersect bindings innerBindings -> - Just (bindings ++ innerBindings, innerBody) - _ -> Just (bindings, body) + Just (_isTop, bindings0, body) -> + let bindings = letrecBindingsToLetBindingsGroups bindings0 + in case rec body of + Just (innerBindings, innerBody) + | dontIntersect bindings innerBindings -> + Just (bindings <> innerBindings, innerBody) + _ -> Just (bindings, body) + + nonrec :: Term2 vt at ap v a -> Maybe (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a) nonrec t = case unLet t of Nothing -> Nothing Just (bindings0, body) -> - let bindings = [(v, b) | (_, v, b) <- bindings0] + let bindings = letBindingsToLetBindingsGroups [(v, b) | (_, v, b) <- bindings0] in case rec body of Just (innerBindings, innerBody) | dontIntersect bindings innerBindings -> - Just (bindings ++ innerBindings, innerBody) + Just (bindings <> innerBindings, innerBody) _ -> Just (bindings, body) pattern LamsNamedMatch' :: @@ -1726,7 +1901,7 @@ prettyDoc2 :: Term3 v PrintAnnotation -> m (Maybe (Pretty SyntaxText)) prettyDoc2 ac tm = do - ppe <- getPPE + env <- ask let brace p = if PP.isMultiLine p then fmt S.DocDelimiter "{{" <> PP.newline <> p <> PP.newline <> fmt S.DocDelimiter "}}" @@ -1746,11 +1921,11 @@ prettyDoc2 ac tm = do makeFence inner = PP.string $ replicate (max 3 $ longestRun '`' inner) '`' go :: Width -> Term3 v PrintAnnotation -> m (Pretty SyntaxText) go hdr = \case - (toDocTransclude ppe -> Just d) -> + (toDocTransclude env.ppe -> Just d) -> bail d - (toDocUntitledSection ppe -> Just ds) -> + (toDocUntitledSection env.ppe -> Just ds) -> sepBlankline ds - (toDocSection ppe -> Just (title, ds)) -> do + (toDocSection env.ppe -> Just (title, ds)) -> do prettyTitle <- rec title prettyDs <- intercalateMapM "\n\n" (go (hdr + 1)) ds pure $ @@ -1759,19 +1934,19 @@ prettyDoc2 ac tm = do "", PP.indentN (hdr + 1) prettyDs ] - (toDocParagraph ppe -> Just ds) -> + (toDocParagraph env.ppe -> Just ds) -> PP.wrap . mconcat <$> traverse rec ds - (toDocBulletedList ppe -> Just ds) -> do + (toDocBulletedList env.ppe -> Just ds) -> do PP.lines <$> traverse item ds where item d = ("* " <>) . PP.indentAfterNewline " " <$> rec d - (toDocNumberedList ppe -> Just (n, ds)) -> + (toDocNumberedList env.ppe -> Just (n, ds)) -> PP.column2 <$> traverse item (zip [n ..] ds) where item (n, d) = (PP.group (PP.shown n <> "."),) <$> rec d - (toDocWord ppe -> Just t) -> + (toDocWord env.ppe -> Just t) -> pure $ PP.text t - (toDocCode ppe -> Just d) -> do + (toDocCode env.ppe -> Just d) -> do inner <- rec d let quotes = -- Prefer ` if there aren't any in the inner text, @@ -1780,67 +1955,67 @@ prettyDoc2 ac tm = do then PP.string $ oneMore '\'' inner else PP.string "`" pure $ PP.group $ quotes <> inner <> quotes - (toDocJoin ppe -> Just ds) -> foldMapM rec ds - (toDocItalic ppe -> Just d) -> do + (toDocJoin env.ppe -> Just ds) -> foldMapM rec ds + (toDocItalic env.ppe -> Just d) -> do inner <- rec d let underscores = PP.string $ oneMore '_' inner pure $ PP.group $ underscores <> inner <> underscores - (toDocBold ppe -> Just d) -> do + (toDocBold env.ppe -> Just d) -> do inner <- rec d let stars = PP.string $ oneMore '*' inner pure $ PP.group $ stars <> inner <> stars - (toDocStrikethrough ppe -> Just d) -> do + (toDocStrikethrough env.ppe -> Just d) -> do inner <- rec d let quotes = PP.string $ oneMore '~' inner pure $ PP.group $ quotes <> inner <> quotes - (toDocGroup ppe -> Just d) -> + (toDocGroup env.ppe -> Just d) -> PP.group <$> rec d - (toDocColumn ppe -> Just ds) -> + (toDocColumn env.ppe -> Just ds) -> PP.lines <$> traverse rec ds - (toDocNamedLink ppe -> Just (name, target)) -> + (toDocNamedLink env.ppe -> Just (name, target)) -> do name' <- rec name target' <- rec target pure $ PP.group $ "[" <> name' <> "](" <> target' <> ")" - (toDocLink ppe -> Just e) -> pure . PP.group $ case e of + (toDocLink env.ppe -> Just e) -> pure . PP.group $ case e of Left r -> "{type " <> tyName r <> "}" Right r -> "{" <> tmName r <> "}" - (toDocEval ppe -> Just tm) -> + (toDocEval env.ppe -> Just tm) -> do inner <- pretty0 ac tm let fence = makeFence inner pure $ PP.lines [fence, inner, fence] - (toDocEvalInline ppe -> Just tm) -> + (toDocEvalInline env.ppe -> Just tm) -> do inner <- pretty0 ac tm pure $ "@eval{" <> inner <> "}" - (toDocExample ppe -> Just tm) -> + (toDocExample env.ppe -> Just tm) -> do inner <- pretty0 ac tm pure $ "``" <> inner <> "``" - (toDocExampleBlock ppe -> Just tm) -> + (toDocExampleBlock env.ppe -> Just tm) -> do inner <- pretty0 ac' tm let fence = makeFence inner pure $ PP.lines ["@typecheck " <> fence, inner, fence] where ac' = ac {elideUnit = True} - (toDocSource ppe -> Just es) -> + (toDocSource env.ppe -> Just es) -> pure . PP.group $ " @source{" <> intercalateMap ", " go es <> "}" where go (Left r, _anns) = "type " <> tyName r go (Right r, _anns) = tmName r - (toDocFoldedSource ppe -> Just es) -> + (toDocFoldedSource env.ppe -> Just es) -> pure . PP.group $ " @foldedSource{" <> intercalateMap ", " go es <> "}" where go (Left r, _anns) = "type " <> tyName r go (Right r, _anns) = tmName r - (toDocSignatureInline ppe -> Just tm) -> + (toDocSignatureInline env.ppe -> Just tm) -> pure . PP.group $ "@inlineSignature{" <> tmName tm <> "}" - (toDocSignature ppe -> Just tms) -> + (toDocSignature env.ppe -> Just tms) -> let name = if length tms == 1 then "@signature" else "@signatures" in pure . PP.group $ " " <> name <> "{" <> intercalateMap ", " tmName tms <> "}" - (toDocCodeBlock ppe -> Just (typ, txt)) -> + (toDocCodeBlock env.ppe -> Just (typ, txt)) -> pure $ let txt' = PP.text txt fence = makeFence txt' @@ -1850,7 +2025,7 @@ prettyDoc2 ac tm = do PP.group txt', fence ] - (toDocVerbatim ppe -> Just txt) -> + (toDocVerbatim env.ppe -> Just txt) -> pure $ PP.group $ PP.lines @@ -1862,15 +2037,15 @@ prettyDoc2 ac tm = do tm -> bail tm where im = imports ac - tyName r = styleHashQualified'' (fmt $ S.TypeReference r) . elideFQN im $ PrettyPrintEnv.typeName ppe r - tmName r = styleHashQualified'' (fmt $ S.TermReference r) . elideFQN im $ PrettyPrintEnv.termName ppe r + tyName r = styleHashQualified'' (fmt $ S.TypeReference r) . elideFQN im $ PrettyPrintEnv.typeName env.ppe r + tmName r = styleHashQualified'' (fmt $ S.TermReference r) . elideFQN im $ PrettyPrintEnv.termName env.ppe r rec = go hdr sepBlankline = intercalateMapM "\n\n" rec case tm of -- these patterns can introduce a {{ .. }} block - (toDocUntitledSection ppe -> Just _) -> Just . brace <$> go 1 tm - (toDocSection ppe -> Just _) -> Just . brace <$> go 1 tm - (toDocParagraph ppe -> Just _) -> Just . brace <$> go 1 tm + (toDocUntitledSection env.ppe -> Just _) -> Just . brace <$> go 1 tm + (toDocSection env.ppe -> Just _) -> Just . brace <$> go 1 tm + (toDocParagraph env.ppe -> Just _) -> Just . brace <$> go 1 tm _ -> pure Nothing toDocJoin :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation] @@ -1958,7 +2133,7 @@ toDocExample' suffix ppe (Apps' (Ref' r) [Nat' n, l@(LamsNamed' vs tm)]) | nameEndsWith ppe suffix r, ABT.freeVars l == mempty, ok tm = - Just (lam' (ABT.annotation l) (drop (fromIntegral n + 1) vs) tm) + Just (lamWithoutBindingAnns (ABT.annotation l) (drop (fromIntegral n + 1) vs) tm) where ok (Apps' f _) = ABT.freeVars f == mempty ok tm = ABT.freeVars tm == mempty @@ -2116,7 +2291,9 @@ nameEndsWith ppe suffix r = case PrettyPrintEnv.termName ppe (Referent.Ref r) of -- 1. Form the set of all local variables used anywhere in the term -- 2. When picking a name for a term, see if it is contained in this set. -- If yes: use a minimally qualified name which is longer than the suffixed name, --- but doesn't conflict with any local vars. +-- but doesn't conflict with any local vars. If even the fully-qualified +-- name conflicts with any local vars, make it absolute. (This relies on +-- disallowing absolute names for local variables). -- If no: use the suffixed name for the term -- -- The algorithm does the same for type references in signatures. @@ -2140,28 +2317,22 @@ avoidShadowing tm (PrettyPrintEnv terms types) = usedTypeNames = Set.fromList [n | Ann' _ ty <- ABT.subterms tm, v <- ABT.allVars ty, n <- varToName v] tweak :: Set Name -> (HQ'.HashQualified Name, HQ'.HashQualified Name) -> (HQ'.HashQualified Name, HQ'.HashQualified Name) - tweak used (fullName, HQ'.NameOnly suffixedName) + tweak used (HQ'.NameOnly fullName, HQ'.NameOnly suffixedName) | Set.member suffixedName used = - let revFQNSegments :: NEL.NonEmpty NameSegment - revFQNSegments = Name.reverseSegments (HQ'.toName fullName) - minimallySuffixed :: HQ'.HashQualified Name - minimallySuffixed = - revFQNSegments - -- Get all suffixes (it's inits instead of tails because name segments are in reverse order) - & NEL.inits - -- Drop the empty 'init' - & NEL.tail - & mapMaybe (fmap Name.fromReverseSegments . NEL.nonEmpty) -- Convert back into names + let resuffixifiedName :: Name + resuffixifiedName = + fullName + & Name.suffixes -- Drop the suffixes that we know are shorter than the suffixified name & List.drop (Name.countSegments suffixedName) - -- Drop the suffixes that are equal to local variables - & filter ((\n -> n `Set.notMember` used)) - & listToMaybe - & maybe fullName HQ'.NameOnly - in (fullName, minimallySuffixed) + -- Find the first (shortest) suffix that isn't in the used set + & find (\n -> n `Set.notMember` used) + -- If there isn't one, use the absolut-ified full name + & fromMaybe (Name.makeAbsolute fullName) + in (HQ'.NameOnly fullName, HQ'.NameOnly resuffixifiedName) tweak _ p = p - varToName :: Var v => v -> [Name] - varToName = toList . Name.parseText . Var.name + varToName :: (Var v) => v -> [Name] + varToName = toList . Name.parseText . Var.name . Var.reset isLeaf :: Term2 vt at ap v a -> Bool isLeaf (Var' {}) = True @@ -2169,7 +2340,3 @@ isLeaf (Constructor' {}) = True isLeaf (Request' {}) = True isLeaf (Ref' {}) = True isLeaf _ = False - --- | Indicates this is the RHS of a top-level definition. -isTopLevelPrecedence :: Int -> Bool -isTopLevelPrecedence i = i == -2 diff --git a/parser-typechecker/src/Unison/Syntax/TypeParser.hs b/parser-typechecker/src/Unison/Syntax/TypeParser.hs index ff84f94cbe..e270ef25eb 100644 --- a/parser-typechecker/src/Unison/Syntax/TypeParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TypeParser.hs @@ -31,7 +31,7 @@ type TypeP v m = P v m (Type v Ann) -- the right of a function arrow: -- valueType ::= Int | Text | App valueType valueType | Arrow valueType computationType valueType :: (Monad m, Var v) => TypeP v m -valueType = forall type1 <|> type1 +valueType = forAll type1 <|> type1 -- Computation -- computationType ::= [{effect*}] valueType @@ -101,7 +101,7 @@ sequenceTyp = do let a = ann open <> ann close pure $ Type.app a (Type.list a) t -tupleOrParenthesizedType :: Var v => TypeP v m -> TypeP v m +tupleOrParenthesizedType :: (Var v) => TypeP v m -> TypeP v m tupleOrParenthesizedType rec = do (spanAnn, ty) <- tupleOrParenthesized rec DD.unitType pair pure (ty {ABT.annotation = ABT.annotation ty <> spanAnn}) @@ -119,8 +119,8 @@ arrow rec = in chainr1 (effect <|> rec) (reserved "->" *> eff) -- "forall a b . List a -> List b -> Maybe Text" -forall :: (Var v) => TypeP v m -> TypeP v m -forall rec = do +forAll :: (Var v) => TypeP v m -> TypeP v m +forAll rec = do kw <- reserved "forall" <|> reserved "∀" vars <- fmap (fmap L.payload) . some $ prefixDefinitionName _ <- reserved "." diff --git a/parser-typechecker/src/Unison/Syntax/TypePrinter.hs b/parser-typechecker/src/Unison/Syntax/TypePrinter.hs index 271546e776..90cd52943e 100644 --- a/parser-typechecker/src/Unison/Syntax/TypePrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TypePrinter.hs @@ -17,6 +17,7 @@ module Unison.Syntax.TypePrinter ) where +import Control.Monad.Reader (ask) import Data.Map qualified as Map import Unison.Builtin.Decls qualified as DD import Unison.HashQualified (HashQualified) @@ -25,7 +26,7 @@ import Unison.Prelude import Unison.PrettyPrintEnv (PrettyPrintEnv) import Unison.PrettyPrintEnv qualified as PrettyPrintEnv import Unison.PrettyPrintEnv.FQN (Imports, elideFQN) -import Unison.PrettyPrintEnv.MonadPretty (MonadPretty, getPPE, runPretty, willCapture) +import Unison.PrettyPrintEnv.MonadPretty (Env (..), MonadPretty, runPretty, willCaptureType) import Unison.Reference (Reference, pattern Builtin) import Unison.Referent (Referent) import Unison.Settings qualified as Settings @@ -101,8 +102,8 @@ prettyRaw im p tp = go im p tp DD.TupleType' xs | length xs /= 1 -> PP.parenthesizeCommas <$> traverse (go im 0) xs -- Would be nice to use a different SyntaxHighlights color if the reference is an ability. Ref' r -> do - n <- getPPE - pure $ styleHashQualified'' (fmt $ S.TypeReference r) $ elideFQN im (PrettyPrintEnv.typeName n r) + env <- ask + pure $ styleHashQualified'' (fmt $ S.TypeReference r) $ elideFQN im (PrettyPrintEnv.typeName env.ppe r) Cycle' _ _ -> pure $ fromString "bug: TypeParser does not currently emit Cycle" Abs' _ -> pure $ fromString "bug: TypeParser does not currently emit Abs" Ann' _ _ -> pure $ fromString "bug: TypeParser does not currently emit Ann" @@ -125,7 +126,7 @@ prettyRaw im p tp = go im p tp -- are universally quantified, then we can omit the `forall` keyword -- only if the type variables are not bound in an outer scope if p < 0 && not Settings.debugRevealForalls && all Var.universallyQuantifyIfFree vs - then ifM (willCapture vs) (prettyForall p) (go im p body) + then ifM (willCaptureType vs) (prettyForall p) (go im p body) else paren (p >= 0) <$> prettyForall (-1) t@(Arrow' _ _) -> case t of EffectfulArrows' (Ref' DD.UnitRef) rest -> diff --git a/parser-typechecker/src/Unison/Typechecker.hs b/parser-typechecker/src/Unison/Typechecker.hs index d20c7bec0c..3c8c98a28b 100644 --- a/parser-typechecker/src/Unison/Typechecker.hs +++ b/parser-typechecker/src/Unison/Typechecker.hs @@ -21,13 +21,7 @@ where import Control.Lens import Control.Monad.Fail (fail) -import Control.Monad.State - ( State, - StateT, - execState, - get, - modify, - ) +import Control.Monad.State (State, StateT, execState, get, modify) import Control.Monad.Writer import Data.Foldable import Data.Map qualified as Map @@ -92,7 +86,12 @@ data Env v loc = Env -- -- This mapping is populated before typechecking with as few entries -- as are needed to help resolve variables needing TDNR in the file. - termsByShortname :: Map Name.Name [NamedReference v loc] + -- + -- - Left means a term in the file (for which we don't have a type before typechecking) + -- - Right means a term/constructor in the namespace, or a constructor in the file (for which we do have a type + -- before typechecking) + termsByShortname :: Map Name.Name [Either Name.Name (NamedReference v loc)], + topLevelComponents :: Map Name.Name (NamedReference v loc) } deriving stock (Generic) @@ -100,7 +99,7 @@ data Env v loc = Env -- a function to resolve the type of @Ref@ constructors -- contained in that term. synthesize :: - (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc) => + (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc, Semigroup loc) => PrettyPrintEnv -> Context.PatternMatchCoverageCheckAndKindInferenceSwitch -> Env v loc -> @@ -234,8 +233,7 @@ typeDirectedNameResolution ppe oldNotes oldType env = do addTypedComponent (Context.TopLevelComponent vtts) = for_ vtts \(v, typ, _) -> let name = Name.unsafeParseVar (Var.reset v) - in for_ (Name.suffixes name) \suffix -> - #termsByShortname %= Map.insertWith (<>) suffix [NamedReference name typ (Context.ReplacementVar v)] + in #topLevelComponents %= Map.insert name (NamedReference name typ (Context.ReplacementVar v)) addTypedComponent _ = pure () suggest :: [Resolution v loc] -> Result (Notes v loc) () @@ -249,7 +247,7 @@ typeDirectedNameResolution ppe oldNotes oldType env = do guard x a = if x then Just a else Nothing - suggestedVar :: Var v => v -> Text -> v + suggestedVar :: (Var v) => v -> Text -> v suggestedVar v name = case Var.typeOf v of Var.MissingResult -> v @@ -305,7 +303,12 @@ typeDirectedNameResolution ppe oldNotes oldType env = do resolveNote env = \case Context.SolvedBlank (B.Resolve loc str) v it -> do let shortname = Name.unsafeParseText (Text.pack str) - matches = Map.findWithDefault [] shortname env.termsByShortname + matches = + env.termsByShortname + & Map.findWithDefault [] shortname + & mapMaybe \case + Left longname -> Map.lookup longname env.topLevelComponents + Right namedRef -> Just namedRef suggestions <- wither (resolve it) matches pure $ Just @@ -350,7 +353,7 @@ typeDirectedNameResolution ppe oldNotes oldType env = do -- contained in the term. Returns @typ@ if successful, -- and a note about typechecking failure otherwise. check :: - (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc) => + (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc, Semigroup loc) => PrettyPrintEnv -> Env v loc -> Term v loc -> @@ -373,7 +376,7 @@ check ppe env term typ = -- tweak (Type.ForallNamed' v body) = Type.forall() v (tweak body) -- tweak t = Type.arrow() t t -- | Returns `True` if the expression is well-typed, `False` otherwise -wellTyped :: (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc) => PrettyPrintEnv -> Env v loc -> Term v loc -> f Bool +wellTyped :: (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc, Semigroup loc) => PrettyPrintEnv -> Env v loc -> Term v loc -> f Bool wellTyped ppe env term = go <$> runResultT (synthesize ppe Context.PatternMatchCoverageCheckAndKindInferenceSwitch'Enabled env term) where go (may, _) = isJust may diff --git a/parser-typechecker/src/Unison/Typechecker/Components.hs b/parser-typechecker/src/Unison/Typechecker/Components.hs index ccef8995d3..72dac37113 100644 --- a/parser-typechecker/src/Unison/Typechecker/Components.hs +++ b/parser-typechecker/src/Unison/Typechecker/Components.hs @@ -78,7 +78,7 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop blockAnn bs e) = blockAnn [(annotatedVar hdv, hdb)] e - | otherwise = Term.singleLet isTop blockAnn (hdv, hdb) e + | otherwise = Term.singleLet isTop blockAnn (annotationFor hdv) (hdv, hdb) e mklet cycle@((_, _) : _) e = Term.letRec isTop @@ -86,10 +86,7 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop blockAnn bs e) = (first annotatedVar <$> cycle) e mklet [] e = e - in -- The outer annotation is going to be meaningful, so we make - -- sure to preserve it, whereas the annotations at intermediate Abs - -- nodes aren't necessarily meaningful - Right . Just . ABT.annotate blockAnn . foldr mklet e $ cs + in Right . Just . foldr mklet e $ cs minimize _ = Right Nothing minimize' :: diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 11279cf898..87748efe6a 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -105,6 +105,7 @@ import Unison.Typechecker.TypeLookup qualified as TL import Unison.Typechecker.TypeVar qualified as TypeVar import Unison.Var (Var) import Unison.Var qualified as Var +import qualified Unison.Debug as Debug type TypeVar v loc = TypeVar.TypeVar (B.Blank loc) v @@ -358,6 +359,14 @@ data InfoNote v loc = SolvedBlank (B.Recorded loc) v (Type v loc) | Decision v loc (Term.Term v loc) | TopLevelComponent [(v, Type.Type v loc, RedundantTypeAnnotation)] + | -- The inferred type of a let or argument binding, and the scope of that binding as a loc. + -- Note that if interpreting the type of a 'v' at a given usage site, it is the caller's + -- job to use the binding with the smallest containing scope so as to respect variable + -- shadowing. + -- This is used in the LSP. + VarBinding v (Type.Type v loc) + | -- | The usage of a particular variable. We report the variable and its location so we can match a given source location with a specific symbol later in the LSP. + VarMention v loc deriving (Show) topLevelComponent :: (Var v) => [(v, Type.Type v loc, RedundantTypeAnnotation)] -> InfoNote v loc @@ -521,7 +530,18 @@ markThenRetract hint body = markThenCallWithRetract hint \retract -> adjustNotes do r <- body ctx <- retract - pure ((r, ctx), substituteSolved ctx) + let solvedCtx = substituteSolved ctx + for_ ctx \case + var@(Ann v typ) -> do + Debug.debugM Debug.Temp "Ann" var + noteVarBinding v (TypeVar.lowerType typ) + v@(Var{}) -> + Debug.debugM Debug.Temp "Var" v + (Solved _ v t) -> do + Debug.debugM Debug.Temp "Solved" v + noteVarBinding v (TypeVar.lowerType $ Type.getPolytype t) + _ -> pure () + pure ((r, ctx), solvedCtx) markThenRetract0 :: (Var v, Ord loc) => v -> M v loc a -> M v loc () markThenRetract0 markerHint body = () <$ markThenRetract markerHint body @@ -606,15 +626,15 @@ debugTrace :: String -> Bool debugTrace e | debugEnabled = trace e False debugTrace _ = False -showType :: Var v => Type.Type v a -> String +showType :: (Var v) => Type.Type v a -> String showType ty = TP.prettyStr (Just 120) PPE.empty ty -debugType :: Var v => String -> Type.Type v a -> Bool +debugType :: (Var v) => String -> Type.Type v a -> Bool debugType tag ty | debugEnabled = debugTrace $ "(" <> show tag <> "," <> showType ty <> ")" | otherwise = False -debugTypes :: Var v => String -> Type.Type v a -> Type.Type v a -> Bool +debugTypes :: (Var v) => String -> Type.Type v a -> Type.Type v a -> Bool debugTypes tag t1 t2 | debugEnabled = debugTrace $ "(" <> show tag <> ",\n " <> showType t1 <> ",\n " <> showType t2 <> ")" | otherwise = False @@ -963,7 +983,7 @@ apply' solvedExistentials t = go t Type.Ann' v k -> Type.ann a (go v) k Type.Effect1' e t -> Type.effect1 a (go e) (go t) Type.Effects' es -> Type.effects a (map go es) - Type.ForallNamed' v t' -> Type.forall a v (go t') + Type.ForallNamed' v t' -> Type.forAll a v (go t') Type.IntroOuterNamed' v t' -> Type.introOuter a v (go t') _ -> error $ "Match error in Context.apply': " ++ show t where @@ -986,7 +1006,7 @@ withEffects handled act = do pruneWanted [] want handled synthesizeApps :: - (Foldable f, Var v, Ord loc) => + (Foldable f, Var v, Ord loc, Semigroup loc) => Term v loc -> Type v loc -> f (Term v loc) -> @@ -1004,7 +1024,7 @@ synthesizeApps fun ft args = -- the process. -- e.g. in `(f:t) x` -- finds the type of (f x) given t and x. synthesizeApp :: - (Var v, Ord loc) => + (Var v, Ord loc, Semigroup loc) => Term v loc -> Type v loc -> (Term v loc, Int) -> @@ -1059,7 +1079,7 @@ vectorConstructorOfArity loc arity = do let elementVar = Var.named "elem" args = replicate arity (loc, Type.var loc elementVar) resultType = Type.app loc (Type.list loc) (Type.var loc elementVar) - vt = Type.forall loc elementVar (Type.arrows args resultType) + vt = Type.forAll loc elementVar (Type.arrows args resultType) pure vt generalizeAndUnTypeVar :: (Var v) => Type v a -> Type.Type v a @@ -1076,7 +1096,7 @@ generalizeExistentials' t = isExistential _ = False noteTopLevelType :: - (Ord loc, Var v) => + (Ord loc, Var v, Semigroup loc) => ABT.Subst f v a -> Term v loc -> Type v loc -> @@ -1085,7 +1105,7 @@ noteTopLevelType e binding typ = case binding of Term.Ann' strippedBinding _ -> do inferred <- (Just <$> synthesizeTop strippedBinding) `orElse` pure Nothing case inferred of - Nothing -> + Nothing -> do btw $ topLevelComponent [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, False)] @@ -1095,13 +1115,23 @@ noteTopLevelType e binding typ = case binding of topLevelComponent [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, redundant)] -- The signature didn't exist, so was definitely redundant - _ -> + _ -> do btw $ topLevelComponent [(Var.reset (ABT.variable e), generalizeAndUnTypeVar typ, True)] +-- | Take note of the types and locations of all bindings, including let bindings, letrec +-- bindings, lambda argument bindings and top-level bindings. +-- This information is used to provide information to the LSP after typechecking. +noteVarBinding :: (Var v) => v -> Type.Type v loc -> M v loc () +noteVarBinding v t = btw $ VarBinding v t + +noteVarMention :: (Var v) => v -> loc -> M v loc () +noteVarMention v loc = do + btw $ VarMention v loc + synthesizeTop :: - (Var v) => + (Var v, Semigroup loc) => (Ord loc) => Term v loc -> M v loc (Type v loc) @@ -1122,7 +1152,7 @@ synthesizeTop tm = do -- the process. Also collect wanted abilities. -- | Figure 11 from the paper synthesize :: - (Var v) => + (Var v, Semigroup loc) => (Ord loc) => Term v loc -> M v loc (Type v loc, Wanted v loc) @@ -1155,11 +1185,12 @@ wantRequest loc ty = -- The return value is the synthesized type together with a list of -- wanted abilities. synthesizeWanted :: - (Var v) => + (Var v, Semigroup loc) => (Ord loc) => Term v loc -> M v loc (Type v loc, Wanted v loc) -synthesizeWanted (Term.Var' v) = +synthesizeWanted trm@(Term.Var' v) = do + noteVarMention v (ABT.annotation trm) getContext >>= \ctx -> case lookupAnn ctx v of -- Var Nothing -> compilerCrash $ UndeclaredTermVariable v ctx @@ -1207,7 +1238,10 @@ synthesizeWanted (Term.Constructor' r) = synthesizeWanted tm@(Term.Request' r) = fmap (wantRequest tm) . ungeneralize . Type.purifyArrows =<< getEffectConstructorType r -synthesizeWanted (Term.Let1Top' top binding e) = do +synthesizeWanted trm@(Term.Let1Top' top binding e) = do + case trm of + ABT.Term _ loc (ABT.Abs v _) -> noteVarMention v loc + _ -> pure () (tbinding, wb) <- synthesizeBinding top binding v' <- ABT.freshen e freshenVar when (Var.isAction (ABT.variable e)) $ @@ -1216,12 +1250,12 @@ synthesizeWanted (Term.Let1Top' top binding e) = do appendContext [Ann v' tbinding] (t, w) <- synthesize (ABT.bindInheritAnnotation e (Term.var () v')) t <- applyM t - when top $ noteTopLevelType e binding tbinding + when top $ noteTopLevelType e binding tbinding want <- coalesceWanted w wb -- doRetract $ Ann v' tbinding pure (t, want) synthesizeWanted (Term.LetRecNamed' [] body) = synthesizeWanted body -synthesizeWanted (Term.LetRecTop' isTop letrec) = do +synthesizeWanted (Term.LetRecAnnotatedTop' isTop letrec) = do ((t, want), ctx2) <- markThenRetract (Var.named "let-rec-marker") $ do e <- annotateLetRecBindings isTop letrec synthesize e @@ -1325,6 +1359,7 @@ synthesizeWanted e else checkWithAbilities [et] body' ot ctx <- getContext let t = apply ctx $ Type.arrow l it (Type.effect l [et] ot) + pure (t, []) | Term.If' cond t f <- e = do cwant <- scope InIfCond $ check cond (Type.boolean l) @@ -1390,7 +1425,7 @@ synthesizeWanted _e = compilerCrash PatternMatchFailure -- can be refined later. This is a bit unusual for the algorithm we -- use, but it seems like it should be safe. synthesizeBinding :: - (Var v) => + (Var v, Semigroup loc) => (Ord loc) => Bool -> Term v loc -> @@ -1525,15 +1560,13 @@ ensurePatternCoverage theMatch _theMatchType _scrutinee scrutineeType cases = do constructorCache = mempty } (redundant, _inaccessible, uncovered) <- flip evalStateT pmcState do - checkMatch matchLoc scrutineeType cases - let checkUncovered = case Nel.nonEmpty uncovered of - Nothing -> pure () - Just xs -> failWith (UncoveredPatterns matchLoc xs) - checkRedundant = foldr (\a b -> failWith (RedundantPattern a) *> b) (pure ()) redundant + checkMatch scrutineeType cases + let checkUncovered = maybe (pure ()) (failWith . UncoveredPatterns matchLoc) $ Nel.nonEmpty uncovered + checkRedundant = foldr ((*>) . failWith . RedundantPattern) (pure ()) redundant checkUncovered *> checkRedundant checkCases :: - (Var v) => + (Var v, Semigroup loc) => (Ord loc) => Type v loc -> Type v loc -> @@ -1598,7 +1631,7 @@ requestType ps = checkCase :: forall v loc. - (Var v, Ord loc) => + (Var v, Ord loc, Semigroup loc) => Type v loc -> Type v loc -> Term.MatchCase loc (Term v loc) -> @@ -1822,9 +1855,9 @@ resetContextAfter x a = do -- their type. Also returns the freshened version of `body`. -- See usage in `synthesize` and `check` for `LetRec'` case. annotateLetRecBindings :: - (Var v, Ord loc) => + (Var v, Ord loc, Semigroup loc) => Term.IsTop -> - ((v -> M v loc v) -> M v loc ([(v, Term v loc)], Term v loc)) -> + ((v -> M v loc v) -> M v loc ([((loc, v), Term v loc)], Term v loc)) -> M v loc (Term v loc) annotateLetRecBindings isTop letrec = -- If this is a top-level letrec, then emit a TopLevelComponent note, @@ -1850,14 +1883,17 @@ annotateLetRecBindings isTop letrec = btw $ topLevelComponent ((\(v, b) -> (Var.reset v, b, False)) . unTypeVar <$> vts) pure body - else -- If this isn't a top-level letrec, then we don't have to do anything special - fst <$> annotateLetRecBindings' True + else do -- If this isn't a top-level letrec, then we don't have to do anything special + (body, _vts) <- annotateLetRecBindings' True + pure body where annotateLetRecBindings' useUserAnnotations = do (bindings, body) <- letrec freshenVar - let vs = map fst bindings + let vs = map (snd . fst) bindings + for bindings \((loc, v), _trm) -> do + noteVarMention v loc ((bindings, bindingTypes), ctx2) <- markThenRetract Var.inferOther $ do - let f (v, binding) = case binding of + let f ((_loc, v), binding) = case binding of -- If user has provided an annotation, we use that Term.Ann' e t | useUserAnnotations -> do -- Arrows in `t` with no ability lists get an attached fresh @@ -1984,7 +2020,7 @@ tweakEffects v0 t0 rewrite p ty | Type.ForallNamed' v t <- ty, v0 /= v = - second (Type.forall a v) <$> rewrite p t + second (Type.forAll a v) <$> rewrite p t | Type.Arrow' i o <- ty = do (vis, i) <- rewrite (not <$> p) i (vos, o) <- rewrite p o @@ -2097,7 +2133,7 @@ generalizeP p ctx0 ty = foldr gen (applyCtx ctx0 ty) ctx -- location of the forall is just the location of the input type -- and the location of each quantified variable is just inherited -- from its source location - Type.forall + Type.forAll (loc t) (TypeVar.Universal v) (ABT.substInheritAnnotation tv (universal' () v) t) @@ -2121,7 +2157,7 @@ variableP _ = Nothing -- See its usage in `synthesize` and `annotateLetRecBindings`. checkScoped :: forall v loc. - (Var v, Ord loc) => + (Var v, Ord loc, Semigroup loc) => Term v loc -> Type v loc -> M v loc (Type v loc, Wanted v loc) @@ -2138,7 +2174,7 @@ checkScoped e t = do (t,) <$> check e t checkScopedWith :: - (Var v) => + (Var v, Semigroup loc) => (Ord loc) => Term v loc -> Type v loc -> @@ -2400,7 +2436,7 @@ relax' nonArrow v t tv = Type.var loc (TypeVar.Existential B.Blank v) checkWantedScoped :: - (Var v) => + (Var v, Semigroup loc) => (Ord loc) => Wanted v loc -> Term v loc -> @@ -2410,7 +2446,7 @@ checkWantedScoped want m ty = scope (InCheck m ty) $ checkWanted want m ty checkWanted :: - (Var v) => + (Var v, Semigroup loc) => (Ord loc) => Wanted v loc -> Term v loc -> @@ -2432,7 +2468,10 @@ checkWanted want (Term.Lam' body) (Type.Arrow'' i es o) = do body <- pure $ ABT.bindInheritAnnotation body (Term.var () x) checkWithAbilities es body o pure want -checkWanted want (Term.Let1Top' top binding m) t = do +checkWanted want trm@(Term.Let1Top' top binding m) t = do + case trm of + ABT.Term _ loc (ABT.Abs v _) -> noteVarMention v loc + _ -> pure () (tbinding, wbinding) <- synthesizeBinding top binding want <- coalesceWanted wbinding want v <- ABT.freshen m freshenVar @@ -2445,9 +2484,9 @@ checkWanted want (Term.Let1Top' top binding m) t = do checkWanted want (Term.LetRecNamed' [] m) t = checkWanted want m t -- letrec can't have effects, so it doesn't extend the wanted set -checkWanted want (Term.LetRecTop' isTop lr) t = +checkWanted want (Term.LetRecAnnotatedTop' isTop lr) t = markThenRetractWanted (Var.named "let-rec-marker") $ do - e <- annotateLetRecBindings isTop lr + e <- annotateLetRecBindings isTop lr checkWanted want e t checkWanted want e@(Term.Match' scrut cases) t = do (scrutType, swant) <- synthesize scrut @@ -2472,7 +2511,7 @@ checkWanted want e t = do -- `m` has type `t` with abilities `es`, -- updating the context in the process. checkWithAbilities :: - (Var v) => + (Var v, Semigroup loc) => (Ord loc) => [Type v loc] -> Term v loc -> @@ -2488,7 +2527,7 @@ checkWithAbilities es m t = do -- `m` has type `t` -- updating the context in the process. check :: - (Var v) => + (Var v, Semigroup loc) => (Ord loc) => Term v loc -> Type v loc -> @@ -2561,8 +2600,7 @@ subtype tx ty = scope (InSubtype tx ty) $ do go ctx (Type.Var' (TypeVar.Existential b v)) t -- `InstantiateL` | Set.member v (existentials ctx) && notMember v (Type.freeVars t) = do - e <- extendExistential Var.inferAbility - instantiateL b v (relax' False e t) + instantiateL b v t go ctx t (Type.Var' (TypeVar.Existential b v)) -- `InstantiateR` | Set.member v (existentials ctx) && notMember v (Type.freeVars t) = do @@ -3195,7 +3233,7 @@ verifyDataDeclarations decls = forM_ (Map.toList decls) $ \(_ref, decl) -> do -- | public interface to the typechecker synthesizeClosed :: - (BuiltinAnnotation loc, Var v, Ord loc, Show loc) => + (BuiltinAnnotation loc, Var v, Ord loc, Show loc, Semigroup loc) => PrettyPrintEnv -> PatternMatchCoverageCheckAndKindInferenceSwitch -> [Type v loc] -> @@ -3284,7 +3322,7 @@ run ppe pmcSwitch datas effects m = $ Env 1 context0 synthesizeClosed' :: - (Var v, Ord loc) => + (Var v, Ord loc, Semigroup loc) => [Type v loc] -> Term v loc -> M v loc (Type v loc) diff --git a/parser-typechecker/src/Unison/UnisonFile.hs b/parser-typechecker/src/Unison/UnisonFile.hs index 9613ce1642..b3b8a12e1d 100644 --- a/parser-typechecker/src/Unison/UnisonFile.hs +++ b/parser-typechecker/src/Unison/UnisonFile.hs @@ -33,9 +33,12 @@ module Unison.UnisonFile nonEmpty, termSignatureExternalLabeledDependencies, topLevelComponents, + typecheckedToTypeLookup, typecheckedUnisonFile, Unison.UnisonFile.rewrite, prepareRewrite, + termNamespaceBindings, + typeNamespaceBindings, ) where @@ -49,12 +52,13 @@ import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorType qualified as CT import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..)) import Unison.DataDeclaration qualified as DD +import Unison.DataDeclaration qualified as DataDeclaration import Unison.Hash qualified as Hash import Unison.Hashing.V2.Convert qualified as Hashing import Unison.LabeledDependency (LabeledDependency) import Unison.LabeledDependency qualified as LD import Unison.Prelude -import Unison.Reference (Reference) +import Unison.Reference (Reference, TermReference, TypeReference) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.Term (Term) @@ -63,10 +67,12 @@ import Unison.Type (Type) import Unison.Type qualified as Type import Unison.Typechecker.TypeLookup qualified as TL import Unison.UnisonFile.Type (TypecheckedUnisonFile (..), UnisonFile (..), pattern TypecheckedUnisonFile, pattern UnisonFile) +import Unison.Util.Defns (Defns (..), DefnsF) import Unison.Util.List qualified as List import Unison.Var (Var) import Unison.Var qualified as Var import Unison.WatchKind (WatchKind, pattern TestWatch) +import Unison.WatchKind qualified as WatchKind -- | An empty Unison file. emptyUnisonFile :: UnisonFile v a @@ -78,9 +84,9 @@ emptyUnisonFile = watches = Map.empty } -leftBiasedMerge :: forall v a. Ord v => UnisonFile v a -> UnisonFile v a -> UnisonFile v a +leftBiasedMerge :: forall v a. (Ord v) => UnisonFile v a -> UnisonFile v a -> UnisonFile v a leftBiasedMerge lhs rhs = - let mergedTerms = Map.foldlWithKey' (addNotIn lhsTermNames) (terms lhs) (terms rhs) + let mergedTerms = Map.foldlWithKey' (addNotIn lhsTermNames) lhs.terms rhs.terms mergedWatches = Map.foldlWithKey' addWatch (watches lhs) (watches rhs) mergedDataDecls = Map.foldlWithKey' (addNotIn lhsTypeNames) (dataDeclarationsId lhs) (dataDeclarationsId rhs) mergedEffectDecls = Map.foldlWithKey' (addNotIn lhsTypeNames) (effectDeclarationsId lhs) (effectDeclarationsId rhs) @@ -92,7 +98,7 @@ leftBiasedMerge lhs rhs = } where lhsTermNames = - Map.keysSet (terms lhs) + Map.keysSet lhs.terms <> foldMap (\x -> Set.fromList [v | (v, _, _) <- x]) (watches lhs) lhsTypeNames = @@ -128,7 +134,7 @@ allWatches = join . Map.elems . watches -- | Get the location of a given definition in the file. definitionLocation :: (Var v) => v -> UnisonFile v a -> Maybe a definitionLocation v uf = - terms uf ^? ix v . _1 + uf.terms ^? ix v . _1 <|> watches uf ^? folded . folded . filteredBy (_1 . only v) . _2 <|> dataDeclarations uf ^? ix v . _2 . to DD.annotation <|> effectDeclarations uf ^? ix v . _2 . to (DD.annotation . DD.toDataDecl) @@ -148,7 +154,7 @@ typecheckingTerm uf = termBindings :: UnisonFile v a -> [(v, a, Term v a)] termBindings uf = - Map.foldrWithKey (\k (a, t) b -> (k, a, t) : b) [] (terms uf) + Map.foldrWithKey (\k (a, t) b -> (k, a, t) : b) [] uf.terms -- backwards compatibility with the old data type dataDeclarations' :: TypecheckedUnisonFile v a -> Map v (Reference, DataDeclaration v a) @@ -333,14 +339,22 @@ termSignatureExternalLabeledDependencies -- Returns the dependencies of the `UnisonFile` input. Needed so we can -- load information about these dependencies before starting typechecking. -dependencies :: (Monoid a, Var v) => UnisonFile v a -> Set Reference -dependencies (UnisonFile ds es ts ws) = - foldMap (DD.typeDependencies . snd) ds - <> foldMap (DD.typeDependencies . DD.toDataDecl . snd) es - <> foldMap (Term.dependencies . snd) ts - <> foldMap (foldMap (Term.dependencies . view _3)) ws - -discardTypes :: Ord v => TypecheckedUnisonFile v a -> UnisonFile v a +dependencies :: (Monoid a, Var v) => UnisonFile v a -> DefnsF Set TermReference TypeReference +dependencies file = + fold + [ Defns + { terms = Set.empty, + types = + Set.unions + [ foldMap (DD.typeDependencies . snd) file.dataDeclarationsId, + foldMap (DD.typeDependencies . DD.toDataDecl . snd) file.effectDeclarationsId + ] + }, + foldMap (Term.dependencies . snd) file.terms, + foldMap (foldMap (Term.dependencies . view _3)) file.watches + ] + +discardTypes :: (Ord v) => TypecheckedUnisonFile v a -> UnisonFile v a discardTypes (TypecheckedUnisonFileId datas effects terms watches _) = let watches' = g . mconcat <$> List.multimap watches g tup3s = [(v, a, e) | (v, a, e, _t) <- tup3s] @@ -355,6 +369,15 @@ declsToTypeLookup uf = where wrangle = Map.fromList . Map.elems +typecheckedToTypeLookup :: TypecheckedUnisonFile v a -> TL.TypeLookup v a +typecheckedToTypeLookup tuf = + TL.TypeLookup + mempty + (wrangle (dataDeclarations' tuf)) + (wrangle (effectDeclarations' tuf)) + where + wrangle = Map.fromList . Map.elems + -- Returns true if the file has any definitions or watches nonEmpty :: TypecheckedUnisonFile v a -> Bool nonEmpty uf = @@ -390,3 +413,28 @@ constructorsForDecls types uf = & fmap (DD.toDataDecl . snd) & concatMap DD.constructorVars in Set.fromList (dataConstructors <> effectConstructors) + +-- | All bindings in the term namespace: terms, test watches (since those are the only watches that are actually stored +-- in the codebase), data constructors, and effect constructors. +termNamespaceBindings :: (Ord v) => TypecheckedUnisonFile v a -> Set v +termNamespaceBindings uf = + terms <> tests <> datacons <> effcons + where + terms = foldMap (Set.fromList . map (view _1)) uf.topLevelComponents' + tests = + uf.watchComponents & foldMap \case + (WatchKind.TestWatch, watches) -> Set.fromList (map (view _1) watches) + _ -> Set.empty + datacons = foldMap (Set.fromList . DataDeclaration.constructorVars . view _2) uf.dataDeclarationsId' + effcons = + foldMap + (Set.fromList . DataDeclaration.constructorVars . DataDeclaration.toDataDecl . view _2) + uf.effectDeclarationsId' + +-- | All bindings in the term namespace: data declarations and effect declarations. +typeNamespaceBindings :: (Ord v) => TypecheckedUnisonFile v a -> Set v +typeNamespaceBindings uf = + datas <> effs + where + datas = Map.keysSet uf.dataDeclarationsId' + effs = Map.keysSet uf.effectDeclarationsId' diff --git a/parser-typechecker/src/Unison/UnisonFile/Names.hs b/parser-typechecker/src/Unison/UnisonFile/Names.hs index 87f9fb6d12..c6ead705a1 100644 --- a/parser-typechecker/src/Unison/UnisonFile/Names.hs +++ b/parser-typechecker/src/Unison/UnisonFile/Names.hs @@ -1,7 +1,13 @@ -module Unison.UnisonFile.Names where +module Unison.UnisonFile.Names + ( addNamesFromTypeCheckedUnisonFile, + environmentFor, + toNames, + toTermAndWatchNames, + typecheckedToNames, + ) +where -import Control.Lens -import Data.List.Extra (nubOrd) +import Control.Lens (_1) import Data.Map qualified as Map import Data.Set qualified as Set import Unison.ABT qualified as ABT @@ -9,33 +15,37 @@ import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..)) import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration.Names qualified as DD.Names import Unison.Hashing.V2.Convert qualified as Hashing -import Unison.Name qualified as Name import Unison.Names (Names (..)) +import Unison.Names qualified as Names import Unison.Names.ResolutionResult qualified as Names -import Unison.NamesWithHistory qualified as Names import Unison.Prelude import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.Syntax.Name qualified as Name -import Unison.Term qualified as Term import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Env (Env (..)) import Unison.UnisonFile.Error (Error (DupDataAndAbility, UnknownType)) -import Unison.UnisonFile.Type (TypecheckedUnisonFile (TypecheckedUnisonFileId), UnisonFile (UnisonFileId)) -import Unison.Util.List qualified as List +import Unison.UnisonFile.Type (TypecheckedUnisonFile, UnisonFile) import Unison.Util.Relation qualified as Relation import Unison.Var (Var) -import Unison.Var qualified as Var import Unison.WatchKind qualified as WK -toNames :: Var v => UnisonFile v a -> Names +toNames :: (Var v) => UnisonFile v a -> Names toNames uf = datas <> effects where datas = foldMap (DD.Names.dataDeclToNames' Name.unsafeParseVar) (Map.toList (UF.dataDeclarationsId uf)) effects = foldMap (DD.Names.effectDeclToNames' Name.unsafeParseVar) (Map.toList (UF.effectDeclarationsId uf)) -addNamesFromUnisonFile :: (Var v) => UnisonFile v a -> Names -> Names -addNamesFromUnisonFile unisonFile names = Names.shadowing (toNames unisonFile) names +-- | The set of all term and test watch names. No constructors. +toTermAndWatchNames :: (Var v) => UnisonFile v a -> Set v +toTermAndWatchNames uf = + Map.keysSet uf.terms + <> foldMap + ( \case + (WK.TestWatch, xs) -> Set.fromList (map (view _1) xs) + _ -> Set.empty + ) + (Map.toList uf.watches) typecheckedToNames :: (Var v) => TypecheckedUnisonFile v a -> Names typecheckedToNames uf = Names (terms <> ctors) types @@ -64,58 +74,6 @@ typecheckedToNames uf = Names (terms <> ctors) types addNamesFromTypeCheckedUnisonFile :: (Var v) => TypecheckedUnisonFile v a -> Names -> Names addNamesFromTypeCheckedUnisonFile unisonFile names = Names.shadowing (typecheckedToNames unisonFile) names -typecheckedUnisonFile0 :: (Ord v) => TypecheckedUnisonFile v a -typecheckedUnisonFile0 = TypecheckedUnisonFileId Map.empty Map.empty mempty mempty mempty - --- Substitutes free type and term variables occurring in the terms of this --- `UnisonFile` using `externalNames`. --- --- Hash-qualified names are substituted during parsing, but non-HQ names are --- substituted at the end of parsing, since they can be locally bound. Example, in --- `x -> x + math.sqrt 2`, we don't know if `math.sqrt` is locally bound until --- we are done parsing, whereas `math.sqrt#abc` can be resolved immediately --- as it can't refer to a local definition. -bindNames :: - (Var v) => - Names -> - UnisonFile v a -> - Names.ResolutionResult v a (UnisonFile v a) -bindNames names (UnisonFileId d e ts ws) = do - -- todo: consider having some kind of binding structure for terms & watches - -- so that you don't weirdly have free vars to tiptoe around. - -- The free vars should just be the things that need to be bound externally. - let termVarsSet = Map.keysSet ts <> Set.fromList (Map.elems ws >>= map (view _1)) - -- todo: can we clean up this lambda using something like `second` - ts' <- traverse (\(a, t) -> (a,) <$> Term.bindNames Name.unsafeParseVar termVarsSet names t) ts - ws' <- traverse (traverse (\(v, a, t) -> (v,a,) <$> Term.bindNames Name.unsafeParseVar termVarsSet names t)) ws - pure $ UnisonFileId d e ts' ws' - --- | Given the set of fully-qualified variable names, this computes --- a Map from unique suffixes to the fully qualified name. --- --- Example, given [foo.bar, qux.bar, baz.quaffle], this returns: --- --- Map [ foo.bar -> foo.bar --- , qux.bar -> qux.bar --- , baz.quaffle -> baz.quaffle --- , quaffle -> baz.quaffle --- ] --- --- This is used to replace variable references with their canonical --- fully qualified variables. --- --- It's used below in `environmentFor` and also during the term resolution --- process. -variableCanonicalizer :: forall v. Var v => [v] -> Map v v -variableCanonicalizer vs = - done $ List.multimap do - v <- vs - let n = Name.unsafeParseVar v - suffix <- Name.suffixes n - pure (Var.named (Name.toText suffix), v) - where - done xs = Map.fromList [(k, v) | (k, nubOrd -> [v]) <- Map.toList xs] <> Map.fromList [(v, v) | v <- vs] - -- This function computes hashes for data and effect declarations, and -- also returns a function for resolving strings to (Reference, ConstructorId) -- for parsing of pattern matching @@ -128,14 +86,16 @@ environmentFor :: Names -> Map v (DataDeclaration v a) -> Map v (EffectDeclaration v a) -> - Names.ResolutionResult v a (Either [Error v a] (Env v a)) + Names.ResolutionResult a (Either [Error v a] (Env v a)) environmentFor names dataDecls0 effectDecls0 = do - let locallyBoundTypes = variableCanonicalizer (Map.keys dataDecls0 <> Map.keys effectDecls0) - -- data decls and hash decls may reference each other, and thus must be hashed together + let locallyBoundTypes = Map.keysSet dataDecls0 <> Map.keysSet effectDecls0 + + -- data decls and effect decls may reference each other, and thus must be hashed together dataDecls :: Map v (DataDeclaration v a) <- - traverse (DD.Names.bindNames Name.unsafeParseVar locallyBoundTypes names) dataDecls0 + traverse (DD.Names.bindNames Name.unsafeParseVar Name.toVar locallyBoundTypes names) dataDecls0 effectDecls :: Map v (EffectDeclaration v a) <- - traverse (DD.withEffectDeclM (DD.Names.bindNames Name.unsafeParseVar locallyBoundTypes names)) effectDecls0 + traverse (DD.withEffectDeclM (DD.Names.bindNames Name.unsafeParseVar Name.toVar locallyBoundTypes names)) effectDecls0 + let allDecls0 :: Map v (DataDeclaration v a) allDecls0 = Map.union dataDecls (toDataDecl <$> effectDecls) hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- Hashing.hashDataDecls allDecls0 diff --git a/parser-typechecker/src/Unison/Util/EnumContainers.hs b/parser-typechecker/src/Unison/Util/EnumContainers.hs index ec61f3f8cc..b227ad3ee7 100644 --- a/parser-typechecker/src/Unison/Util/EnumContainers.hs +++ b/parser-typechecker/src/Unison/Util/EnumContainers.hs @@ -15,6 +15,7 @@ module Unison.Util.EnumContainers keysSet, restrictKeys, withoutKeys, + mapDifference, member, lookup, lookupWithDefault, @@ -31,6 +32,7 @@ module Unison.Util.EnumContainers where import Data.Bifunctor +import Data.Functor.Classes (Eq1, Ord1) import Data.IntMap.Strict qualified as IM import Data.IntSet qualified as IS import Data.Word (Word16, Word64) @@ -41,11 +43,15 @@ class EnumKey k where intToKey :: Int -> k instance EnumKey Word64 where + {-# INLINE keyToInt #-} keyToInt e = fromIntegral e + {-# INLINE intToKey #-} intToKey i = fromIntegral i instance EnumKey Word16 where + {-# INLINE keyToInt #-} keyToInt e = fromIntegral e + {-# INLINE intToKey #-} intToKey i = fromIntegral i newtype EnumMap k a = EM (IM.IntMap a) @@ -59,7 +65,9 @@ newtype EnumMap k a = EM (IM.IntMap a) ) deriving newtype ( Monoid, - Semigroup + Semigroup, + Eq1, + Ord1 ) newtype EnumSet k = ES IS.IntSet @@ -73,24 +81,31 @@ newtype EnumSet k = ES IS.IntSet Semigroup ) +{-# INLINE mapFromList #-} mapFromList :: (EnumKey k) => [(k, a)] -> EnumMap k a mapFromList = EM . IM.fromList . fmap (first keyToInt) +{-# INLINE setFromList #-} setFromList :: (EnumKey k) => [k] -> EnumSet k setFromList = ES . IS.fromList . fmap keyToInt +{-# INLINE setToList #-} setToList :: (EnumKey k) => EnumSet k -> [k] setToList (ES s) = intToKey <$> IS.toList s +{-# INLINE mapSingleton #-} mapSingleton :: (EnumKey k) => k -> a -> EnumMap k a mapSingleton e a = EM $ IM.singleton (keyToInt e) a +{-# INLINE setSingleton #-} setSingleton :: (EnumKey k) => k -> EnumSet k setSingleton e = ES . IS.singleton $ keyToInt e +{-# INLINE mapInsert #-} mapInsert :: (EnumKey k) => k -> a -> EnumMap k a -> EnumMap k a mapInsert e x (EM m) = EM $ IM.insert (keyToInt e) x m +{-# INLINE unionWith #-} unionWith :: (EnumKey k) => (a -> a -> a) -> @@ -99,6 +114,7 @@ unionWith :: EnumMap k a unionWith f (EM l) (EM r) = EM $ IM.unionWith f l r +{-# INLINE intersectionWith #-} intersectionWith :: (a -> b -> c) -> EnumMap k a -> @@ -106,50 +122,69 @@ intersectionWith :: EnumMap k c intersectionWith f (EM l) (EM r) = EM $ IM.intersectionWith f l r +{-# INLINE keys #-} keys :: (EnumKey k) => EnumMap k a -> [k] keys (EM m) = fmap intToKey . IM.keys $ m +{-# INLINE keysSet #-} keysSet :: (EnumKey k) => EnumMap k a -> EnumSet k keysSet (EM m) = ES (IM.keysSet m) +{-# INLINE restrictKeys #-} restrictKeys :: (EnumKey k) => EnumMap k a -> EnumSet k -> EnumMap k a restrictKeys (EM m) (ES s) = EM $ IM.restrictKeys m s +{-# INLINE withoutKeys #-} withoutKeys :: (EnumKey k) => EnumMap k a -> EnumSet k -> EnumMap k a withoutKeys (EM m) (ES s) = EM $ IM.withoutKeys m s +{-# INLINE mapDifference #-} +mapDifference :: (EnumKey k) => EnumMap k a -> EnumMap k b -> EnumMap k a +mapDifference (EM l) (EM r) = EM $ IM.difference l r + +{-# INLINE member #-} member :: (EnumKey k) => k -> EnumSet k -> Bool member e (ES s) = IS.member (keyToInt e) s +{-# INLINE hasKey #-} hasKey :: (EnumKey k) => k -> EnumMap k a -> Bool hasKey k (EM m) = IM.member (keyToInt k) m +{-# INLINE lookup #-} lookup :: (EnumKey k) => k -> EnumMap k a -> Maybe a lookup e (EM m) = IM.lookup (keyToInt e) m +{-# INLINE lookupWithDefault #-} lookupWithDefault :: (EnumKey k) => a -> k -> EnumMap k a -> a lookupWithDefault d e (EM m) = IM.findWithDefault d (keyToInt e) m +{-# INLINE mapWithKey #-} mapWithKey :: (EnumKey k) => (k -> a -> b) -> EnumMap k a -> EnumMap k b mapWithKey f (EM m) = EM $ IM.mapWithKey (f . intToKey) m +{-# INLINE foldMapWithKey #-} foldMapWithKey :: (EnumKey k) => (Monoid m) => (k -> a -> m) -> EnumMap k a -> m foldMapWithKey f (EM m) = IM.foldMapWithKey (f . intToKey) m +{-# INLINE mapToList #-} mapToList :: (EnumKey k) => EnumMap k a -> [(k, a)] mapToList (EM m) = first intToKey <$> IM.toList m +{-# INLINE (!) #-} (!) :: (EnumKey k) => EnumMap k a -> k -> a (!) (EM m) e = m IM.! keyToInt e +{-# INLINE findMin #-} findMin :: (EnumKey k) => EnumSet k -> k findMin (ES s) = intToKey $ IS.findMin s +{-# INLINE traverseSet_ #-} traverseSet_ :: (Applicative f) => (EnumKey k) => (k -> f ()) -> EnumSet k -> f () traverseSet_ f (ES s) = IS.foldr (\i r -> f (intToKey i) *> r) (pure ()) s +{-# INLINE interverse #-} interverse :: (Applicative f) => (a -> b -> f c) -> @@ -159,6 +194,7 @@ interverse :: interverse f (EM l) (EM r) = fmap EM . traverse id $ IM.intersectionWith f l r +{-# INLINE traverseWithKey #-} traverseWithKey :: (Applicative f) => (EnumKey k) => @@ -167,5 +203,6 @@ traverseWithKey :: f (EnumMap k b) traverseWithKey f (EM m) = EM <$> IM.traverseWithKey (f . intToKey) m +{-# INLINE setSize #-} setSize :: EnumSet k -> Int setSize (ES s) = IS.size s diff --git a/parser-typechecker/src/Unison/Util/TQueue.hs b/parser-typechecker/src/Unison/Util/TQueue.hs index 23ebfa6791..a6109f9a7d 100644 --- a/parser-typechecker/src/Unison/Util/TQueue.hs +++ b/parser-typechecker/src/Unison/Util/TQueue.hs @@ -8,8 +8,11 @@ import UnliftIO.STM hiding (TQueue) data TQueue a = TQueue (TVar (Seq a)) (TVar Word64) +prepopulatedIO :: forall a m. (MonadIO m) => Seq a -> m (TQueue a) +prepopulatedIO as = TQueue <$> newTVarIO as <*> newTVarIO (fromIntegral $ length as) + newIO :: forall a m. (MonadIO m) => m (TQueue a) -newIO = TQueue <$> newTVarIO mempty <*> newTVarIO 0 +newIO = prepopulatedIO mempty size :: TQueue a -> STM Int size (TQueue q _) = S.length <$> readTVar q diff --git a/parser-typechecker/src/Unison/Util/Text.hs b/parser-typechecker/src/Unison/Util/Text.hs index 2c5bdf3c5b..c588e35743 100644 --- a/parser-typechecker/src/Unison/Util/Text.hs +++ b/parser-typechecker/src/Unison/Util/Text.hs @@ -6,6 +6,7 @@ module Unison.Util.Text where import Data.Foldable (toList) import Data.List (foldl', unfoldr) +import Data.List qualified as L import Data.String (IsString (..)) import Data.Text qualified as T import Data.Text.Encoding qualified as T @@ -131,6 +132,25 @@ indexOf needle haystack = needle' = toLazyText needle haystack' = toLazyText haystack +-- | Return the ordinal representation of a number in English. +-- A number ending with '1' must finish with 'st' +-- A number ending with '2' must finish with 'nd' +-- A number ending with '3' must finish with 'rd' +-- _except_ for 11, 12, and 13 which must finish with 'th' +ordinal :: (IsString s) => Int -> s +ordinal n = do + let s = show n + fromString $ + s ++ case L.drop (L.length s - 2) s of + ['1', '1'] -> "th" + ['1', '2'] -> "th" + ['1', '3'] -> "th" + _ -> case last s of + '1' -> "st" + '2' -> "nd" + '3' -> "rd" + _ -> "th" + -- Drop with both a maximum size and a predicate. Yields actual number of -- dropped characters. -- diff --git a/parser-typechecker/tests/Suite.hs b/parser-typechecker/tests/Suite.hs index a3f0d89d65..4ef15dfd23 100644 --- a/parser-typechecker/tests/Suite.hs +++ b/parser-typechecker/tests/Suite.hs @@ -9,13 +9,11 @@ import System.IO import System.IO.CodePage (withCP65001) import Unison.Core.Test.Name qualified as Name import Unison.Test.ABT qualified as ABT -import Unison.Test.ANF qualified as ANF import Unison.Test.Codebase.Branch qualified as Branch import Unison.Test.Codebase.Causal qualified as Causal import Unison.Test.Codebase.Path qualified as Path import Unison.Test.CodebaseInit qualified as CodebaseInit import Unison.Test.DataDeclaration qualified as DataDeclaration -import Unison.Test.MCode qualified as MCode import Unison.Test.Referent qualified as Referent import Unison.Test.Syntax.FileParser qualified as FileParser import Unison.Test.Syntax.TermParser qualified as TermParser @@ -25,7 +23,6 @@ import Unison.Test.Type qualified as Type import Unison.Test.Typechecker qualified as Typechecker import Unison.Test.Typechecker.Context qualified as Context import Unison.Test.Typechecker.TypeError qualified as TypeError -import Unison.Test.UnisonSources qualified as UnisonSources import Unison.Test.Util.Relation qualified as Relation import Unison.Test.Util.Text qualified as Text import Unison.Test.Var qualified as Var @@ -38,7 +35,6 @@ test = Type.test, TypeError.test, TypePrinter.test, - UnisonSources.test, FileParser.test, DataDeclaration.test, Text.test, @@ -47,8 +43,6 @@ test = Causal.test, Referent.test, ABT.test, - ANF.test, - MCode.test, Var.test, Typechecker.test, Context.test, diff --git a/parser-typechecker/tests/Unison/Core/Test/Name.hs b/parser-typechecker/tests/Unison/Core/Test/Name.hs index de10924772..61293d3240 100644 --- a/parser-typechecker/tests/Unison/Core/Test/Name.hs +++ b/parser-typechecker/tests/Unison/Core/Test/Name.hs @@ -80,9 +80,9 @@ testSplitName = testSuffixes :: [Test ()] testSuffixes = [ scope "one namespace" $ expectEqual (suffixes (Name.unsafeParseText "bar")) [Name.unsafeParseText "bar"], - scope "two namespaces" $ expectEqual (suffixes (Name.unsafeParseText "foo.bar")) [Name.unsafeParseText "foo.bar", Name.unsafeParseText "bar"], - scope "multiple namespaces" $ expectEqual (suffixes (Name.unsafeParseText "foo.bar.baz")) [Name.unsafeParseText "foo.bar.baz", Name.unsafeParseText "bar.baz", Name.unsafeParseText "baz"], - scope "terms named `.`" $ expectEqual (suffixes (Name.unsafeParseText "base.`.`")) [Name.unsafeParseText "base.`.`", Name.unsafeParseText "`.`"] + scope "two namespaces" $ expectEqual (suffixes (Name.unsafeParseText "foo.bar")) [Name.unsafeParseText "bar", Name.unsafeParseText "foo.bar"], + scope "multiple namespaces" $ expectEqual (suffixes (Name.unsafeParseText "foo.bar.baz")) [Name.unsafeParseText "baz", Name.unsafeParseText "bar.baz", Name.unsafeParseText "foo.bar.baz"], + scope "terms named `.`" $ expectEqual (suffixes (Name.unsafeParseText "base.`.`")) [Name.unsafeParseText "`.`", Name.unsafeParseText "base.`.`"] ] testSuffixSearch :: [Test ()] diff --git a/parser-typechecker/tests/Unison/Test/ANF.hs b/parser-typechecker/tests/Unison/Test/ANF.hs deleted file mode 100644 index 9e2aa9c4b6..0000000000 --- a/parser-typechecker/tests/Unison/Test/ANF.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternGuards #-} - -module Unison.Test.ANF where - -import Control.Monad.Reader (ReaderT (..)) -import Control.Monad.State (evalState) -import Data.Map qualified as Map -import Data.Set qualified as Set -import Data.Word (Word64) -import EasyTest -import Unison.ABT qualified as ABT -import Unison.ABT.Normalized (Term (TAbs)) -import Unison.ConstructorReference (GConstructorReference (..)) -import Unison.Pattern qualified as P -import Unison.Reference (Reference, Reference' (Builtin)) -import Unison.Runtime.ANF as ANF -import Unison.Runtime.MCode (RefNums (..), emitCombs) -import Unison.Term qualified as Term -import Unison.Test.Common (tm) -import Unison.Type as Ty -import Unison.Util.EnumContainers as EC -import Unison.Util.Text qualified as Util.Text -import Unison.Var as Var - --- testSNF s = ok --- where --- t0 = tm s --- snf = toSuperNormal (const 0) t0 - -simpleRefs :: Reference -> RTag -simpleRefs r - | r == Ty.natRef = 0 - | r == Ty.intRef = 1 - | r == Ty.floatRef = 2 - | r == Ty.booleanRef = 3 - | r == Ty.textRef = 4 - | r == Ty.charRef = 5 - | otherwise = 100 - -runANF :: (Var v) => ANFM v a -> a -runANF m = evalState (runReaderT m Set.empty) (0, 1, []) - -testANF :: String -> Test () -testANF s - | t0 == denormalize anf = ok - | otherwise = crash $ show $ denormalize anf - where - t0 = const () `Term.amap` tm s - anf = snd . runANF $ anfTerm t0 - -testLift :: String -> Test () -testLift s = case cs of !_ -> ok - where - cs = - emitCombs (RN (const 0) (const 0)) (Builtin "Test") 0 - . superNormalize - . (\(ll, _, _, _) -> ll) - . lamLift mempty - $ tm s - -denormalizeLit :: (Var v) => Lit -> Term.Term0 v -denormalizeLit (I i) = Term.int () i -denormalizeLit (N n) = Term.nat () n -denormalizeLit (F f) = Term.float () f -denormalizeLit (T t) = Term.text () (Util.Text.toText t) -denormalizeLit (C c) = Term.char () c -denormalizeLit (LM r) = Term.termLink () r -denormalizeLit (LY r) = Term.typeLink () r - -denormalize :: (Var v) => ANormal v -> Term.Term0 v -denormalize (TVar v) = Term.var () v -denormalize (TLit l) = denormalizeLit l -denormalize (TBLit l) = denormalizeLit l -denormalize (THnd _ _ _) = - error "denormalize handler" --- = Term.match () (denormalize b) $ denormalizeHandler h -denormalize (TShift _ _ _) = - error "denormalize shift" -denormalize (TLet _ v _ bn bo) - | typeOf v == ANFBlank = ABT.subst v dbn dbo - | otherwise = Term.let1_ False [(v, dbn)] dbo - where - dbn = denormalize bn - dbo = denormalize bo -denormalize (TName _ _ _ _) = - error "can't denormalize by-name bindings" -denormalize (TMatch v cs) = - Term.match () (ABT.var v) $ denormalizeMatch cs -denormalize (TApp f args) - | FCon r 0 <- f, - r `elem` [Ty.natRef, Ty.intRef], - [v] <- args = - Term.var () v -denormalize (TApp f args) = Term.apps' df (Term.var () <$> args) - where - df = case f of - FVar v -> Term.var () v - FComb _ -> error "FComb" - FCon r n -> - Term.constructor () (ConstructorReference r (fromIntegral $ rawTag n)) - FReq r n -> - Term.request () (ConstructorReference r (fromIntegral $ rawTag n)) - FPrim _ -> error "FPrim" - FCont _ -> error "denormalize FCont" -denormalize (TFrc _) = error "denormalize TFrc" - -denormalizeRef :: RTag -> Reference -denormalizeRef r - | 0 <- rawTag r = Ty.natRef - | 1 <- rawTag r = Ty.intRef - | 2 <- rawTag r = Ty.floatRef - | 3 <- rawTag r = Ty.booleanRef - | 4 <- rawTag r = Ty.textRef - | 5 <- rawTag r = Ty.charRef - | otherwise = error "denormalizeRef" - -backReference :: Word64 -> Reference -backReference _ = error "backReference" - -denormalizeMatch :: - (Var v) => Branched (ANormal v) -> [Term.MatchCase () (Term.Term0 v)] -denormalizeMatch b - | MatchEmpty <- b = [] - | MatchIntegral m df <- b = - (dcase (ipat @Word64 @Integer Ty.intRef) <$> mapToList m) ++ dfcase df - | MatchText m df <- b = - (dcase (const @_ @Integer $ P.Text () . Util.Text.toText) <$> Map.toList m) ++ dfcase df - | MatchData r cs Nothing <- b, - [(0, ([UN], zb))] <- mapToList cs, - TAbs i (TMatch j (MatchIntegral m df)) <- zb, - i == j = - (dcase (ipat @Word64 @Integer r) <$> mapToList m) ++ dfcase df - | MatchData r m df <- b = - (dcase (dpat r) . fmap snd <$> mapToList m) ++ dfcase df - | MatchRequest hs df <- b = denormalizeHandler hs df - | MatchNumeric _ cs df <- b = - (dcase (ipat @Word64 @Integer Ty.intRef) <$> mapToList cs) ++ dfcase df - | MatchSum _ <- b = error "MatchSum not a compilation target" - where - dfcase (Just d) = - [Term.MatchCase (P.Unbound ()) Nothing $ denormalize d] - dfcase Nothing = [] - - dcase p (t, br) = Term.MatchCase (p n t) Nothing dbr - where - (n, dbr) = denormalizeBranch br - - ipat :: (Integral a) => Reference -> p -> a -> P.Pattern () - ipat r _ i - | r == Ty.natRef = P.Nat () $ fromIntegral i - | otherwise = P.Int () $ fromIntegral i - dpat r n t = P.Constructor () (ConstructorReference r (fromIntegral (fromEnum t))) (replicate n $ P.Var ()) - -denormalizeBranch :: - (Num a, Var v) => - Term ANormalF v -> - (a, ABT.Term (Term.F v () ()) v ()) -denormalizeBranch (TAbs v br) = (n + 1, ABT.abs v dbr) - where - (n, dbr) = denormalizeBranch br -denormalizeBranch tm = (0, denormalize tm) - -denormalizeHandler :: - (Var v) => - Map.Map Reference (EnumMap CTag ([Mem], ANormal v)) -> - ANormal v -> - [Term.MatchCase () (Term.Term0 v)] -denormalizeHandler cs df = dcs - where - dcs = Map.foldMapWithKey rf cs <> dfc - dfc = - [ Term.MatchCase - (P.EffectPure () (P.Var ())) - Nothing - db - ] - where - (_, db) = denormalizeBranch @Int df - rf r rcs = foldMapWithKey (cf r) rcs - cf r t b = - [ Term.MatchCase - ( P.EffectBind - () - (ConstructorReference r (fromIntegral (fromEnum t))) - (replicate n $ P.Var ()) - (P.Var ()) - ) - Nothing - db - ] - where - (n, db) = denormalizeBranch (snd b) - -test :: Test () -test = - scope "anf" . tests $ - [ scope "lift" . tests $ - [ testLift - "let\n\ - \ g = m x -> ##Nat.+ x m\n\ - \ m -> g m m", - testLift - "m n -> let\n\ - \ f acc i = match i with\n\ - \ 0 -> acc\n\ - \ _ -> f (##Nat.+ acc n) (##Nat.sub i 1)\n\ - \ f 0 m" - ], - scope "denormalize" . tests $ - [ testANF "1", - testANF "1 + 2", - testANF - "match x with\n\ - \ +1 -> foo\n\ - \ +2 -> bar\n\ - \ +3 -> baz", - testANF - "1 + match x with\n\ - \ +1 -> foo\n\ - \ +2 -> bar", - testANF "(match x with +3 -> foo) + (match x with +2 -> foo)" - ] - ] diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs index 96fb0aca65..77cb80718e 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs @@ -6,7 +6,7 @@ import Data.Maybe (fromJust) import EasyTest import Unison.Codebase.Path (Path (..), Path' (..), Relative (..)) import Unison.Codebase.Path.Parse (parseHQSplit', parseShortHashOrHQSplit') -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.NameSegment.Internal (NameSegment (NameSegment)) import Unison.Prelude import Unison.ShortHash qualified as SH diff --git a/parser-typechecker/tests/Unison/Test/Common.hs b/parser-typechecker/tests/Unison/Test/Common.hs index ba1e5916c0..e1d880002c 100644 --- a/parser-typechecker/tests/Unison/Test/Common.hs +++ b/parser-typechecker/tests/Unison/Test/Common.hs @@ -87,5 +87,7 @@ parsingEnv = Parser.ParsingEnv { uniqueNames = mempty, uniqueTypeGuid = \_ -> pure Nothing, - names = B.names + names = B.names, + maybeNamespace = Nothing, + localNamespacePrefixedTypesAndConstructors = mempty } diff --git a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs index f7e66a7ada..425d9bd267 100644 --- a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs +++ b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs @@ -88,7 +88,7 @@ unhashComponentTest = inventedVarsFreshnessTest = let var = Type.var () app = Type.app () - forall = Type.forall () + forAll = Type.forAll () (-->) = Type.arrow () h = Hash.fromByteString (encodeUtf8 "abcd") ref = R.Id h 0 @@ -104,8 +104,8 @@ unhashComponentTest = annotation = (), bound = [], constructors' = - [ ((), nil, forall a (listType `app` var a)), - ((), cons, forall b (var b --> listType `app` var b --> listType `app` var b)) + [ ((), nil, forAll a (listType `app` var a)), + ((), cons, forAll b (var b --> listType `app` var b --> listType `app` var b)) ] } component :: Map R.Id (Decl Symbol ()) @@ -120,7 +120,7 @@ unhashComponentTest = in tests [ -- check that `nil` constructor's type did not collapse to `forall a. a a`, -- which would happen if the var invented for `listRef` was simply `Var.refNamed listRef` - expectEqual (forall z (listType' `app` var z)) nilType', + expectEqual (forAll z (listType' `app` var z)) nilType', -- check that the variable assigned to `listRef` is different from `cons`, -- which would happen if the var invented for `listRef` was simply `Var.refNamed listRef` expectNotEqual cons listVar diff --git a/parser-typechecker/tests/Unison/Test/MCode.hs b/parser-typechecker/tests/Unison/Test/MCode.hs deleted file mode 100644 index 8224914d6d..0000000000 --- a/parser-typechecker/tests/Unison/Test/MCode.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeApplications #-} - -module Unison.Test.MCode where - -import Control.Concurrent.STM -import Data.Map.Strict qualified as Map -import EasyTest -import Unison.Reference (Reference, Reference' (Builtin)) -import Unison.Runtime.ANF - ( SuperGroup (..), - lamLift, - superNormalize, - ) -import Unison.Runtime.MCode - ( Args (..), - Branch (..), - Instr (..), - Section (..), - ) -import Unison.Runtime.Machine - ( CCache (..), - apply0, - baseCCache, - cacheAdd, - ) -import Unison.Runtime.Pattern -import Unison.Symbol (Symbol) -import Unison.Term (unannotate) -import Unison.Test.Common (tm) - -dummyRef :: Reference -dummyRef = Builtin "dummy" - -mainRef :: Reference -mainRef = Builtin "main" - -modifyTVarTest :: TVar a -> (a -> a) -> Test () -modifyTVarTest v f = io . atomically $ modifyTVar v f - -testEval0 :: [(Reference, SuperGroup Symbol)] -> SuperGroup Symbol -> Test () -testEval0 env main = - ok << io do - cc <- baseCCache False - _ <- cacheAdd ((mainRef, main) : env) cc - rtm <- readTVarIO (refTm cc) - apply0 Nothing cc Nothing (rtm Map.! mainRef) - where - (<<) = flip (>>) - -asrt :: Section -asrt = - Ins (Unpack Nothing 0) $ - Match 0 $ - Test1 - 1 - (Yield (BArg1 0)) - (Die "assertion failed") - -multRec :: String -multRec = - "let\n\ - \ n = 5\n\ - \ f acc i = match i with\n\ - \ 0 -> acc\n\ - \ _ -> f (##Nat.+ acc n) (##Nat.sub i 1)\n\ - \ if (##Nat.== (f 0 1000) 5000) then () else ##bug ()" - -testEval :: String -> Test () -testEval s = testEval0 (fmap superNormalize <$> ctx) (superNormalize ll) - where - (ll, _, ctx, _) = - lamLift mempty - . splitPatterns builtinDataSpec - . unannotate - $ tm s - -nested :: String -nested = - "let\n\ - \ x = match 2 with\n\ - \ 0 -> ##Nat.+ 0 1\n\ - \ m@n -> n\n\ - \ if (##Nat.== x 2) then () else ##bug ()" - -matching'arguments :: String -matching'arguments = - "let\n\ - \ f x y z = y\n\ - \ g x = f x\n\ - \ blorf = let\n\ - \ a = 0\n\ - \ b = 1\n\ - \ d = 2\n\ - \ h = g a b\n\ - \ c = 2\n\ - \ h c\n\ - \ if (##Nat.== blorf 1) then () else ##bug ()" - -test :: Test () -test = - scope "mcode" . tests $ - [ scope "2=2" $ testEval "if (##Nat.== 2 2) then () else ##bug ()", - scope "2=1+1" $ testEval "if (##Nat.== 2 (##Nat.+ 1 1)) then () else ##bug ()", - scope "2=3-1" $ testEval "if (##Nat.== 2 (##Nat.sub 3 1)) then () else ##bug ()", - scope "5*5=25" $ - testEval "if (##Nat.== (##Nat.* 5 5) 25) then () else ##bug ()", - scope "5*1000=5000" $ - testEval "if (##Nat.== (##Nat.* 5 1000) 5000) then () else ##bug ()", - scope "5*1000=5000 rec" $ testEval multRec, - scope "nested" $ - testEval nested, - scope "matching arguments" $ - testEval matching'arguments - ] diff --git a/parser-typechecker/tests/Unison/Test/Syntax/FileParser.hs b/parser-typechecker/tests/Unison/Test/Syntax/FileParser.hs index f436e5efe3..7896d75fd9 100644 --- a/parser-typechecker/tests/Unison/Test/Syntax/FileParser.hs +++ b/parser-typechecker/tests/Unison/Test/Syntax/FileParser.hs @@ -60,9 +60,7 @@ test = emptyWatchTest, signatureNeedsAccompanyingBodyTest, emptyBlockTest, - expectedBlockOpenTest, - unknownDataConstructorTest, - unknownAbilityConstructorTest + expectedBlockOpenTest ] expectFileParseFailure :: String -> (P.Error Symbol -> Test ()) -> Test () @@ -117,26 +115,6 @@ expectedBlockOpenTest = P.ExpectedBlockOpen _ _ -> ok _ -> crash "Error wasn't ExpectedBlockOpen" -unknownDataConstructorTest :: Test () -unknownDataConstructorTest = - scope "unknownDataConstructorTest" $ - expectFileParseFailure "m a = match a with A -> 1" expectation - where - expectation :: (Var e) => P.Error e -> Test () - expectation e = case e of - P.UnknownDataConstructor _ _ -> ok - _ -> crash "Error wasn't UnknownDataConstructor" - -unknownAbilityConstructorTest :: Test () -unknownAbilityConstructorTest = - scope "unknownAbilityConstructorTest" $ - expectFileParseFailure "f e = match e with {E t -> u} -> 1" expectation - where - expectation :: (Var e) => P.Error e -> Test () - expectation e = case e of - P.UnknownAbilityConstructor _ _ -> ok - _ -> crash "Error wasn't UnknownAbilityConstructor" - parses :: String -> Test () parses s = scope s $ do let p :: UnisonFile Symbol P.Ann diff --git a/parser-typechecker/tests/Unison/Test/Term.hs b/parser-typechecker/tests/Unison/Test/Term.hs index ae75589ac6..4791382bd9 100644 --- a/parser-typechecker/tests/Unison/Test/Term.hs +++ b/parser-typechecker/tests/Unison/Test/Term.hs @@ -33,7 +33,7 @@ test = Type.arrow () (tv "a") (tv "x") ) ) - (Type.forall () (v "a") (tv "a")) + (Type.forAll () (v "a") (tv "a")) tm' = Term.substTypeVar (v "x") (tv "a") tm expected = Term.ann @@ -45,7 +45,7 @@ test = Type.arrow () (Type.var () $ v1 "a") (tv "a") ) ) - (Type.forall () (v1 "a") (Type.var () $ v1 "a")) + (Type.forAll () (v1 "a") (Type.var () $ v1 "a")) note $ show tm' note $ show expected expect $ tm == tm @@ -57,7 +57,7 @@ test = ref = R.Id h 0 v1 = Var.unnamedRef @Symbol ref -- input component: `ref = \v1 -> ref` - component = Map.singleton ref (Term.lam () v1 (Term.refId () ref)) + component = Map.singleton ref (Term.lam () ((), v1) (Term.refId () ref)) component' = Term.unhashComponent component -- expected unhashed component: `v2 = \v1 -> v2`, where `v2 /= v1`, -- i.e. `v2` cannot be just `ref` converted to a ref-named variable, diff --git a/parser-typechecker/tests/Unison/Test/Type.hs b/parser-typechecker/tests/Unison/Test/Type.hs index de22ec80bf..767addedcd 100644 --- a/parser-typechecker/tests/Unison/Test/Type.hs +++ b/parser-typechecker/tests/Unison/Test/Type.hs @@ -28,7 +28,7 @@ test = v2 = Var.named "b" vt = var () v vt2 = var () v2 - x = forall () v (nat () --> effect () [vt, builtin () "eff"] (nat ())) :: Type Symbol () - y = forall () v2 (nat () --> effect () [vt2] (nat ())) :: Type Symbol () + x = forAll () v (nat () --> effect () [vt, builtin () "eff"] (nat ())) :: Type Symbol () + y = forAll () v2 (nat () --> effect () [vt2] (nat ())) :: Type Symbol () expect . not $ Typechecker.isSubtype x y ] diff --git a/parser-typechecker/tests/Unison/Test/Typechecker.hs b/parser-typechecker/tests/Unison/Test/Typechecker.hs index 6fe94b59be..ce39af19c2 100644 --- a/parser-typechecker/tests/Unison/Test/Typechecker.hs +++ b/parser-typechecker/tests/Unison/Test/Typechecker.hs @@ -18,12 +18,12 @@ test = isSubtypeTest :: Test () isSubtypeTest = let symbol i n = Symbol i (Var.User n) - forall v t = Type.forall () v t + forAll v t = Type.forAll () v t var v = Type.var () v a = symbol 0 "a" a_ i = symbol i "a" - lhs = forall a (var a) -- ∀a. a + lhs = forAll a (var a) -- ∀a. a rhs_ i = var (a_ i) -- a_i in -- check that `∀a. a <: a_i` (used to fail for i = 2, 3) tests [expectSubtype lhs (rhs_ i) | i <- [0 .. 5]] diff --git a/parser-typechecker/tests/Unison/Test/Util/Text.hs b/parser-typechecker/tests/Unison/Test/Util/Text.hs index e5e13e9d55..245ca3424e 100644 --- a/parser-typechecker/tests/Unison/Test/Util/Text.hs +++ b/parser-typechecker/tests/Unison/Test/Util/Text.hs @@ -46,10 +46,8 @@ test = scope "<>" . expect' $ Text.toText (t1s <> t2s <> t3s) == t1 <> t2 <> t3 scope "Ord" . expect' $ - (t1 <> t2 <> t3) - `compare` t3 - == (t1s <> t2s <> t3s) - `compare` t3s + (t1 <> t2 <> t3) `compare` t3 + == (t1s <> t2s <> t3s) `compare` t3s scope "take" . expect' $ Text.toText (Text.take k (t1s <> t2s)) == T.take k (t1 <> t2) scope "drop" . expect' $ @@ -178,7 +176,28 @@ test = ) (P.Join [P.Capture (P.Literal "zzzaaa"), P.Capture (P.Literal "!")]) in P.run p "zzzaaa!!!" - ok + ok, + scope "ordinal" do + expectEqual (Text.ordinal 1) ("1st" :: String) + expectEqual (Text.ordinal 2) ("2nd" :: String) + expectEqual (Text.ordinal 3) ("3rd" :: String) + expectEqual (Text.ordinal 4) ("4th" :: String) + expectEqual (Text.ordinal 5) ("5th" :: String) + expectEqual (Text.ordinal 10) ("10th" :: String) + expectEqual (Text.ordinal 11) ("11th" :: String) + expectEqual (Text.ordinal 12) ("12th" :: String) + expectEqual (Text.ordinal 13) ("13th" :: String) + expectEqual (Text.ordinal 14) ("14th" :: String) + expectEqual (Text.ordinal 21) ("21st" :: String) + expectEqual (Text.ordinal 22) ("22nd" :: String) + expectEqual (Text.ordinal 23) ("23rd" :: String) + expectEqual (Text.ordinal 24) ("24th" :: String) + expectEqual (Text.ordinal 111) ("111th" :: String) + expectEqual (Text.ordinal 112) ("112th" :: String) + expectEqual (Text.ordinal 113) ("113th" :: String) + expectEqual (Text.ordinal 121) ("121st" :: String) + expectEqual (Text.ordinal 122) ("122nd" :: String) + expectEqual (Text.ordinal 123) ("123rd" :: String) ] where log2 :: Int -> Int diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 7a9a467093..0e8691bbb2 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -17,14 +17,6 @@ source-repository head type: git location: https://github.com/unisonweb/unison -flag arraychecks - manual: True - default: False - -flag optimized - manual: True - default: True - library exposed-modules: U.Codebase.Branch.Diff @@ -48,7 +40,6 @@ library Unison.Codebase.CodeLookup.Util Unison.Codebase.Editor.DisplayObject Unison.Codebase.Editor.RemoteRepo - Unison.Codebase.Execute Unison.Codebase.FileCodebase Unison.Codebase.Init Unison.Codebase.Init.CreateCodebaseError @@ -60,8 +51,8 @@ library Unison.Codebase.Patch Unison.Codebase.Path Unison.Codebase.Path.Parse + Unison.Codebase.ProjectPath Unison.Codebase.PushBehavior - Unison.Codebase.RootBranchCache Unison.Codebase.Runtime Unison.Codebase.Serialization Unison.Codebase.ShortCausalHash @@ -72,6 +63,7 @@ library Unison.Codebase.SqliteCodebase.Migrations Unison.Codebase.SqliteCodebase.Migrations.Helpers Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 + Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 @@ -111,7 +103,6 @@ library Unison.PatternMatchCoverage.Constraint Unison.PatternMatchCoverage.Desugar Unison.PatternMatchCoverage.EffectHandler - Unison.PatternMatchCoverage.Fix Unison.PatternMatchCoverage.GrdTree Unison.PatternMatchCoverage.IntervalSet Unison.PatternMatchCoverage.ListPat @@ -131,34 +122,14 @@ library Unison.PrettyPrintEnvDecl.Names Unison.PrettyPrintEnvDecl.Sqlite Unison.PrintError - Unison.Project.Util Unison.Result - Unison.Runtime.ANF - Unison.Runtime.ANF.Rehash - Unison.Runtime.ANF.Serialize - Unison.Runtime.Array - Unison.Runtime.Builtin - Unison.Runtime.Crypto.Rsa - Unison.Runtime.Debug - Unison.Runtime.Decompile - Unison.Runtime.Exception - Unison.Runtime.Foreign - Unison.Runtime.Foreign.Function - Unison.Runtime.Interface - Unison.Runtime.IOSource - Unison.Runtime.Machine - Unison.Runtime.MCode - Unison.Runtime.MCode.Serialize - Unison.Runtime.Pattern - Unison.Runtime.Serialize - Unison.Runtime.SparseVector - Unison.Runtime.Stack - Unison.Runtime.Vector Unison.Share.Types Unison.Syntax.DeclParser Unison.Syntax.DeclPrinter Unison.Syntax.FileParser + Unison.Syntax.FilePrinter Unison.Syntax.NamePrinter + Unison.Syntax.Precedence Unison.Syntax.TermParser Unison.Syntax.TermPrinter Unison.Syntax.TypeParser @@ -194,6 +165,7 @@ library ApplicativeDo BangPatterns BlockArguments + ConstraintKinds DeriveAnyClass DeriveFunctor DeriveGeneric @@ -220,99 +192,41 @@ library TypeApplications TypeFamilies ViewPatterns - ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures build-depends: - IntervalMap - , ListLike - , NanoID + ListLike , aeson - , ansi-terminal - , asn1-encoding - , asn1-types , async , atomic-primops , base - , base16 >=0.2.1.0 - , base64-bytestring - , basement - , binary , bytes , bytestring - , bytestring-to-vector - , cereal - , clock , concurrent-output - , configurator , containers >=0.6.3 - , cryptonite - , data-default - , data-memocombinators - , deepseq - , directory - , either , errors - , exceptions , extra , filelock , filepath - , fingertree , free - , fuzzyfind , generic-lens , hashable , hashtables - , haskeline - , http-client - , http-media - , http-types - , iproute , lens - , lucid , megaparsec - , memory , mmorph - , monad-validate , mtl - , murmur-hash , mutable-containers - , mwc-random - , natural-transformation - , network - , network-simple - , network-udp , network-uri , nonempty-containers - , open-browser - , openapi3 - , optparse-applicative >=0.16.1.0 - , pem , pretty-simple - , primitive - , process - , random >=1.2.0 - , raw-strings-qq - , recover-rtti - , regex-base , regex-tdfa - , safe - , safe-exceptions , semialign , semigroups - , servant , servant-client - , servant-docs - , servant-openapi3 - , servant-server - , shellmet , stm - , tagged - , temporary - , terminal-size >=0.3.3 , text - , text-short , these , time - , tls , transformers , unicode-show , unison-codebase @@ -330,29 +244,15 @@ library , unison-util-base32hex , unison-util-bytes , unison-util-cache - , unison-util-nametree + , unison-util-recursion , unison-util-relation , unison-util-rope , unison-util-serialization , unliftio - , uri-encode - , utf8-string , uuid , vector - , wai - , warp - , witch , witherable - , x509 - , x509-store - , x509-system - , yaml - , zlib default-language: Haskell2010 - if flag(optimized) - ghc-options: -funbox-strict-fields -O2 - if flag(arraychecks) - cpp-options: -DARRAY_CHECK test-suite parser-typechecker-tests type: exitcode-stdio-1.0 @@ -360,16 +260,13 @@ test-suite parser-typechecker-tests other-modules: Unison.Core.Test.Name Unison.Test.ABT - Unison.Test.ANF Unison.Test.Codebase.Branch Unison.Test.Codebase.Causal Unison.Test.Codebase.Path Unison.Test.CodebaseInit Unison.Test.Common Unison.Test.DataDeclaration - Unison.Test.MCode Unison.Test.Referent - Unison.Test.Runtime.Crypto.Rsa Unison.Test.Syntax.FileParser Unison.Test.Syntax.TermParser Unison.Test.Syntax.TypePrinter @@ -379,7 +276,6 @@ test-suite parser-typechecker-tests Unison.Test.Typechecker.Components Unison.Test.Typechecker.Context Unison.Test.Typechecker.TypeError - Unison.Test.UnisonSources Unison.Test.Util.Pretty Unison.Test.Util.Relation Unison.Test.Util.Text @@ -390,6 +286,7 @@ test-suite parser-typechecker-tests ApplicativeDo BangPatterns BlockArguments + ConstraintKinds DeriveAnyClass DeriveFunctor DeriveGeneric @@ -416,110 +313,17 @@ test-suite parser-typechecker-tests TypeApplications TypeFamilies ViewPatterns - ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 build-depends: - IntervalMap - , ListLike - , NanoID - , aeson - , ansi-terminal - , asn1-encoding - , asn1-types - , async - , atomic-primops - , base - , base16 >=0.2.1.0 - , base64-bytestring - , basement - , binary - , bytes - , bytestring - , bytestring-to-vector - , cereal - , clock + base , code-page - , concurrent-output - , configurator - , containers >=0.6.3 - , cryptonite - , data-default - , data-memocombinators - , deepseq - , directory + , containers , easytest - , either - , errors - , exceptions - , extra - , filelock - , filemanip - , filepath - , fingertree - , free - , fuzzyfind - , generic-lens - , hashable - , hashtables - , haskeline - , hex-text - , http-client - , http-media - , http-types - , iproute - , lens - , lucid , megaparsec - , memory - , mmorph - , monad-validate , mtl - , murmur-hash - , mutable-containers - , mwc-random - , natural-transformation - , network - , network-simple - , network-udp - , network-uri - , nonempty-containers - , open-browser - , openapi3 - , optparse-applicative >=0.16.1.0 - , pem - , pretty-simple - , primitive - , process - , random >=1.2.0 , raw-strings-qq - , recover-rtti - , regex-base - , regex-tdfa - , safe - , safe-exceptions - , semialign - , semigroups - , servant - , servant-client - , servant-docs - , servant-openapi3 - , servant-server - , shellmet - , split - , stm - , tagged , temporary - , terminal-size >=0.3.3 , text - , text-short - , these - , time - , tls - , transformers - , unicode-show - , unison-codebase - , unison-codebase-sqlite - , unison-codebase-sqlite-hashing-v2 - , unison-codebase-sync , unison-core , unison-core1 , unison-hash @@ -527,31 +331,7 @@ test-suite parser-typechecker-tests , unison-parser-typechecker , unison-prelude , unison-pretty-printer - , unison-sqlite , unison-syntax - , unison-util-base32hex - , unison-util-bytes - , unison-util-cache - , unison-util-nametree , unison-util-relation , unison-util-rope - , unison-util-serialization - , unliftio - , uri-encode - , utf8-string - , uuid - , vector - , wai - , warp - , witch - , witherable - , x509 - , x509-store - , x509-system - , yaml - , zlib default-language: Haskell2010 - if flag(optimized) - ghc-options: -funbox-strict-fields -O2 - if flag(arraychecks) - cpp-options: -DARRAY_CHECK diff --git a/scheme-libs/racket/unison-runtime.rkt b/scheme-libs/racket/unison-runtime.rkt index 23b5e85e19..7ddb9fea0d 100644 --- a/scheme-libs/racket/unison-runtime.rkt +++ b/scheme-libs/racket/unison-runtime.rkt @@ -30,7 +30,6 @@ unison/data-info unison/chunked-seq unison/primops - unison/builtin unison/primops-generated unison/builtin-generated) @@ -68,12 +67,12 @@ (let ([bs (grab-bytes port)]) (match (builtin-Value.deserialize (bytes->chunked-bytes bs)) [(unison-data _ t (list q)) - (= t ref-either-right:tag) + #:when (= t ref-either-right:tag) (apply values (unison-tuple->list (reify-value (unison-quote-val q))))] - [else - (raise "unexpected input")]))) + [val + (raise (format "unexpected input: ~a " (describe-value val)))]))) (define (natural->bytes/variable n) (let rec ([i n] [acc '()]) @@ -118,9 +117,9 @@ (define ((eval-exn-handler port) rq) (request-case rq [pure (result) (encode-success result port)] - [ref-exception:typelink + [ref-exception [0 (fail) - (control ref-exception:typelink k + (control ref-exception k (encode-exception fail port))]])) ; Implements the evaluation mode of operation. First decodes the @@ -134,33 +133,34 @@ ([exn:bug? (lambda (e) (encode-error e out))]) (parameterize ([current-command-line-arguments args]) - (handle [ref-exception:typelink] (eval-exn-handler out) + (handle [ref-exception] (eval-exn-handler out) ((termlink->proc main-ref))))))) ; Uses racket pretty printing machinery to instead generate a file ; containing the given code, and which executes the main definition on ; loading. This file can then be built with `raco exe`. -(define (write-module srcf main-ref icode) +(define (write-module prof srcf main-ref icode) (call-with-output-file srcf (lambda (port) (parameterize ([print-as-expression #t]) (display "#lang racket/base\n\n" port) - (for ([expr (build-intermediate-module main-ref icode)]) + (for ([expr (build-intermediate-module #:profile prof main-ref icode)]) (pretty-print expr port 1) (newline port)) (newline port))) #:exists 'replace)) ; Decodes input and writes a module to the specified file. -(define (do-generate srcf) +(define (do-generate prof srcf) (define-values (icode main-ref) (decode-input (current-input-port))) - (write-module srcf main-ref icode)) + (write-module prof srcf main-ref icode)) (define generate-to (make-parameter #f)) (define show-version (make-parameter #f)) (define use-port-num (make-parameter #f)) +(define enable-profiling (make-parameter #f)) (define (handle-command-line) (command-line @@ -177,6 +177,10 @@ file "generate code to " (generate-to file)] + #:once-each + [("--profile") + "enable profiling" + (enable-profiling #t)] #:args remaining (list->vector remaining))) @@ -185,7 +189,7 @@ (current-command-line-arguments sub-args)) (cond [(show-version) (displayln "unison-runtime version 0.0.11")] - [(generate-to) (do-generate (generate-to))] + [(generate-to) (do-generate (enable-profiling) (generate-to))] [(use-port-num) (match (string->number (use-port-num)) [port diff --git a/scheme-libs/racket/unison/.gitignore b/scheme-libs/racket/unison/.gitignore new file mode 100644 index 0000000000..64e9064d19 --- /dev/null +++ b/scheme-libs/racket/unison/.gitignore @@ -0,0 +1,6 @@ +compiled/ +boot-generated.ss +builtin-generated.ss +compound-wrappers.ss +data-info.ss +simple-wrappers.ss diff --git a/scheme-libs/racket/unison/Readme.md b/scheme-libs/racket/unison/Readme.md index dafd7e3fa8..c8f7e76eb4 100644 --- a/scheme-libs/racket/unison/Readme.md +++ b/scheme-libs/racket/unison/Readme.md @@ -1,5 +1,18 @@ This directory contains libraries necessary for building and running -unison programs via Racket Scheme. +unison programs via Racket Scheme. The rough steps are as follows: + +* Build Racket libraries from the current Unison version. +* Build the `unison-runtime` binary. +* Pass the path to `unison-runtime` to `ucm`. + +Native compilation is done via the `compile.native` `ucm` command. +Under-the-hood, Unison does the following: + +* Convert the function to bytecode (similar to how `compile` command works). +* Call `unison-runtime` which will convert the bytecode to a temporary Racket + file. The Racket file is usually placed in your `.cache/unisonlanguage`. +* folder. Call `raco exe file.rkt -o executable` which will create a native + executable from the Racket source code. ## Prerequisites @@ -9,20 +22,56 @@ You'll need to have a couple things installed on your system: * [Racket](https://racket-lang.org/), with the executable `racket` on your path somewhere * [BLAKE2](https://github.com/BLAKE2/libb2) (you may need to install this manually) - -In particular, our crypto functions require on both `libcrypto` (from openssl) and `libb2`. You may have to tell racket where to find `libb2`, by adding an entry to the hash table in your [`config.rktd` file](https://docs.racket-lang.org/raco/config-file.html). This is what I had, for an M1 mac w/ libb2 installed via Homebrew: +In particular, our crypto functions require both `libcrypto` (from openssl or +eg. libressl) and `libb2`. You may have to tell racket where to find `libb2`, by +adding an entry to the hash table in your +[`config.rktd` file](https://docs.racket-lang.org/raco/config-file.html). +This is what I had, for an M1 mac with `libb2` installed via Homebrew: ``` -(lib-search-dirs . (#f "/opt/homebrew/Cellar/libb2/0.98.1/lib/")) +$ cat scheme-libs/racket/config/config.rktd +#hash( + (lib-search-dirs . (#f "/opt/homebrew/Cellar/libb2/0.98.1/lib/")) +) ``` You'll also need to install `x509-lib` with `raco pkg install x509-lib` +Finally, some distributions only package `racket-minimal`. You'll need to +install the full compiler suite using `raco pkg install compiler-lib` +([source](https://www.dbrunner.de/blog/2016/01/12/using-racket-minimal-and-raco/)) + +## Building + +First, make sure unison is built (see [development](../../../development.markdown)) + +Next, use unison to generate the racket libraries. These are dependencies for +building `unison-runtime`. +* Read [gen-racket-libs.md](../../../unison-src/transcripts-manual/gen-racket-libs.md). + It will contain two things: + * `ucm` and `unison` transcripts that generate the libraries + * Instructions on how to build `unison-runtime` using `raco` + +If everything went well you should now have a new executable in `scheme-libs/racket/unison-runtime`. +For example: +``` +$ file scheme-libs/racket/unison-runtime +scheme-libs/racket/unison-runtime: Mach-O 64-bit executable arm64 +``` ## Running the unison test suite -To run the test suite, first `stack build` (or `stack build --fast`), then: +Note that if you set up `config.rktd` above, you'll need to pass the path to its +folder in `PLTCONFIGDIR` before invoking unison or the test scripts: + +``` +export PLTCONFIGDIR=$(pwd)/scheme-libs/racket/config +``` + +If you don't, some of the tests will fail with eg `ffi-lib: could not load foreign library`. + +To run the test suite you can do: ``` -./unison-src/builtin-tests/jit-tests.sh $(stack exec which unison) --runtime-path +./unison-src/builtin-tests/jit-tests.sh $(stack exec which unison) --runtime-path scheme-libs/racket/unison-runtime ``` OR if you want to run the same tests in interpreted mode: @@ -31,7 +80,9 @@ OR if you want to run the same tests in interpreted mode: ./unison-src/builtin-tests/interpreter-tests.sh ``` -The above scripts fetch and cache a copy of base and the scheme-generating libraries, and copy this directory to `$XDG_DATA_DIRECTORY/unisonlanguage/scheme-libs`. +The above scripts fetch and cache a copy of base and the scheme-generating +libraries, and copy this directory to `$XDG_DATA_DIRECTORY/unisonlanguage/scheme-libs`. +Both scripts _should_ pass. ## Iterating more quickly diff --git a/scheme-libs/racket/unison/arithmetic.rkt b/scheme-libs/racket/unison/arithmetic.rkt deleted file mode 100644 index d9a63d9eb5..0000000000 --- a/scheme-libs/racket/unison/arithmetic.rkt +++ /dev/null @@ -1,71 +0,0 @@ -#!racket/base - -(provide - (prefix-out - builtin- - (combine-out - Nat.toFloat - Nat.increment - Nat.+ - Nat.drop - Float.* - Float.fromRepresentation - Float.toRepresentation - Float.ceiling - Int.+ - Int.- - Int./ - Int.increment - Int.negate - Int.fromRepresentation - Int.toRepresentation - Int.signum - ))) - -(require racket - racket/fixnum - racket/flonum - racket/performance-hint - unison/boot) - -(begin-encourage-inline - (define-unison (Nat.+ m n) (clamp-natural (+ m n))) - (define-unison (Nat.drop m n) (max 0 (- m n))) - - (define-unison (Nat.increment n) (clamp-natural (add1 n))) - (define-unison (Int.increment i) (clamp-integer (add1 i))) - (define-unison (Int.negate i) (if (> i nbit63) (- i) i)) - (define-unison (Int.+ i j) (clamp-integer (+ i j))) - (define-unison (Int.- i j) (clamp-integer (- i j))) - (define-unison (Int./ i j) (floor (/ i j))) - (define-unison (Int.signum i) (sgn i)) - (define-unison (Float.* x y) (fl* x y)) - - (define-unison (Nat.toFloat n) (->fl n)) - - (define-unison (Float.ceiling f) - (clamp-integer (fl->exact-integer (ceiling f)))) - - ; If someone can suggest a better mechanism for these, - ; that would be appreciated. - (define-unison (Float.toRepresentation fl) - (integer-bytes->integer - (real->floating-point-bytes fl 8 #t) ; big endian - #f ; unsigned - #t)) ; big endian - - (define-unison (Float.fromRepresentation n) - (floating-point-bytes->real - (integer->integer-bytes n 8 #f #t) ; unsigned, big endian - #t)) ; big endian - - (define-unison (Int.toRepresentation i) - (integer-bytes->integer - (integer->integer-bytes i 8 #t #t) ; signed, big endian - #f #t)) ; unsigned, big endian - - (define-unison (Int.fromRepresentation n) - (integer-bytes->integer - (integer->integer-bytes n 8 #f #t) ; unsigned, big endian - #t #t)) ; signed, big endian - ) diff --git a/scheme-libs/racket/unison/boot.ss b/scheme-libs/racket/unison/boot.ss index 67d390f9cf..90a4530a69 100644 --- a/scheme-libs/racket/unison/boot.ss +++ b/scheme-libs/racket/unison/boot.ss @@ -55,6 +55,7 @@ bytes control define-unison + define-unison-builtin handle name data @@ -62,6 +63,7 @@ clamp-integer clamp-natural + natural-max0 wrap-natural bit64 bit63 @@ -87,6 +89,9 @@ exception->string raise-unison-exception + exn:io? + exn:arith? + request request-case sum @@ -99,6 +104,7 @@ describe-value decode-value + describe-hash top-exn-handler @@ -107,6 +113,7 @@ referent->termlink typelink->reference termlink->referent + termlink->reference unison-tuple->list list->unison-tuple @@ -116,20 +123,23 @@ (require (for-syntax racket/set - (only-in racket partition flatten)) + (only-in racket partition flatten split-at string-trim identity) + (only-in racket/string string-prefix?) + (only-in racket/syntax format-id)) (rename-in (except-in racket false true unit any) [make-continuation-prompt-tag make-prompt]) ; (for (only (compatibility mlist) mlist->list list->mlist) expand) ; (for (only (racket base) quasisyntax/loc) expand) ; (for-syntax (only-in unison/core syntax->list)) - (only-in racket/control prompt0-at control0-at) + (only-in racket/control control0-at) racket/performance-hint + racket/trace unison/core + unison/curry unison/data unison/sandbox unison/data-info - unison/crypto (only-in unison/chunked-seq string->chunked-string chunked-string->string @@ -151,125 +161,313 @@ (syntax-rules () [(with-name name e) (let ([name e]) name)])) -; function definition with slow/fast path. Slow path allows for -; under/overapplication. Fast path is exact application. +; Our definition macro needs to generate multiple entry points for the +; defined procedures, so this is a function for making up names for +; those based on the original. +(define-for-syntax (adjust-symbol #:trim trim? name post) + (define trimmer + (if trim? + (lambda (n) (string-trim n #px"-\\d+$")) + identity)) + + (string->symbol + (string-append + (trimmer (symbol->string name)) + ":" + post))) + +(define-for-syntax (adjust-name #:trim [trim? #f] name post) + (datum->syntax name (adjust-symbol #:trim trim? (syntax->datum name) post) name)) + +(define-for-syntax (ref-link? name:link:stx) + (string-prefix? (symbol->string (syntax->datum name:link:stx)) "ref-")) + +(define-for-syntax (build-groupref internal? name:link:stx lo) + (if (and internal? (ref-link? name:link:stx)) + #f + #`(termlink->groupref #,name:link:stx #,lo))) + +; Helper function. Turns a list of syntax objects into a +; list-syntax object. +(define-for-syntax (list->syntax l) #`(#,@l)) + +; These are auxiliary functions for manipulating a unison definition +; into a form amenable for the right runtime behavior. This involves +; multiple separate definitions: +; +; 1. an :impl definition is generated containing the actual code body +; 2. a :fast definition, which takes exactly the number of arguments +; as the original, but checks if stack information needs to be +; stored for continuation serialization. +; 3. a :slow path which implements under/over application to unison +; definitions, so they act like curried functions, not scheme +; procedures +; 4. a macro that implements the actual occurrences, and directly +; calls the fast path for static calls with exactly the right +; number of arguments ; -; The intent is for the scheme compiler to be able to recognize and -; optimize static, fast path calls itself, while still supporting -; unison-like automatic partial application and such. -(define-syntax (define-unison x) - (define (fast-path-symbol name) - (string->symbol - (string-append - (symbol->string name) - ":fast-path"))) - - (define (fast-path-name name) - (datum->syntax name (fast-path-symbol (syntax->datum name)))) - - ; Helper function. Turns a list of syntax objects into a - ; list-syntax object. - (define (list->syntax l) #`(#,@l)) - ; Builds partial application cases for unison functions. - ; It seems most efficient to have a case for each posible - ; under-application. - (define (build-partials name formals) - (let rec ([us formals] [acc '()]) - (syntax-case us () - [() (list->syntax (cons #`[() #,name] acc))] - [(a ... z) - (rec #'(a ...) - (cons - #`[(a ... z) - (with-name - #,(datum->syntax name (syntax->datum name)) - (partial-app #,name a ... z))] - acc))]))) - - ; Given an overall function name, a fast path name, and a list of - ; arguments, builds the case-lambda body of a unison function that - ; enables applying to arbitrary numbers of arguments. - (define (func-cases name name:fast args) - (syntax-case args () - [() (quasisyntax/loc x - (case-lambda - [() (#,name:fast)] - [r (apply (#,name:fast) r)]))] - [(a ... z) - (quasisyntax/loc x - (case-lambda - #,@(build-partials name #'(a ...)) - [(a ... z) (#,name:fast a ... z)] - [(a ... z . r) (apply (#,name:fast a ... z) r)]))])) - - (syntax-case x () - [(define-unison (name a ...) e ...) - (let ([fname (fast-path-name #'name)]) - (with-syntax ([name:fast fname] - [fast (syntax/loc x (lambda (a ...) e ...))] - [slow (func-cases #'name fname #'(a ...))]) - (syntax/loc x - (define-values (name:fast name) (values fast slow)))))])) +; Additionally, arguments are threaded through the internal +; definitions that indicate whether an ability handler is in place +; that could potentially result in the continuation being serialized. +; If so, then calls write additional information to the continuation +; for that serialization. This isn't cheap for tight loops, so we +; attempt to avoid this as much as possible (conditioning the +; annotation on a flag checkseems to cause no performance loss). + + +; This builds the core definition for a unison definition. It is just +; a lambda expression with the original code, but with an additional +; keyword argument for threading purity information. +(define-for-syntax (make-impl value? name:impl:stx arg:stx body:stx) + (with-syntax ([name:impl name:impl:stx] + [args arg:stx] + [body body:stx]) + (cond + [value? + (syntax/loc body:stx + (define name:impl . body))] + [else + (syntax/loc body:stx + (define (name:impl . args) . body))]))) + +(define frame-contents (gensym)) + +; Builds the wrapper definition, 'fast path,' which just tests the +; purity, writes the stack information if necessary, and calls the +; implementation. If #:force-pure is specified, the fast path just +; directly calls the implementation procedure. This should allow +; tight loops to still perform well if we can detect that they +; (hereditarily) cannot make ability requests, even in contexts +; where a handler is present. +(define-for-syntax + (make-fast-path + #:force-pure force-pure? + #:value value? + loc ; original location + name:fast:stx name:impl:stx + arg:stx) + + (with-syntax ([name:impl name:impl:stx] + [name:fast name:fast:stx] + [args arg:stx]) + (cond + [value? + (syntax/loc loc + (define (name:fast) name:impl))] + + [force-pure? + (syntax/loc loc + ; note: for some reason this performs better than + ; (define name:fast name:impl) + (define (name:fast . args) (name:impl . args)))] + + [else + (syntax/loc loc + (define (name:fast #:pure pure? . args) + (if pure? + (name:impl #:pure pure? . args) + (with-continuation-mark + frame-contents + (vector . args) + (name:impl #:pure pure? . args)))))]))) + +(define-for-syntax + (make-main loc value? inline? name:stx ref:stx name:impl:stx n) + (with-syntax ([name name:stx] + [name:impl name:impl:stx] + [gr ref:stx] + [n (datum->syntax loc n)]) + (cond + [value? + (syntax/loc loc + (define (name) name:impl))] + [inline? + (syntax/loc loc + (define name + (unison-curry #:inline n gr name:impl)))] + [else + (syntax/loc loc + (define name + (unison-curry n gr name:impl)))]))) + +(define-for-syntax + (link-decl no-link-decl? loc name:stx name:fast:stx name:impl:stx) + (if no-link-decl? + #'() + (let ([name:link:stx (adjust-name name:stx "termlink")]) + (with-syntax + ([name:fast name:fast:stx] + [name:impl name:impl:stx] + [name:link name:link:stx]) + (syntax/loc loc + ((declare-function-link name:fast name:link) + (declare-function-link name:impl name:link))))))) + +(define-for-syntax + (trace-decls trace? loc name:impl:stx) + (if trace? + (with-syntax ([name:impl name:impl:stx]) + (syntax/loc loc + ((trace name:impl)))) + #'())) + +(define-for-syntax (process-hints hs) + (for/fold ([internal? #f] + [force-pure? #t] + [gen-link? #f] + [no-link-decl? #f] + [trace? #f] + [inline? #f] + [recursive? #f] + [value? #f]) + ([h hs]) + (values + (or internal? (eq? h 'internal)) + (or force-pure? (eq? h 'force-pure) (eq? h 'internal)) + (or gen-link? (eq? h 'gen-link)) + (or no-link-decl? (eq? h 'no-link-decl)) + (or trace? (eq? h 'trace)) + (or inline? (eq? h 'inline)) + (or recursive? (eq? h 'recursive)) + (or value? (eq? h 'value))))) + +(define-for-syntax + (make-link-def gen-link? loc name:stx name:link:stx) + + (define (chop s) + (if (string-prefix? s "builtin-") + (substring s 8) + s)) + + (define name:txt + (chop + (symbol->string + (syntax->datum name:stx)))) + + (cond + [gen-link? + (with-syntax ([name:link name:link:stx]) + (quasisyntax/loc loc + ((define name:link + (unison-termlink-builtin #,name:txt)))))] + [else #'()])) + +(define-for-syntax + (expand-define-unison + #:hints hints + #:local [lo 0] + loc name:stx arg:stx expr:stx) + + (define-values (internal? + force-pure? + gen-link? + no-link-decl? + trace? + inline? + recursive? + value?) + (process-hints hints)) + + + (let* ([name:fast:stx (adjust-name name:stx "fast")] + [name:impl:stx (adjust-name name:stx "impl")] + [name:link:stx (adjust-name name:stx "termlink" #:trim #t)] + [ref:stx (build-groupref internal? name:link:stx lo)] + [arity (length (syntax->list arg:stx))]) + (with-syntax + ([(link ...) (make-link-def gen-link? loc name:stx name:link:stx)] + [fast (make-fast-path + #:force-pure #t ; force-pure? + #:value value? + loc name:fast:stx name:impl:stx arg:stx)] + [impl (make-impl value? name:impl:stx arg:stx expr:stx)] + [main (make-main loc value? inline? name:stx ref:stx name:impl:stx arity)] + ; [(decls ...) + ; (link-decl no-link-decl? loc name:stx name:fast:stx name:impl:stx)] + [(traces ...) + (trace-decls trace? loc name:impl:stx)]) + (quasisyntax/loc loc + (begin + link ... + #,(if (or recursive? inline?) #'(begin-encourage-inline impl) #'impl) + traces ... + #,(if (or recursive? inline?) #'(begin-encourage-inline fast) #'fast) + #,(if inline? #'(begin-encourage-inline main) #'main)))))) + +; Function definition supporting various unison features, like +; partial application and continuation serialization. See above for +; details. +; +; `#:internal #t` indicates that the definition is for builtin +; functions. These should always be built in a way that does not +; annotate the stack, because they don't make relevant ability +; requests. This is important for performance and some correct +; behavior (i.e. they may occur in non-unison contexts where a +; `pure?` indicator is not being threaded). +(define-syntax (define-unison stx) + (syntax-case stx () + [(define-unsion #:hints hs #:local n (name . args) . exprs) + (expand-define-unison + #:local (syntax->datum #'n) + #:hints (syntax->datum #'hs) + stx #'name #'args #'exprs)] + [(define-unsion #:local n #:hints hs (name . args) . exprs) + (expand-define-unison + #:local (syntax->datum #'n) + #:hints (syntax->datum #'hs) + stx #'name #'args #'exprs)] + [(define-unison #:hints hs (name . args) . exprs) + (expand-define-unison + #:hints (syntax->datum #'hs) + stx #'name #'args #'exprs)] + [(define-unison #:local n (name . args) . exprs) + (expand-define-unison + #:local (syntax->datum #'n) + #:hints '[] + stx #'name #'args #'exprs)] + [(define-unison (name . args) . exprs) + (expand-define-unison + #:hints '[internal] + stx #'name #'args #'exprs)])) + +(define-syntax (define-unison-builtin stx) + (syntax-case stx () + [(define-unison-builtin #:local n #:hints [h ...] . rest) + (syntax/loc stx + (define-unison #:local n #:hints [inline internal gen-link h ...] . rest))] + [(define-unison-builtin #:local n . rest) + (syntax/loc stx + (define-unison #:local n #:hints [inline internal gen-link] . rest))] + [(define-unison-builtin #:hints [h ...] . rest) + (syntax/loc stx + (define-unison #:hints [inline internal gen-link h ...] . rest))] + [(define-unison-builtin . rest) + (syntax/loc stx + (define-unison #:hints [inline internal gen-link] . rest))])) ; call-by-name bindings -(define-syntax name - (lambda (stx) - (syntax-case stx () - ((name ([v (f . args)] ...) body ...) - (with-syntax ([(lam ...) - (map (lambda (body) - (quasisyntax/loc stx - (lambda r #,body))) - (syntax->list #'[(apply f (append (list . args) r)) ...]))]) - #`(let ([v lam] ...) - body ...)))))) +(define-syntax (name stx) + (syntax-case stx () + [(name ([v (f . args)] ...) body ...) + (syntax/loc stx + (let ([v (build-closure f . args)] ...) body ...))])) ; Wrapper that more closely matches `handle` constructs -; -; Note: this uses the prompt _twice_ to achieve the sort of dynamic -; scoping we want. First we push an outer delimiter, then install -; the continuation marks corresponding to the handled abilities -; (which tells which propt to use for that ability and which -; functions to use for each request). Then we re-delimit by the same -; prompt. -; -; If we just used one delimiter, we'd have a problem. If we pushed -; the marks _after_ the delimiter, then the continuation captured -; when handling would contain those marks, and would effectively -; retain the handler for requests within the continuation. If the -; marks were outside the prompt, we'd be in a similar situation, -; except where the handler would be automatically handling requests -; within its own implementation (although, in both these cases we'd -; get control errors, because we would be using the _function_ part -; of the handler without the necessary delimiters existing on the -; continuation). Both of these situations are wrong for _shallow_ -; handlers. -; -; Instead, what we need to be able to do is capture the continuation -; _up to_ the marks, then _discard_ the marks, and this is what the -; multiple delimiters accomplish. There might be more efficient ways -; to accomplish this with some specialized mark functions, but I'm -; uncertain of what pitfalls there are with regard to that (whehter -; they work might depend on exact frame structure of the -; metacontinuation). (define-syntax handle (syntax-rules () [(handle [r ...] h e ...) - (let ([p (make-prompt)]) - (prompt0-at p - (let ([v (let-marks (list r ...) (cons p h) - (prompt0-at p e ...))]) - (h (make-pure v)))))])) + (call-with-handler '(r ...) h (lambda () e ...))])) ; wrapper that more closely matches ability requests (define-syntax request (syntax-rules () [(request r t . args) - (let ([rq (make-request r t (list . args))]) - (let ([current-mark (ref-mark r)]) - (if (equal? #f current-mark) - (error "Unhandled top-level effect! " (list r t . args)) - ((cdr current-mark) rq))))])) + (let* ([key (quote r)] + [rq (make-request key t (list . args))] + [current-mark (ref-mark key)]) + (if (pair? current-mark) + ((cdr current-mark) rq) + (error "unhandled ability request: " (list key t . args))))])) ; See the explanation of `handle` for a more thorough understanding ; of why this is doing two control operations. @@ -282,7 +480,7 @@ (define-syntax control (syntax-rules () [(control r k e ...) - (let ([p (car (ref-mark r))]) + (let ([p (car (ref-mark (quote r)))]) (control0-at p k (control0-at p _k e ...)))])) ; forces something that is expected to be a thunk, defined with @@ -477,7 +675,7 @@ (syntax-case stx () [(a sc ...) #`((unison-request b t vs) - #:when (equal? a b) + #:when (eq? (quote a) b) (match* (t vs) #,@(map mk-req (syntax->list #'(sc ...)))))]))) @@ -508,7 +706,12 @@ (match id [(unison-data _ t (list rf i)) #:when (= t ref-id-id:tag) - (unison-termlink-derived rf i)])])) + (unison-termlink-derived rf i)])] + [else + (raise-argument-error + 'reference->termlink + "unison-reference?" + rf)])) (define (referent->termlink rn) (match rn @@ -550,6 +753,16 @@ [(unison-termlink-con tyl i) (ref-referent-con (typelink->reference tyl) i)])) +(define (termlink->reference rn) + (match rn + [(unison-termlink-builtin name) + (ref-reference-builtin + (string->chunked-string name))] + [(unison-termlink-derived bs i) + (ref-reference-derived (ref-id-id bs i))] + [else (raise "termlink->reference: con case")])) + + (define (unison-seq . l) (vector->chunked-list (list->vector l))) @@ -566,9 +779,9 @@ (display "")] [else (display (describe-value x))])] - [ref-exception:typelink + [ref-exception [0 (f) - (control ref-exception:typelink k + (control ref-exception k (let ([disp (describe-value f)]) (raise (make-exn:bug @@ -596,6 +809,15 @@ (if (fixnum? n) n (modulo n bit64))) + ; For natural arithmetic operations that can yield negatives, this + ; ensures that they are clamped back to 0. + ; + ; Note: (max 0 n) is apparently around 2-3x slower than this, hence + ; the custom operation. I've factored it out here in case something + ; even better is found, but this seems to match the performance of + ; the underlying operation. + (define (natural-max0 n) (if (>= n 0) n 0)) + ; module arithmetic appropriate for when a Nat operation my either ; have too large or a negative result. (define (wrap-natural n) @@ -604,7 +826,7 @@ (define (raise-unison-exception ty msg val) (request - ref-exception:typelink + ref-exception 0 (ref-failure-failure ty msg (unison-any-any val)))) @@ -613,3 +835,13 @@ ref-runtimefailure:typelink (string->chunked-string (exn:bug-msg b)) (exn:bug-val b))) + +(define (exn:io? e) + (or (exn:fail:read? e) + (exn:fail:filesystem? e) + (exn:fail:network? e))) + +(define (exn:arith? e) + (or (exn:fail:contract:divide-by-zero? e) + (exn:fail:contract:non-fixnum-result? e))) + diff --git a/scheme-libs/racket/unison/builtin.rkt b/scheme-libs/racket/unison/builtin.rkt deleted file mode 100644 index 85d591b497..0000000000 --- a/scheme-libs/racket/unison/builtin.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang racket/base -(require unison/udp) - -(provide (all-from-out)) diff --git a/scheme-libs/racket/unison/bytes-nat.rkt b/scheme-libs/racket/unison/bytes-nat.rkt index c86036cd02..56e63e8cc0 100644 --- a/scheme-libs/racket/unison/bytes-nat.rkt +++ b/scheme-libs/racket/unison/bytes-nat.rkt @@ -1,46 +1,33 @@ #lang racket/base -(require unison/chunked-seq unison/data unison/boot) +(require unison/chunked-seq unison/data unison/data-info unison/boot) -(provide - (rename-out [encodeNat16be unison-FOp-Bytes.encodeNat16be]) - (prefix-out - unison-FOp-Bytes. - (combine-out - decodeNat16be - decodeNat16le - decodeNat32be - decodeNat32le - decodeNat64be - decodeNat64le - encodeNat16be - encodeNat16le - encodeNat32be - encodeNat32le - encodeNat64be - encodeNat64le))) +(provide decodeNatBe decodeNatLe + encodeNatBe encodeNatLe) +; TODO: this algorithm isn't good for large bytes values. It flattens +; the entire byte rope to a single chunk, reads the value off, builds +; a sub-chunk, then rebuilds the byte rope from the subchunk. (define (decodeNatBe bytes size) (if (< (chunked-bytes-length bytes) size) - none + ref-optional-none (let ([buf (chunked-bytes->bytes bytes)]) (define (loop acc n) (if (> n 0) - (begin (loop (+ (arithmetic-shift acc 8) (bytes-ref buf (- size n))) (- n 1)) - ) - acc - )) - (sum 1 (loop 0 size) (bytes->chunked-bytes - (subbytes buf size)))))) + acc)) + (ref-optional-some + (unison-tuple + (loop 0 size) + (bytes->chunked-bytes (subbytes buf size))))))) (define (decodeNatLe bytes size) (if (< (chunked-bytes-length bytes) size) - none + ref-optional-none (let ([buf (chunked-bytes->bytes bytes)]) (define (loop acc n) (if (> n 0) @@ -50,8 +37,10 @@ (bytes-ref buf (- n 1))) (- n 1)) acc)) - (sum 1 (loop 0 size) (bytes->chunked-bytes - (subbytes buf size)))))) + (ref-optional-some + (unison-tuple + (loop 0 size) + (bytes->chunked-bytes (subbytes buf size))))))) (define (encodeNatBe num size) (define buf (make-bytes size 0)) @@ -83,4 +72,4 @@ (define (decodeNat32be num) (decodeNatBe num 4)) (define (decodeNat32le num) (decodeNatLe num 4)) (define (decodeNat64be num) (decodeNatBe num 8)) -(define (decodeNat64le num) (decodeNatLe num 8)) \ No newline at end of file +(define (decodeNat64le num) (decodeNatLe num 8)) diff --git a/scheme-libs/racket/unison/concurrent.ss b/scheme-libs/racket/unison/concurrent.ss index 2049e23b37..275382b323 100644 --- a/scheme-libs/racket/unison/concurrent.ss +++ b/scheme-libs/racket/unison/concurrent.ss @@ -23,6 +23,7 @@ (rename (only (racket base) box + car unbox set-box! box-cas! @@ -38,6 +39,7 @@ with-handlers exn:break?) (box ref-new) + (car icar) (unbox ref-read) (set-box! ref-write) (sleep sleep-secs)) @@ -48,7 +50,7 @@ (define (promise-new) (let* ([sem (make-semaphore)] [evt (semaphore-peek-evt sem)] - [value none]) + [value ref-optional-none]) (make-promise sem evt value))) (define (promise-try-read promise) (promise-value promise)) @@ -57,26 +59,33 @@ (let loop () (let ([value (promise-value promise)]) (cond - [(some? value) (option-get value)] + [(= (unison-data-tag value) ref-optional-some:tag) + (icar (unison-data-fields value))] [else (sync/enable-break (promise-event promise)) (loop)])))) (define (promise-write promise new-value) (let loop () (let* ([value (promise-value promise)] - [cas! (lambda () (unsafe-struct*-cas! promise 2 value (some new-value)))] - [awake-readers (lambda () (semaphore-post (promise-semaphore promise)))]) + [cas! (lambda () + (unsafe-struct*-cas! + promise 2 + value + (ref-optional-some new-value)))] + [awake-readers (lambda () + (semaphore-post + (promise-semaphore promise)))]) (cond - [(some? value) false] + [(= (unison-data-tag value) ref-optional-some:tag) #f] [else - (let ([ok (parameterize-break #f (if (cas!) (awake-readers) false))]) - (if ok true (loop)))])))) + (let ([ok (parameterize-break #f (if (cas!) (awake-readers) #f))]) + (if ok #t (loop)))])))) (define (ref-cas ref ticket value) - (if (box-cas! ref ticket value) true false)) + (if (box-cas! ref ticket value) #t #f)) (define (sleep n) (sleep-secs (/ n 1000000)) - (right unit)) + (ref-either-right ref-unit-unit)) ;; Swallows uncaught breaks/thread kills rather than logging them to ;; match the behaviour of the Haskell runtime @@ -88,5 +97,5 @@ (define (kill threadId) (break-thread threadId) - (right unit)) + (ref-either-right ref-unit-unit)) ) diff --git a/scheme-libs/racket/unison/core.ss b/scheme-libs/racket/unison/core.ss index a273938150..75b969847c 100644 --- a/scheme-libs/racket/unison/core.ss +++ b/scheme-libs/racket/unison/core.ss @@ -23,6 +23,7 @@ (struct-out exn:bug) let-marks + call-with-marks ref-mark chunked-string-foldMap-chunks @@ -30,17 +31,12 @@ unison-tuple list->unison-tuple - freeze-bytevector! - freeze-vector! - freeze-subvector - bytevector bytevector-append - current-microseconds - decode-value describe-value + describe-hash bytevector->string/utf-8 string->bytevector/utf-8) @@ -192,17 +188,15 @@ (string-append "{Value " (describe-value v) "}")] [(unison-code v) (string-append "{Code " (describe-value v) "}")] - [(unison-closure code env) - (define dc - (termlink->string (lookup-function-link code) #t)) + [(unison-cont-reflected fs) "{Continuation}"] + [(unison-cont-wrapped _) "{Continuation}"] + [(unison-closure gr code env) + (define dc (groupref->string gr #t)) (define (f v) (string-append " " (describe-value v))) (string-append* dc (map f env))] - [(? procedure?) - (string-append - "ref" - (termlink->string (lookup-function-link x) #t))] + [(? procedure?) (describe-value (build-closure x))] [(? chunked-list?) (describe-list-sq (vector->list (chunked-list->vector x)))] [(? chunked-string?) @@ -223,18 +217,6 @@ [else (format "~a" x)])) -(define (current-microseconds) - (fl->fx (* 1000 (current-inexact-milliseconds)))) - -(define (list-head l n) - (let rec ([c l] [m n]) - (cond - [(eqv? m 0) '()] - [(null? c) '()] - [else - (let ([sub (rec (cdr c) (- m 1))]) - (cons (car c) sub))]))) - ; Simple macro to expand a syntactic sequence of comparisons into a ; short-circuiting nested comparison. (define-syntax comparisons @@ -251,6 +233,8 @@ (let rec ([cls ls] [crs rs]) (cond [(and (null? cls) (null? crs)) '=] + [(null? cls) '<] + [(null? crs) '>] [else (comparisons (universal-compare (car cls) (car crs) cmp-ty) @@ -282,6 +266,22 @@ (compare-num i j))] [(? unison-typelink-builtin?) '>])])) +(define (compare-groupref lr rr) + (match lr + [(unison-groupref-builtin lname) + (match rr + [(unison-groupref-builtin rname) + (compare-string lname rname)] + [else '<])] + [(unison-groupref-derived lh li ll) + (match rr + [(unison-groupref-derived rh ri rl) + (comparisons + (compare-bytes lh rh) + (compare-num li ri) + (compare-num ll rl))] + [else '>])])) + (define (compare-termlink ll rl) (match ll [(unison-termlink-builtin lnm) @@ -307,8 +307,8 @@ (define (value->category v) (cond - [(procedure? v) 0] [(unison-closure? v) 0] + [(procedure? v) 0] [(number? v) 1] [(char? v) 1] [(boolean? v) 1] @@ -347,18 +347,18 @@ (define (compare-proc l r cmp-ty) (define (unpack v) - (if (procedure? v) - (values (lookup-function-link v) '()) - (values - (lookup-function-link (unison-closure-code v)) - (unison-closure-env v)))) + (define clo (build-closure v)) + + (values + (unison-closure-ref clo) + (unison-closure-env clo))) - (define-values (lnl envl) (unpack l)) + (define-values (grl envl) (unpack l)) - (define-values (lnr envr) (unpack r)) + (define-values (grr envr) (unpack r)) (comparisons - (compare-termlink lnl lnr) + (compare-groupref grl grr) (lexico-compare envl envr cmp-ty))) (define (compare-timespec l r) @@ -383,7 +383,7 @@ (chunked-bytes-compare/recur l r compare-byte)] [(and (unison-data? l) (unison-data? r)) (compare-data l r cmp-ty)] [(and (bytes? r) (bytes? r)) (compare-bytes l r)] - [(and (u-proc? l) (u-proc? r)) (compare-proc l r)] + [(and (u-proc? l) (u-proc? r)) (compare-proc l r cmp-ty)] [(and (unison-termlink? l) (unison-termlink? r)) (compare-termlink l r)] [(and (unison-typelink? l) (unison-typelink? r)) @@ -437,13 +437,6 @@ ; [() '()] ; [(x . xs) (cons #'x (syntax->list #'xs))])) -(define (call-with-marks rs v f) - (cond - [(null? rs) (f)] - [else - (with-continuation-mark (car rs) v - (call-with-marks (cdr rs) v f))])) - (define-syntax let-marks (syntax-rules () [(let-marks ks bn e ...) @@ -457,19 +450,6 @@ ([c (in-chunked-string-chunks s)]) (f acc (string->chunked-string (m c))))) -(define freeze-vector! unsafe-vector*->immutable-vector!) - -(define (freeze-subvector src off len) - (let ([dst (make-vector len)]) - (let next ([i (fx1- len)]) - (if (< i 0) - (begin - (freeze-vector! dst) - (sum 1 dst)) - (begin - (vector-set! dst i (vector-ref src (+ off i))) - (next (fx1- i))))))) - (define (write-exn:bug ex port mode) (when mode (write-string "hex-string hex-string->bytes) - - ) - -(provide (prefix-out unison-FOp-crypto. - (combine-out - HashAlgorithm.Md5 - HashAlgorithm.Sha1 - HashAlgorithm.Sha2_256 - HashAlgorithm.Sha2_512 - HashAlgorithm.Sha3_256 - HashAlgorithm.Sha3_512 - HashAlgorithm.Blake2s_256 - HashAlgorithm.Blake2b_256 - HashAlgorithm.Blake2b_512 - hashBytes - hmacBytes - Ed25519.sign.impl - Ed25519.verify.impl - ))) - -(define-runtime-path libb2-so '(so "libb2" ("1" #f))) - -(define libb2 - (with-handlers [[exn:fail? exn->string]] - (ffi-lib libb2-so '("1" #f)))) - -(define _EVP-pointer (_cpointer 'EVP)) - -; returns a function that, when called, either -; 1) raises an exception, if libcrypto failed to load, or -; 2) returns a pair of (_EVP-pointer bits) -(define (lc-algo name bits) - (if (string? libcrypto) - (lambda _ (raise (error 'libcrypto "~a\n~a" name libcrypto))) - (let ([getter (get-ffi-obj name libcrypto (_fun -> _EVP-pointer))]) - (lambda [] - (cons (getter) bits))))) - -(define (check v who) - (unless (= 1 v) - (error who "failed with return value ~a" v))) - -(define EVP_Digest - (if (string? libcrypto) - (lambda _ (raise (error 'libcrypto "EVP_Digest\n~a" libcrypto))) - (get-ffi-obj "EVP_Digest" libcrypto - (_fun - _pointer ; input - _int ; input-len - _pointer ; output - _pointer ; null - _EVP-pointer ; algorithm - _pointer ; null - -> (r : _int) - -> (unless (= 1 r) - (error 'EVP_Digest "failed with return value ~a" r)))))) - -(define HMAC - (if (string? libcrypto) - (lambda _ (raise (error 'libcrypto "HMAC\n~a" libcrypto))) - (get-ffi-obj "HMAC" libcrypto - (_fun - _EVP-pointer ; algorithm - _pointer ; key - _int ; key-len - _pointer ; input - _int ; input-len - _pointer ; output pointer - _pointer ; null - -> _pointer ; unused - )))) - -(define (libb2-raw fn) - (if (string? libb2) - (lambda _ (raise (error 'libb2 "~a\n~a" fn libb2))) - (get-ffi-obj fn libb2 - (_fun - _pointer ; output - _pointer ; input - _pointer ; key - _int ; output-len - _int ; input-len - _int ; key-len - -> (r : _int) - -> (unless (= 0 r) - (error 'blake2 "~a failed with return value ~a" fn r)))))) - -(define blake2b-raw (libb2-raw "blake2b")) - -(define HashAlgorithm.Md5 (lc-algo "EVP_md5" 128)) -(define HashAlgorithm.Sha1 (lc-algo "EVP_sha1" 160)) -(define HashAlgorithm.Sha2_256 (lc-algo "EVP_sha256" 256)) -(define HashAlgorithm.Sha2_512 (lc-algo "EVP_sha512" 512)) -(define HashAlgorithm.Sha3_256 (lc-algo "EVP_sha3_256" 256)) -(define HashAlgorithm.Sha3_512 (lc-algo "EVP_sha3_512" 512)) -(define HashAlgorithm.Blake2s_256 (lc-algo "EVP_blake2s256" 256)) -(define HashAlgorithm.Blake2b_512 (lc-algo "EVP_blake2b512" 512)) - -(define _EVP_PKEY-pointer (_cpointer 'EVP_PKEY)) -(define _EVP_MD_CTX-pointer (_cpointer 'EVP_MD_CTX)) - -(define EVP_MD_CTX_new - (if (string? libcrypto) - (lambda _ (raise (error 'libcrypto "EVP_MD_CTX_create\n~a" libcrypto))) - (get-ffi-obj "EVP_MD_CTX_new" libcrypto - (_fun -> _EVP_MD_CTX-pointer - )))) - -; EVP_PKEY_new_raw_private_key(int type, NULL, const unsigned char *key, size_t keylen); -(define EVP_PKEY_new_raw_private_key - (if (string? libcrypto) - (lambda _ (raise (error 'libcrypto "EVP_PKEY_new_raw_private_key\n~a" libcrypto))) - (get-ffi-obj "EVP_PKEY_new_raw_private_key" libcrypto - (_fun - _int ; type - _pointer ; engine (null) - _pointer ; key - _int ; key-len - -> _EVP_PKEY-pointer - )))) - -; EVP_DigestSignInit(hctx, NULL, EVP_sha256(), NULL, pkey) -(define EVP_DigestSignInit - (if (string? libcrypto) - (lambda _ (raise (error 'libcrypto "EVP_DigestSignInit\n~a" libcrypto))) - (get-ffi-obj "EVP_DigestSignInit" libcrypto - (_fun - _EVP_MD_CTX-pointer - _pointer ; (null) - _pointer ; (null) - _pointer ; (null) - _EVP_PKEY-pointer ; pkey - -> _int - )))) - -; EVP_DigestSign(hctx, output, output-len-ptr, input-data, input-data-len) -(define EVP_DigestSign - (if (string? libcrypto) - (lambda _ (raise (error 'libcrypto "EVP_DigestSign\n~a" libcrypto))) - (get-ffi-obj "EVP_DigestSign" libcrypto - (_fun - _EVP_MD_CTX-pointer - _pointer ; output - (_ptr o _int) ; output-len (null prolly) - _pointer ; input-data - _int ; input-data-len - -> _int - )))) - -; EVP_PKEY_new_raw_public_key(int type, NULL, const unsigned char *key, size_t keylen); -(define EVP_PKEY_new_raw_public_key - (if (string? libcrypto) - (lambda _ (raise (error 'libcrypto "EVP_PKEY_new_raw_public_key\n~a" libcrypto))) - (get-ffi-obj "EVP_PKEY_new_raw_public_key" libcrypto - (_fun - _int ; type - _pointer ; engine (null) - _pointer ; key - _int ; key-len - -> _EVP_PKEY-pointer - )))) - -; int EVP_DigestVerifyInit(EVP_MD_CTX *ctx, EVP_PKEY_CTX **pctx, -; const EVP_MD *type, ENGINE *e, EVP_PKEY *pkey); -(define EVP_DigestVerifyInit - (if (string? libcrypto) - (lambda _ (raise (error 'libcrypto "EVP_DigestVerifyInit\n~a" libcrypto))) - (get-ffi-obj "EVP_DigestVerifyInit" libcrypto - (_fun - _EVP_MD_CTX-pointer - _pointer ; (null) - _pointer ; (null) - _pointer ; (null) - _EVP_PKEY-pointer ; pkey - -> _int - )))) - -; int EVP_DigestVerify(EVP_MD_CTX *ctx, const unsigned char *sig, -; size_t siglen, const unsigned char *tbs, size_t tbslen); -(define EVP_DigestVerify - (if (string? libcrypto) - (lambda _ (raise (error 'libcrypto "EVP_DigestVerify\n~a" libcrypto))) - (get-ffi-obj "EVP_DigestVerify" libcrypto - (_fun - _EVP_MD_CTX-pointer - _pointer ; signature - _int ; signature-len - _pointer ; input-data - _int ; input-data-len - -> _int - )))) - - -(define EVP_PKEY_ED25519 1087) -(define (evpSign-raw seed input) - (let* ([ctx (EVP_MD_CTX_new)] - [pkey (EVP_PKEY_new_raw_private_key EVP_PKEY_ED25519 #f seed (bytes-length seed))]) - (if (false? pkey) - (raise (error "Invalid seed provided.")) - (if (<= (EVP_DigestSignInit ctx #f #f #f pkey) 0) - (raise (error "Initializing signing failed")) - (let* ([output (make-bytes 64)]) - (if (<= (EVP_DigestSign ctx output input (bytes-length input)) 0) - (raise (error "Running digest failed")) - output)))))) - -(define (evpVerify-raw public-key input signature) - (let* ([ctx (EVP_MD_CTX_new)] - [pkey (EVP_PKEY_new_raw_public_key EVP_PKEY_ED25519 #f public-key (bytes-length public-key))]) - (if (false? pkey) - (raise (error "Invalid seed provided.")) - (if (<= (EVP_DigestVerifyInit ctx #f #f #f pkey) 0) - (raise (error "Initializing Verify failed")) - (if (<= (EVP_DigestVerify ctx signature (bytes-length signature) input (bytes-length input)) 0) - #f - #t))))) - -(define (Ed25519.sign.impl seed _ignored_pubkey input) - (bytes->chunked-bytes (evpSign-raw (chunked-bytes->bytes seed) (chunked-bytes->bytes input)))) - -(define (Ed25519.verify.impl public-key input signature) - (evpVerify-raw - (chunked-bytes->bytes public-key) - (chunked-bytes->bytes input) - (chunked-bytes->bytes signature))) - -; This one isn't provided by libcrypto, for some reason -(define (HashAlgorithm.Blake2b_256) (cons 'blake2b 256)) - -; kind is a pair of (algorithm bits) -; where algorithm is either an EVP_pointer for libcrypto functions, -; or the tag 'blake2b for libb2 function. -(define (hashBytes kind input) - (bytes->chunked-bytes (hashBytes-raw kind (chunked-bytes->bytes input)))) - -; kind is a pair of (algorithm bits) -; where algorithm is either an EVP_pointer for libcrypto functions, -; or the tag 'blake2b for libb2 function. -(define (hashBytes-raw kind input) - (let* ([bytes (/ (cdr kind) 8)] - [output (make-bytes bytes)] - [algo (car kind)]) - (case algo - ['blake2b (blake2b-raw output input #f bytes (bytes-length input) 0)] - [else (EVP_Digest input (bytes-length input) output #f algo #f)]) - - output)) - -; Mutates and returns the first argument -(define (xor one two) - (for ([i (in-range (bytes-length one))]) - (bytes-set! one i - (bitwise-xor - (bytes-ref one i) - (bytes-ref two i)))) - one) - -; doing the blake hmac by hand. libcrypto -; supports hmac natively, so we just defer to that -(define (hmacBlake kind key input) - (let* - ([bytes (/ (cdr kind) 8)] - [blocksize (case (car kind) ['blake2b 128] ['blake2s 64])] - - [key_ - (let ([key_ (make-bytes blocksize 0)]) - (bytes-copy! key_ 0 - (if (< blocksize (bytes-length key)) - (hashBytes-raw kind key) - key)) - key_)] - - [opad (xor (make-bytes blocksize #x5c) key_)] - [ipad (xor (make-bytes blocksize #x36) key_)] - - [full (bytes-append - opad - (hashBytes-raw kind (bytes-append ipad input)))]) - (hashBytes-raw kind full))) - -(define (hmacBytes kind key input) - (bytes->chunked-bytes (hmacBytes-raw kind (chunked-bytes->bytes key) (chunked-bytes->bytes input)))) - -(define (hmacBytes-raw kind key input) - (case (car kind) - ['blake2b (hmacBlake kind key input)] - [else - (let* ([bytes (/ (cdr kind) 8)] - [output (make-bytes bytes)] - [algo (car kind)]) - (HMAC algo key (bytes-length key) input (bytes-length input) output #f) - output)])) - - -; These will only be evaluated by `raco test` -(module+ test - (require rackunit - (only-in openssl/sha1 bytes->hex-string hex-string->bytes)) - - (test-case "ed25519 sign" - (check-equal? - (bytes->hex-string - (evpSign-raw - (hex-string->bytes "0000000000000000000000000000000000000000000000000000000000000000") #"")) - "8f895b3cafe2c9506039d0e2a66382568004674fe8d237785092e40d6aaf483e4fc60168705f31f101596138ce21aa357c0d32a064f423dc3ee4aa3abf53f803")) - - (test-case "ed25519 verify" - (check-equal? - (evpVerify-raw - (hex-string->bytes "3b6a27bcceb6a42d62a3a8d02a6f0d73653215771de243a63ac048a18b59da29") - #"" - (hex-string->bytes "8f895b3cafe2c9506039d0e2a66382568004674fe8d237785092e40d6aaf483e4fc60168705f31f101596138ce21aa357c0d32a064f423dc3ee4aa3abf53f803") - ) - #t)) - - (test-case "sha1 hmac" - (check-equal? - (bytes->hex-string (hmacBytes-raw (HashAlgorithm.Sha1) #"key" #"message")) - "2088df74d5f2146b48146caf4965377e9d0be3a4")) - - (test-case "blake2b-256 hmac" - (check-equal? - (bytes->hex-string (hmacBytes-raw (HashAlgorithm.Blake2b_256) #"key" #"message")) - "442d98a3872d3f56220f89e2b23d0645610b37c33dd3315ef224d0e39ada6751")) - - (test-case "blake2b-512 hmac" - (check-equal? - (bytes->hex-string (hmacBytes-raw (HashAlgorithm.Blake2b_512) #"key" #"message")) - "04e9ada930688cde75eec939782eed653073dd621d7643f813702976257cf037d325b50eedd417c01b6ad1f978fbe2980a93d27d854044e8626df6fa279d6680")) - - (test-case "blake2s-256 hmac" - (check-equal? - (bytes->hex-string (hmacBytes-raw (HashAlgorithm.Blake2s_256) #"key" #"message")) - "bba8fa28708ae80d249e317318c95c859f3f77512be23910d5094d9110454d6f")) - - (test-case "md5 basic" - (check-equal? - (bytes->hex-string (hashBytes-raw (HashAlgorithm.Md5) #"")) - "d41d8cd98f00b204e9800998ecf8427e")) - - (test-case "sha1 basic" - (check-equal? - (bytes->hex-string (hashBytes-raw (HashAlgorithm.Sha1) #"")) - "da39a3ee5e6b4b0d3255bfef95601890afd80709")) - - (test-case "sha2-256 basic" - (check-equal? - (bytes->hex-string (hashBytes-raw (HashAlgorithm.Sha2_256) #"")) - "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")) - - (test-case "sha2-512 basic" - (check-equal? - (bytes->hex-string (hashBytes-raw (HashAlgorithm.Sha2_512) #"")) - "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e")) - - (test-case "sha3-256 basic" - (check-equal? - (bytes->hex-string (hashBytes-raw (HashAlgorithm.Sha3_256) #"")) - "a7ffc6f8bf1ed76651c14756a061d662f580ff4de43b49fa82d80a4b80f8434a")) - - (test-case "sha3-512 basic" - (check-equal? - (bytes->hex-string (hashBytes-raw (HashAlgorithm.Sha3_512) #"")) - "a69f73cca23a9ac5c8b567dc185a756e97c982164fe25859e0d1dcc1475c80a615b2123af1f5f94c11e3e9402c3ac558f500199d95b6d3e301758586281dcd26")) - - (test-case "blake2s_256 basic" - (check-equal? - (bytes->hex-string (hashBytes-raw (HashAlgorithm.Blake2s_256) #"")) - "69217a3079908094e11121d042354a7c1f55b6482ca1a51e1b250dfd1ed0eef9")) - - (test-case "blake2b_256 basic" - (check-equal? - (bytes->hex-string (hashBytes-raw (HashAlgorithm.Blake2b_256) #"")) - "0e5751c026e543b2e8ab2eb06099daa1d1e5df47778f7787faab45cdf12fe3a8")) - - (test-case "blake2b_512 basic" - (check-equal? - (bytes->hex-string (hashBytes-raw (HashAlgorithm.Blake2b_512) #"")) - "786a02f742015903c6c6fd852552d272912f4740e15847618a86e217f71f5419d25e1031afee585313896444934eb04b903a685b1448b755d56f701afe9be2ce"))) diff --git a/scheme-libs/racket/unison/curry.rkt b/scheme-libs/racket/unison/curry.rkt new file mode 100644 index 0000000000..0fe7a080f5 --- /dev/null +++ b/scheme-libs/racket/unison/curry.rkt @@ -0,0 +1,124 @@ + +#lang racket + +(provide + unison-curry + unison-curry-0 + unison-curry-1 + unison-curry-2 + unison-curry-3 + unison-curry-4 + unison-curry-5 + unison-curry-6 + unison-curry-7 + unison-curry-8 + unison-curry-9) + +(require racket/performance-hint + racket/unsafe/undefined + (for-syntax + (only-in racket + const range match empty-sequence)) + unison/data) + +(define-for-syntax (vsym #:pre [pre "x"] n) + (string->symbol (string-append pre (number->string n)))) + +(define-for-syntax (curry-cases loc n ref:stx fun:stx us vs) + (define (sub us vs) (curry-expr loc n ref:stx fun:stx us vs)) + + (for/foldr ([cases (list)]) ([p (in-partitions vs)]) + (match p + [(cons pre post) + (with-syntax ([(u ...) us] + [(v ...) pre] + [f fun:stx]) + (cond + [(null? post) + (list* + (syntax/loc loc + [(v ...) (f u ... v ...)]) + (syntax/loc loc + [(v ... . rest) (apply (f u ... v ...) rest)]) + cases)] + [else + (with-syntax ([sc (sub (append us pre) post)]) + (cons + (syntax/loc loc [(v ...) sc]) + cases))]))]))) + +; Build case-lambdas that are nested n-deep for partitions of +; variables us and vs. +(define-for-syntax (curry-expr loc n ref:stx fun:stx us vs) + (cond + [(= 0 n) + (with-syntax ([(u ...) us] [gr ref:stx] [f fun:stx]) + (syntax/loc loc + (unison-closure gr f (list u ...))))] + [else + (with-syntax ([(c ...) (curry-cases loc (sub1 n) ref:stx fun:stx us vs)]) + (syntax/loc loc + (case-lambda c ...)))])) + +(define-for-syntax (in-parts pre post) + (in-sequences + (in-value (cons (reverse pre) post)) + (match post + ['() empty-sequence] + [(cons x xs) (in-parts (cons x pre) xs)]))) + +(define-for-syntax (in-partitions xs) (in-parts '() xs)) + +(define-for-syntax (build-curried loc n ref:stx fun:stx) + (define xs:stx (generate-temporaries (map (const 'x) (range n)))) + + (curry-expr loc 2 ref:stx fun:stx '() xs:stx)) + +(define-for-syntax (build-curry loc n) + (define ref:stx (syntax/loc loc gr)) + (define fun:stx (syntax/loc loc f)) + + (with-syntax ([body (build-curried loc n ref:stx fun:stx)]) + (syntax/loc loc + (lambda (gr f) body)))) + +(define-syntax (make-curry stx) + (syntax-case stx () + [(make-curry n gr f) + (build-curried stx (syntax->datum #'n) #'gr #'f)])) + ; (build-curry stx (syntax->datum #'n))])) + +(begin-encourage-inline + (define ((unison-curry-0 gr f) #:reflect [ref? unsafe-undefined] . rest) + (if (eq? ref? unsafe-undefined) + (if (= (length rest) 0) + (f) + (apply (f) rest)) + (unison-closure gr f rest))) + + (define (unison-curry-1 gr f) (make-curry 1 gr f)) + (define (unison-curry-2 gr f) (make-curry 2 gr f)) + (define (unison-curry-3 gr f) (make-curry 3 gr f)) + (define (unison-curry-4 gr f) (make-curry 4 gr f)) + (define (unison-curry-5 gr f) (make-curry 5 gr f)) + (define (unison-curry-6 gr f) (make-curry 6 gr f)) + (define (unison-curry-7 gr f) (make-curry 7 gr f)) + (define (unison-curry-8 gr f) (make-curry 8 gr f)) + (define (unison-curry-9 gr f) (make-curry 9 gr f))) + +(define-syntax (unison-curry stx) + (syntax-case stx () + [(unison-curry #:inline n gr f) + (build-curried stx (syntax->datum #'n) #'gr #'f)] + [(unison-curry n gr f) + (let ([m (syntax->datum #'n)]) + (cond + [(< m 10) + (define curry:stx (vsym #:pre "unison-curry-" m)) + (with-syntax ([u-curry curry:stx]) + (syntax/loc stx + (u-curry gr f)))] + [else + (build-curried stx m #'gr #'f)]))])) + + diff --git a/scheme-libs/racket/unison/data.ss b/scheme-libs/racket/unison/data.ss index 7ab75d6d5b..f4c6edfd8a 100644 --- a/scheme-libs/racket/unison/data.ss +++ b/scheme-libs/racket/unison/data.ss @@ -12,6 +12,12 @@ have-code? (struct-out unison-data) + (struct-out unison-continuation) + (struct-out unison-cont-wrapped) + (struct-out unison-cont-reflected) + (struct-out unison-frame) + (struct-out unison-frame-push) + (struct-out unison-frame-mark) (struct-out unison-sum) (struct-out unison-pure) (struct-out unison-request) @@ -23,10 +29,18 @@ (struct-out unison-typelink) (struct-out unison-typelink-builtin) (struct-out unison-typelink-derived) + (struct-out unison-groupref) + (struct-out unison-groupref-builtin) + (struct-out unison-groupref-derived) (struct-out unison-code) (struct-out unison-quote) (struct-out unison-timespec) + build-closure + + call-with-handler + call-with-marks + define-builtin-link declare-builtin-link @@ -45,9 +59,9 @@ left? either-get either-get - unit - false - true + sum-unit + sum-false + sum-true bool char ord @@ -100,12 +114,19 @@ builtin-tls.version:typelink unison-tuple->list + unison-pair->cons typelink->string - termlink->string) + termlink->string + groupref->string + + groupref->termlink + termlink->groupref) (require - racket + (rename-in racket + [make-continuation-prompt-tag make-prompt]) + (only-in racket/control prompt0-at control0-at) racket/fixnum (only-in "vector-trie.rkt" ->fx/wraparound) unison/bytevector) @@ -211,6 +232,48 @@ (hash i) #:reflection-name 'termlink) +; A groupref is like a termlink, but is used for reflection of +; functions. As such, there is no con case. Also, there's an extra +; level of indexing involved in grouprefs, because multiple scheme +; functions can be generated from the same top level unison +; definition, even after floating. +(struct unison-groupref () + #:methods gen:custom-write + [(define (write-proc gr port mode) + (write-string (groupref->string gr #t) port))] + #:property prop:equal+hash + (let () + (define (equal-proc grl grr rec) + (match grl + [(unison-groupref-builtin nl) + (match grr + [(unison-groupref-builtin nr) + (rec nl nr)] + [else #f])] + [(unison-groupref-derived hl il ll) + (match grr + [(unison-groupref-derived hr ir lr) + (and (rec hl hr) (= il ir) (= ll lr))] + [else #f])])) + + (define ((hash-proc init) gr rec) + (match gr + [(unison-groupref-builtin n) + (fxxor (fx*/wraparound (rec n) 113) + (fx*/wraparound init 109))] + [(unison-groupref-derived h i l) + (fxxor (fx*/wraparound (rec h) 127) + (fx*/wraparound (rec i) 131) + (fx*/wraparound (rec l) 137))])) + + (list equal-proc (hash-proc 3) (hash-proc 5)))) + +(struct unison-groupref-builtin unison-groupref + (name)) + +(struct unison-groupref-derived unison-groupref + (hash index local)) + (struct unison-typelink () #:transparent #:reflection-name 'typelink @@ -290,13 +353,10 @@ (write-string ")" port)) (struct unison-closure - (code env) + (ref code env) #:transparent #:methods gen:custom-write [(define (write-proc clo port mode) - (define code-tl - (lookup-function-link (unison-closure-code clo))) - (define rec (case mode [(#t) write] @@ -308,12 +368,47 @@ (write-string " " port) (write-sequence (unison-closure-env clo) port mode) (write-string ")" port))] + + ; This has essentially becomes the slow path for unison function + ; application. The definition macro immediately creates a closure + ; for any statically under-saturated call or unapplied occurrence. + ; This means that there is never a bare unison function being passed + ; as a value. So, we can define the slow path here once and for all. #:property prop:procedure - (case-lambda - [(clo) clo] - [(clo . rest) - (apply (unison-closure-code clo) - (append (unison-closure-env clo) rest))])) + (lambda (clo . rest) + (define code (unison-closure-code clo)) + (define arity (procedure-arity code)) + (define old-env (unison-closure-env clo)) + + (define new-env (append old-env rest)) + (define k (length rest)) + (define l (length new-env)) + (cond + [(= arity l) ; saturated + (apply code new-env)] + [(= k 0) clo] ; special case, 0-applying undersaturated + [(< arity l) + ; TODO: pending arg annotation if no pure? + (define-values (now pending) (split-at new-env arity)) + (apply (apply code now) pending)] + [else ; still undersaturated + (struct-copy unison-closure clo [env new-env])]))) + +(define (reflect-procedure f) + (if (unison-closure? f) + f + (let-values ([(req opt) (procedure-keywords f)]) + (if (member '#:reflect opt) + ; 0-arg case + (f #:reflect #t) + ; otherwise, by convention, applying enough to 0 args reflects + ((f)))))) + +(define (build-closure f . args) + (define clo (reflect-procedure f)) + (define env (unison-closure-env clo)) + + (struct-copy unison-closure clo [env (append env args)])) (struct unison-timespec (sec nsec) #:transparent @@ -335,6 +430,115 @@ (list equal-proc (hash-proc 3) (hash-proc 5)))) +; This is the base struct for continuation representations. It has +; two possibilities seen below. +(struct unison-continuation () #:transparent) + +; This is a wrapper that allows for a struct representation of all +; continuations involved in unison. I.E. instead of just passing +; around a raw racket continuation, we wrap it in a box for easier +; identification. +(struct unison-cont-wrapped unison-continuation (cont) + ; Use the wrapped continuation for procedure calls. Continuations + ; will always be called via the jumpCont wrapper which exactly + ; applies them to one argument. + #:property prop:procedure 0) + +; Basic mechanism for installing handlers, defined here so that it +; can be used in the implementation of reflected continuations. +; +; Note: this uses the prompt _twice_ to achieve the sort of dynamic +; scoping we want. First we push an outer delimiter, then install +; the continuation marks corresponding to the handled abilities +; (which tells which propt to use for that ability and which +; functions to use for each request). Then we re-delimit by the same +; prompt. +; +; If we just used one delimiter, we'd have a problem. If we pushed +; the marks _after_ the delimiter, then the continuation captured +; when handling would contain those marks, and would effectively +; retain the handler for requests within the continuation. If the +; marks were outside the prompt, we'd be in a similar situation, +; except where the handler would be automatically handling requests +; within its own implementation (although, in both these cases we'd +; get control errors, because we would be using the _function_ part +; of the handler without the necessary delimiters existing on the +; continuation). Both of these situations are wrong for _shallow_ +; handlers. +; +; Instead, what we need to be able to do is capture the continuation +; _up to_ the marks, then _discard_ the marks, and this is what the +; multiple delimiters accomplish. There might be more efficient ways +; to accomplish this with some specialized mark functions, but I'm +; uncertain of what pitfalls there are with regard to that (whehter +; they work might depend on exact frame structure of the +; metacontinuation). +(define (call-with-handler rs h f) + (let ([p (make-prompt)]) + (prompt0-at p + (let ([v (call-with-marks rs (cons p h) + (lambda () (prompt0-at p (f))))]) + (h (make-pure v)))))) + +(define (call-with-marks rs v f) + (cond + [(null? rs) (f)] + [else + (with-continuation-mark (car rs) v + (call-with-marks (cdr rs) v f))])) + +; Version of the above for re-installing a handlers in the serialized +; format. In that case, there is an association list of links and +; handlers, rather than a single handler (although the separate +; handlers are likely duplicates). +(define (call-with-assoc-marks p hs f) + (match hs + ['() (f)] + [(cons (cons r h) rest) + (with-continuation-mark r (cons p h) + (call-with-assoc-marks rest f))])) + +(define (call-with-handler-assocs hs f) + (let ([p (make-prompt)]) + (prompt0-at p + (call-with-assoc-marks p hs + (lambda () (prompt0-at p (f))))))) + +(define (repush frames v) + (match frames + ['() v] + [(cons (unison-frame-mark as tls hs) frames) + ; handler frame; as are pending arguments, tls are typelinks + ; for handled abilities; hs are associations from links to + ; handler values. + ; + ; todo: args + (call-with-handler-assocs hs + (lambda () (repush frames v)))] + [(cons (unison-frame-push ls as rt) rest) + (displayln (list ls as rt)) + (raise "repush push: not implemented yet")])) + +; This is a *reflected* representation of continuations amenable +; to serialization. Most continuations won't be in this format, +; because it's foolish to eagerly parse the racket continuation if +; it's just going to be applied. But, a continuation that we've +; gotten from serialization will be in this format. +; +; `frames` should be a list of the below `unison-frame` structs. +(struct unison-cont-reflected unison-continuation (frames) + #:property prop:procedure + (lambda (cont v) (repush (unison-cont-reflected-frames cont) v))) + +; Stack frames for reflected continuations +(struct unison-frame () #:transparent) + +(struct unison-frame-push unison-frame + (locals args return-to)) + +(struct unison-frame-mark unison-frame + (args abilities handlers)) + (define-syntax (define-builtin-link stx) (syntax-case stx () [(_ name) @@ -344,9 +548,11 @@ [dname (datum->syntax stx (string->symbol (string-append - "builtin-" txt ":termlink")))]) - #`(define #,dname - (unison-termlink-builtin #,(datum->syntax stx txt))))])) + "builtin-" txt ":termlink")) + #'name)]) + (quasisyntax/loc stx + (define #,dname + (unison-termlink-builtin #,(datum->syntax stx txt)))))])) (define-syntax (declare-builtin-link stx) (syntax-case stx () @@ -357,7 +563,8 @@ [dname (datum->syntax stx (string->symbol (string-append txt ":termlink")))]) - #`(declare-function-link name #,dname))])) + (quasisyntax/loc stx + (declare-function-link name #,dname)))])) (define (partial-app f . args) (unison-closure f args)) @@ -382,11 +589,11 @@ ; # works as well ; Unit -(define unit (sum 0)) +(define sum-unit (sum 0)) ; Booleans are represented as numbers -(define false 0) -(define true 1) +(define sum-false 0) +(define sum-true 1) (define (bool b) (if b 1 0)) @@ -522,7 +729,8 @@ (define code-associations (make-hash)) (define (declare-code hs co) - (hash-set! code-associations hs co)) + (unless (hash-has-key? code-associations hs) + (hash-set! code-associations hs co))) (define (lookup-code hs) (let ([mco (hash-ref code-associations hs #f)]) @@ -542,24 +750,41 @@ [else (raise "unison-tuple->list: unexpected value")]))) +(define (unison-pair->cons t) + (match t + [(unison-data _ _ (list x (unison-data _ _ (list y _)))) + (cons x y)] + [else + (raise "unison-pair->cons: unexpected value")])) + (define (hash-string hs) (string-append "#" (bytevector->base32-string hs #:alphabet 'hex))) -(define (ix-string i) +(define (ix-string #:sep [sep "."] i) (if (= i 0) "" - (string-append "." (number->string i)))) + (string-append sep (number->string i)))) -(define (typelink->string ln [short #f]) - (define (clip s) (if short (substring s 0 8) s)) +(define (clip short s) (if short (substring s 0 8) s)) +(define (typelink->string ln [short #f]) (match ln [(unison-typelink-builtin name) (string-append "##" name)] [(unison-typelink-derived hs i) - (string-append (clip (hash-string hs)) (ix-string i))])) + (string-append (clip short (hash-string hs)) (ix-string i))])) + +(define (groupref->string gr [short #f]) + (match gr + [(unison-groupref-builtin name) + (string-append "##" name)] + [(unison-groupref-derived hs i l) + (string-append + (clip short (hash-string hs)) + (ix-string i) + (ix-string #:sep "-" l))])) (define (termlink->string ln [short #f]) (define (clip s) (if short (substring s 0 8) s)) @@ -573,3 +798,22 @@ (string-append (typelink->string rf short) "#" (number->string t))])) +(define (groupref->termlink gr) + (match gr + [(unison-groupref-builtin name) + (unison-termlink-builtin name)] + [(unison-groupref-derived hs i _) + (unison-termlink-derived hs i)])) + +(define (termlink->groupref ln l) + (match ln + [#f #f] + [(unison-termlink-builtin name) + (unison-groupref-builtin name)] + [(unison-termlink-derived hs i) + (unison-groupref-derived hs i l)] + [(unison-termlink-con r i) + (raise-argument-error + 'termlink->groupref + "builtin or derived link" + ln)])) diff --git a/scheme-libs/racket/unison/gzip.rkt b/scheme-libs/racket/unison/gzip.rkt index c223476c8d..ed4c40304f 100644 --- a/scheme-libs/racket/unison/gzip.rkt +++ b/scheme-libs/racket/unison/gzip.rkt @@ -7,10 +7,9 @@ bytes->chunked-bytes chunked-bytes->bytes)) -(provide (prefix-out unison-FOp-Bytes. - (combine-out - gzip.compress - gzip.decompress))) +(provide + gzip-bytes + gunzip-bytes) (define (gzip-bytes bytes) (let ([op1 (open-output-bytes)]) diff --git a/scheme-libs/racket/unison/io-handles.rkt b/scheme-libs/racket/unison/io-handles.rkt deleted file mode 100644 index 9f5c1bdc6f..0000000000 --- a/scheme-libs/racket/unison/io-handles.rkt +++ /dev/null @@ -1,234 +0,0 @@ -#lang racket/base -(require racket/string - rnrs/io/ports-6 - (only-in rnrs standard-error-port standard-input-port standard-output-port vector-map) - (only-in racket empty? with-output-to-string system/exit-code system false?) - (only-in unison/boot data-case define-unison) - unison/data - unison/chunked-seq - unison/data - unison/data-info - unison/chunked-seq - unison/data - ) - -(provide - unison-FOp-IO.stdHandle - unison-FOp-IO.openFile.impl.v3 - (prefix-out - builtin-IO. - (combine-out - seekHandle.impl.v3 - getLine.impl.v1 - getSomeBytes.impl.v1 - getBuffering.impl.v3 - setBuffering.impl.v3 - getEcho.impl.v1 - setEcho.impl.v1 - getArgs.impl.v1 - getEnv.impl.v1 - getChar.impl.v1 - isFileOpen.impl.v3 - isSeekable.impl.v3 - handlePosition.impl.v3 - process.call - getCurrentDirectory.impl.v3 - ready.impl.v1 - )) - -; Still to implement: -; handlePosition.impl.v3 -; isSeekable.impl.v3 -; getChar.impl.v1 - ) - -; typeLink msg any -(define (Exception typeLink message payload) - (let* ([a (unison-any-any payload)] - [msg (string->chunked-string message)] - [f (ref-failure-failure typeLink msg a)]) - (ref-either-left f))) - -(define-unison (isFileOpen.impl.v3 port) - (ref-either-right (not (port-closed? port)))) - -(define-unison (ready.impl.v1 port) - (if (byte-ready? port) - (ref-either-right #t) - (if (port-eof? port) - (Exception ref-iofailure:typelink "EOF" port) - (ref-either-right #f)))) - -(define-unison (getCurrentDirectory.impl.v3 unit) - (ref-either-right - (string->chunked-string (path->string (current-directory))))) - -(define-unison (isSeekable.impl.v3 handle) - (ref-either-right - (port-has-set-port-position!? handle))) - -(define-unison (handlePosition.impl.v3 handle) - (ref-either-right (port-position handle))) - -(define-unison (seekHandle.impl.v3 handle mode amount) - (data-case mode - (0 () - (set-port-position! handle amount) - (ref-either-right none)) - (1 () - (let ([current (port-position handle)]) - (set-port-position! handle (+ current amount)) - (ref-either-right none))) - (2 () - (Exception - ref-iofailure:typelink - "SeekFromEnd not supported" - 0)))) - -(define-unison (getLine.impl.v1 handle) - (let* ([line (read-line handle)]) - (if (eof-object? line) - (ref-either-right (string->chunked-string "")) - (ref-either-right (string->chunked-string line)) - ))) - -(define-unison (getChar.impl.v1 handle) - (let* ([char (read-char handle)]) - (if (eof-object? char) - (Exception - ref-iofailure:typelink - "End of file reached" - ref-unit-unit) - (ref-either-right char)))) - -(define-unison (getSomeBytes.impl.v1 handle nbytes) - (let* ([buffer (make-bytes nbytes)] - [line (read-bytes-avail! buffer handle)]) - (cond - [(eof-object? line) - (ref-either-right (bytes->chunked-bytes #""))] - [(procedure? line) - (Exception - ref-iofailure:typelink - "getSomeBytes.impl: special value returned" - ref-unit-unit)] - [else - (ref-either-right - (bytes->chunked-bytes - (if (< line nbytes) - (subbytes buffer 0 line) - buffer)))]))) - -(define-unison (getBuffering.impl.v3 handle) - (case (file-stream-buffer-mode handle) - [(none) (ref-either-right ref-buffermode-no-buffering)] - [(line) (ref-either-right - ref-buffermode-line-buffering)] - [(block) (ref-either-right - ref-buffermode-block-buffering)] - [(#f) (Exception - ref-iofailure:typelink - "Unable to determine buffering mode of handle" - ref-unit-unit)] - [else (Exception - ref-iofailure:typelink - "Unexpected response from file-stream-buffer-mode" - ref-unit-unit)])) - -(define-unison (setBuffering.impl.v3 handle mode) - (data-case mode - (0 () - (file-stream-buffer-mode handle 'none) - (ref-either-right none)) - (1 () - (file-stream-buffer-mode handle 'line) - (ref-either-right none)) - (2 () - (file-stream-buffer-mode handle 'block) - (ref-either-right none)) - (3 (size) - (Exception - ref-iofailure:typelink - "Sized block buffering not supported" - ref-unit-unit)))) - -(define (with-buffer-mode port mode) - (file-stream-buffer-mode port mode) - port) - -(define stdin (with-buffer-mode (standard-input-port) 'none)) -(define stdout (with-buffer-mode (standard-output-port) 'line)) -(define stderr (with-buffer-mode (standard-error-port) 'line)) - -(define (unison-FOp-IO.stdHandle n) - (case n - [(0) stdin] - [(1) stdout] - [(2) stderr])) - -(define-unison (getEcho.impl.v1 handle) - (if (eq? handle stdin) - (ref-either-right (get-stdin-echo)) - (Exception - ref-iofailure:typelink - "getEcho only supported on stdin" - ref-unit-unit))) - -(define-unison (setEcho.impl.v1 handle echo) - (if (eq? handle stdin) - (begin - (if echo - (system "stty echo") - (system "stty -echo")) - (ref-either-right none)) - (Exception - ref-iofailure:typelink - "setEcho only supported on stdin" - ref-unit-unit))) - -(define (get-stdin-echo) - (let ([current (with-output-to-string (lambda () (system "stty -a")))]) - (string-contains? current " echo "))) - -(define-unison (getArgs.impl.v1 unit) - (ref-either-right - (vector->chunked-list - (vector-map string->chunked-string (current-command-line-arguments))))) - -(define-unison (getEnv.impl.v1 key) - (let ([value (environment-variables-ref (current-environment-variables) (string->bytes/utf-8 (chunked-string->string key)))]) - (if (false? value) - (Exception - ref-iofailure:typelink - "environmental variable not found" - key) - (ref-either-right - (string->chunked-string (bytes->string/utf-8 value)))))) - -(define (unison-FOp-IO.openFile.impl.v3 fn0 mode) - (define fn (chunked-string->string fn0)) - - (right (case mode - [(0) (open-input-file fn)] - [(1) (open-output-file fn #:exists 'truncate)] - [(2) (open-output-file fn #:exists 'append)] - [else (open-input-output-file fn #:exists 'can-update)]))) - -;; From https://github.com/sorawee/shlex/blob/5de06500e8c831cfc8dffb99d57a76decc02c569/main.rkt (MIT License) -;; with is a port of https://github.com/python/cpython/blob/bf2f76ec0976c09de79c8827764f30e3b6fba776/Lib/shlex.py#L325 -(define unsafe-pattern #rx"[^a-zA-Z0-9_@%+=:,./-]") -(define (quote-arg s) - (if (non-empty-string? s) - (if (regexp-match unsafe-pattern s) - (string-append "'" (string-replace s "'" "'\"'\"'") "'") - s) - "''")) - -(define-unison (process.call command arguments) - (system/exit-code - (string-join (cons - (chunked-string->string command) - (map (lambda (arg) (quote-arg (chunked-string->string arg))) - (vector->list - (chunked-list->vector arguments)))) - " "))) diff --git a/scheme-libs/racket/unison/io.rkt b/scheme-libs/racket/unison/io.rkt deleted file mode 100644 index bc94c53149..0000000000 --- a/scheme-libs/racket/unison/io.rkt +++ /dev/null @@ -1,194 +0,0 @@ -#lang racket/base -(require unison/data - unison/chunked-seq - unison/core - unison/data-info - racket/file - racket/flonum - (only-in racket - date-dst? - date-time-zone-offset - date*-time-zone-name) - (only-in unison/boot data-case define-unison) - (only-in - rnrs/arithmetic/flonums-6 - flmod)) -(require racket/file) - -(provide - builtin-Clock.internals.systemTimeZone.v1 - (prefix-out - unison-FOp-Clock.internals. - (combine-out - threadCPUTime.v1 - processCPUTime.v1 - realtime.v1 - monotonic.v1 - sec.v1 - nsec.v1)) - (prefix-out - unison-FOp-IO. - (combine-out - getFileTimestamp.impl.v3 - getTempDirectory.impl.v3 - removeFile.impl.v3 - getFileSize.impl.v3)) - (prefix-out - builtin-IO. - (combine-out - fileExists.impl.v3 - renameFile.impl.v3 - createDirectory.impl.v3 - removeDirectory.impl.v3 - directoryContents.impl.v3 - setCurrentDirectory.impl.v3 - renameDirectory.impl.v3 - isDirectory.impl.v3 - systemTime.impl.v3 - systemTimeMicroseconds.impl.v3 - createTempDirectory.impl.v3))) - -(define (failure-result ty msg vl) - (ref-either-left - (ref-failure-failure - ty - (string->chunked-string msg) - (unison-any-any vl)))) - -(define (getFileSize.impl.v3 path) - (with-handlers - [[exn:fail:filesystem? - (lambda (e) - (exception - ref-iofailure:typelink - (exception->string e) - ref-unit-unit))]] - (right (file-size (chunked-string->string path))))) - -(define (getFileTimestamp.impl.v3 path) - (with-handlers - [[exn:fail:filesystem? - (lambda (e) - (exception - ref-iofailure:typelink - (exception->string e) - ref-unit-unit))]] - (right (file-or-directory-modify-seconds (chunked-string->string path))))) - -; in haskell, it's not just file but also directory -(define-unison (fileExists.impl.v3 path) - (let ([path-string (chunked-string->string path)]) - (ref-either-right - (or - (file-exists? path-string) - (directory-exists? path-string))))) - -(define (removeFile.impl.v3 path) - (delete-file (chunked-string->string path)) - (right none)) - -(define (getTempDirectory.impl.v3) - (right (string->chunked-string (path->string (find-system-path 'temp-dir))))) - -(define-unison (setCurrentDirectory.impl.v3 path) - (current-directory (chunked-string->string path)) - (ref-either-right none)) - -(define-unison (directoryContents.impl.v3 path) - (with-handlers - [[exn:fail:filesystem? - (lambda (e) - (failure-result - ref-iofailure:typelink - (exception->string e) - ref-unit-unit))]] - (let* ([dirps (directory-list (chunked-string->string path))] - [dirss (map path->string dirps)]) - (ref-either-right - (vector->chunked-list - (list->vector - (map - string->chunked-string - (list* "." ".." dirss)))))))) - - -(define-unison (createTempDirectory.impl.v3 prefix) - (ref-either-right - (string->chunked-string - (path->string - (make-temporary-directory* - (string->bytes/utf-8 - (chunked-string->string prefix)) #""))))) - -(define-unison (createDirectory.impl.v3 file) - (make-directory (chunked-string->string file)) - (ref-either-right none)) - -(define-unison (removeDirectory.impl.v3 file) - (delete-directory/files (chunked-string->string file)) - (ref-either-right none)) - -(define-unison (isDirectory.impl.v3 path) - (ref-either-right - (directory-exists? (chunked-string->string path)))) - -(define-unison (renameDirectory.impl.v3 old new) - (rename-file-or-directory (chunked-string->string old) - (chunked-string->string new)) - (ref-either-right none)) - -(define-unison (renameFile.impl.v3 old new) - (rename-file-or-directory (chunked-string->string old) - (chunked-string->string new)) - (ref-either-right none)) - -(define-unison (systemTime.impl.v3 unit) - (ref-either-right (current-seconds))) - -(define-unison (systemTimeMicroseconds.impl.v3 unit) - (ref-either-right (inexact->exact (* 1000 (current-inexact-milliseconds))))) - -(define-unison (builtin-Clock.internals.systemTimeZone.v1 secs) - (let* ([d (seconds->date secs)]) - (list->unison-tuple - (list - (date-time-zone-offset d) - (if (date-dst? d) 1 0) - (date*-time-zone-name d))))) - -(define (threadCPUTime.v1) - (right - (integer->time - (current-process-milliseconds (current-thread))))) - -(define (processCPUTime.v1) - (right - (integer->time - (current-process-milliseconds #f)))) - -(define (realtime.v1) - (right - (float->time - (current-inexact-milliseconds)))) - -(define (monotonic.v1) - (right - (float->time - (current-inexact-monotonic-milliseconds)))) - -(define (integer->time msecs) - (unison-timespec - (truncate (/ msecs 1000)) - (* (modulo msecs 1000) 1000000))) - -(define (float->time msecs) - (unison-timespec - (trunc (/ msecs 1000)) - (trunc (* (flmod msecs 1000.0) 1000000)))) - -; -(define (trunc f) (inexact->exact (truncate f))) - -(define sec.v1 unison-timespec-sec) - -(define nsec.v1 unison-timespec-nsec) diff --git a/scheme-libs/racket/unison/math.rkt b/scheme-libs/racket/unison/math.rkt deleted file mode 100644 index 2e34a49987..0000000000 --- a/scheme-libs/racket/unison/math.rkt +++ /dev/null @@ -1,140 +0,0 @@ -#lang racket/base - -(require math/base - racket/performance-hint - rnrs/arithmetic/bitwise-6 - (only-in unison/boot - clamp-integer - clamp-natural - data-case - define-unison - nbit63)) - -(provide - builtin-Float.exp - builtin-Float.log - builtin-Float.max - builtin-Float.min - builtin-Float.tan - builtin-Float.tanh - builtin-Float.logBase - builtin-Int.* - builtin-Int.pow - builtin-Int.trailingZeros - builtin-Nat.trailingZeros - builtin-Int.popCount - builtin-Nat.popCount - builtin-Float.pow - (prefix-out unison-POp- - (combine-out - ABSF - ACOS - ACSH - ADDF - ADDI - LOGB - ASIN - SINH - TRNF - RNDF - SQRT - TANH - TANF - TZRO - POPC - ASNH - ATAN - ATN2 - ATNH - CEIL - FLOR - EXPF - COSF - COSH - MAXF - MINF - MULF - MULI - NEGI - NTOF - POWF - POWI - POWN - DIVF - DIVI - EQLF - EQLI - SUBF - SUBI - SGNI - LEQF - SINF - ITOF))) - -(define-unison (builtin-Float.logBase base num) (log num base)) -(define (LOGB base num) (log num base)) -(define-unison (builtin-Float.exp n) (exp n)) -(define-unison (builtin-Float.log n) (log n)) -(define-unison (builtin-Float.max n m) (max n m)) -(define-unison (builtin-Float.min n m) (min n m)) -(define-unison (builtin-Float.tan n) (tan n)) -(define-unison (builtin-Float.tanh n) (tanh n)) -(define-unison (builtin-Int.* n m) (clamp-integer (* n m))) -(define-unison (builtin-Int.pow n m) (clamp-integer (expt n m))) -(define-unison (builtin-Int.trailingZeros n) (TZRO n)) -(define-unison (builtin-Nat.trailingZeros n) (TZRO n)) -(define-unison (builtin-Nat.popCount n) (POPC n)) -(define-unison (builtin-Int.popCount n) (POPC n)) -(define-unison (builtin-Float.pow n m) (expt n m)) -(define (EXPF n) (exp n)) -(define ABSF abs) -(define ACOS acos) -(define ACSH acosh) -(define ADDF +) -(define (ADDI i j) (clamp-integer (+ i j))) -(define SUBF -) -(define (SUBI i j) (clamp-integer (- i j))) -(define (SGNI n) (if (< n 0) -1 (if (> n 0) +1 0))) -(define MAXF max) -(define MINF min) -(define MULF *) -(define (MULI i j) (clamp-integer (* i j))) -(define (NEGI i) (if (> i nbit63) (- i) i)) -(define NTOF exact->inexact) -(define POWF expt) -(define (POWI i j) (clamp-integer (expt i j))) -(define (POWN i j) (clamp-natural (expt i j))) -(define ASIN asin) -(define ASNH asinh) -(define ATAN atan) -(define ATN2 atan) -(define ATNH atanh) -(define CEIL ceiling) -(define FLOR floor) -(define COSF cos) -(define (TRNF f) - (cond - [(or (= f +inf.0) (= f -inf.0) (eqv? f +nan.0) (eqv? f +nan.f)) 0] - [else (clamp-integer (inexact->exact (truncate f)))])) -(define RNDF round) -(define SQRT sqrt) -(define TANF tan) -(define TANH tanh) -(define SINF sin) -(define SINH sinh) -(define COSH cosh) -(define DIVF /) -(define (DIVI i j) (floor (/ i j))) -(define ITOF exact->inexact) -(define (EQLF a b) (if (= a b) 1 0)) -(define (LEQF a b) (if (<= a b) 1 0)) -(define (EQLI a b) (if (= a b) 1 0)) - -(define (POPC n) - (modulo (bitwise-bit-count n) 65)) - -(define (TZRO n) - (let ([bit (bitwise-first-bit-set n)]) - (if (eq? -1 bit) - 64 - bit))) diff --git a/scheme-libs/racket/unison/network-utils.rkt b/scheme-libs/racket/unison/network-utils.rkt index a7b6cab73a..952cda94c7 100644 --- a/scheme-libs/racket/unison/network-utils.rkt +++ b/scheme-libs/racket/unison/network-utils.rkt @@ -5,27 +5,34 @@ unison/chunked-seq unison/core) ; exception->string, chunked-string -(provide handle-errors) +(provide + handle-errors + (struct-out socket-pair)) -(define (handle-errors fn) - (with-handlers - [[exn:fail:network? - (lambda (e) - (exception - ref-iofailure:typelink - (exception->string e) - ref-unit-unit))] - [exn:fail:contract? +(struct socket-pair (input output)) + +(define-syntax handle-errors + (syntax-rules () + [(_ ex ...) + (with-handlers + [[exn:fail:network? + (lambda (e) + (exception + ref-iofailure:typelink + (exception->string e) + ref-unit-unit))] + [exn:fail:contract? + (lambda (e) + (exception + ref-miscfailure:typelink + (exception->string e) + ref-unit-unit))] + [(lambda _ #t) (lambda (e) (exception ref-miscfailure:typelink - (exception->string e) - ref-unit-unit))] - [(lambda _ #t) - (lambda (e) - (exception - ref-miscfailure:typelink - (string->chunked-string - (format "Unknown exception ~a" (exn->string e))) - ref-unit-unit))]] - (fn))) + (string->chunked-string + (format "Unknown exception ~a" (exn->string e))) + ref-unit-unit))]] + ex ...)])) + diff --git a/scheme-libs/racket/unison/primops-generated.rkt b/scheme-libs/racket/unison/primops-generated.rkt index 0e9b462ff6..741e1da740 100644 --- a/scheme-libs/racket/unison/primops-generated.rkt +++ b/scheme-libs/racket/unison/primops-generated.rkt @@ -7,6 +7,7 @@ #!racket/base (require (except-in racket false true unit any) racket/vector + racket/hash unison/boot unison/boot-generated (only-in unison/bytevector bytevector->base32-string) @@ -31,20 +32,22 @@ builtin-sandboxLinks builtin-sandboxLinks:termlink + builtin-Code.dependencies:termlink builtin-Code.deserialize:termlink builtin-Code.serialize:termlink builtin-Code.validateLinks:termlink + builtin-Value.dependencies:termlink builtin-Value.deserialize:termlink builtin-Value.serialize:termlink builtin-crypto.hash:termlink builtin-crypto.hmac:termlink - unison-POp-CACH - unison-POp-LOAD - unison-POp-LKUP + builtin-Value.load + builtin-Value.load:termlink + builtin-Code.cache_ + builtin-Code.cache_:termlink ; some exports of internal machinery for use elsewhere - gen-code reify-value reflect-value termlink->name @@ -54,21 +57,15 @@ build-runtime-module termlink->proc) -(define-builtin-link Value.value) -(define-builtin-link Value.reflect) -(define-builtin-link Code.isMissing) -(define-builtin-link Code.lookup) - +(define-builtin-link Code.dependencies) (define-builtin-link Code.deserialize) (define-builtin-link Code.serialize) (define-builtin-link Code.validateLinks) +(define-builtin-link Value.dependencies) (define-builtin-link Value.deserialize) (define-builtin-link Value.serialize) (define-builtin-link crypto.hash) (define-builtin-link crypto.hmac) -(define-builtin-link validateSandboxed) -(define-builtin-link Value.validateSandboxed) -(define-builtin-link sandboxLinks) (define (chunked-list->list cl) (vector->list (chunked-list->vector cl))) @@ -89,9 +86,7 @@ [(unison-data _ t (list as h tms)) #:when (= t ref-schemeterm-handle:tag) `(handle - ,(map - (lambda (tx) (text->linkname tx)) - (chunked-list->list as)) + ,(map text->ident (chunked-list->list as)) ,(text->ident h) ,@(map decode-term (chunked-list->list tms)))] [(unison-data _ t (list hd sc cs)) @@ -129,14 +124,66 @@ (raise (format "decode-binding: unimplemented case: ~a" bn))])) +; This decodes the internal unison SchemeIntermed structure for +; representing generated declarations of intermediate code. The +; structure is just a pair of a name and a SchemeTerm representing +; the code. +(define (decode-intermediate im) + (match im + [(unison-data _ t (list name tm)) + #:when (= t ref-schemeintermed-interdef:tag) + `(define ,(text->ident name #:suffix ":code") + ,(decode-term tm))] + [else + (raise-argument-error + 'decode-intermediate + "scheme-intermediate" + im)])) + +(define (decode-hints hs) + (define (hint->sym t) + (cond + [(= t ref-defnhint-internal:tag) 'internal] + [(= t ref-defnhint-genlink:tag) 'gen-link] + [(= t ref-defnhint-nolinkdecl:tag) 'no-link-decl])) + + (for/fold ([def 'define-unison] [out '()]) ([h hs]) + (match h + [(unison-data _ t (list)) + #:when (= t ref-defnhint-builtin:tag) + (values 'define-unison-builtin out)] + [(unison-data _ t (list)) + (values def (cons (hint->sym t) out))]))) + +(define (decode-local lo) + (match lo + [(unison-data _ t (list)) + #:when (= t ref-optional-none:tag) + 0] + [(unison-data _ t (list n)) + #:when (= t ref-optional-some:tag) + n])) + (define (decode-syntax dfn) (match dfn - [(unison-data _ t (list nm vs bd)) + [(unison-data _ t (list nm lo hs vs bd)) #:when (= t ref-schemedefn-define:tag) - (let ([head (map text->ident - (cons nm (chunked-list->list vs)))] - [body (decode-term bd)]) - (list 'define-unison head body))] + (let-values + ([(head) (map text->ident + (cons nm (chunked-list->list vs)))] + [(ln) (decode-local lo)] + [(def hints) (decode-hints (chunked-list->list hs))] + [(body) (decode-term bd)]) + (if (null? hints) + (list def '#:local ln head body) + (list def '#:local ln '#:hints hints head body)))] + [(unison-data _ t (list nm hs bd)) + #:when (= t ref-schemedefn-defineval:tag) + (let-values + ([(head) (text->ident nm)] + [(def hints) (decode-hints (chunked-list->list hs))] + [(body) (decode-term bd)]) + (list def '#:hints (cons 'value hints) (list head) body))] [(unison-data _ t (list nm bd)) #:when (= t ref-schemedefn-alias:tag) (list 'define (text->ident nm) (decode-term bd))] @@ -154,7 +201,7 @@ (let* ([st (chunked-string->string tx)]) (string->symbol (string-append st ":typelink")))) -(define (text->ident tx) +(define (text->ident tx #:suffix [suffix ""]) (let* ([st (chunked-string->string tx)] [n (string->number st)] [c (string->char st)]) @@ -163,7 +210,7 @@ [(equal? st "#t") #t] [c c] [n n] - [else (string->symbol st)]))) + [else (string->symbol (string-append st suffix))]))) (define (decode-ref rf) (match rf @@ -195,20 +242,17 @@ (describe-value tl)))] [1 (rf) rf])) -(define-syntax make-group-ref-decoder - (lambda (stx) - (syntax-case stx () - [(_) - #`(lambda (gr) - (data-case (group-ref-ident gr) - [#,ref-schemeterm-ident:tag (name) name] - [else - (raise - (format - "decode-group-ref: unimplemented data case: ~a" - (describe-value gr)))]))]))) - -(define decode-group-ref (make-group-ref-decoder)) +(define (decode-group-ref gr0) + (match (group-ref-ident gr0) + [(unison-data _ t (list name)) + #:when (= t ref-schemeterm-ident:tag) + name] + [else + (raise + (format + "decode-group-ref: unimplemented data case: ~a" + (describe-value gr0)))])) + (define (group-ref-sym gr) (string->symbol (chunked-string->string @@ -241,15 +285,6 @@ (raise (string-append "termlink-bytes: called with constructor link"))])) -(define (termlink->reference rn) - (match rn - [(unison-termlink-builtin name) - (ref-reference-builtin - (string->chunked-string name))] - [(unison-termlink-derived bs i) - (ref-reference-derived (ref-id-id bs i))] - [else (raise "termlink->reference: con case")])) - (define (group-reference gr) (data-case gr [0 (r _) r])) @@ -259,14 +294,18 @@ (namespace-require ''#%kernel ns) ns)) -(define runtime-module-map (make-hash)) +(define runtime-module-term-map (make-hash)) +(define runtime-module-type-map (make-hash)) (define (reflect-derived bs i) (data ref-reference:typelink ref-reference-derived:tag (data ref-id:typelink ref-id-id:tag bs i))) (define (function->groupref f) - (match (lookup-function-link f) + (reflect-groupref (unison-closure-ref (build-closure f)))) + +(define (link->groupref ln) + (match ln [(unison-termlink-derived h i) (ref-groupref-group (ref-reference-derived @@ -276,7 +315,7 @@ (ref-groupref-group (ref-reference-builtin (string->chunked-string name)) 0)] - [else (raise "function->groupref: con case")])) + [else (raise "link->groupref: con case")])) (define (reify-vlit vl) (match vl @@ -301,6 +340,65 @@ [else (raise (format "decode-vlit: unimplemented case: !a" vl))])])) +(define (reify-handlers hs) + (for/list ([h (chunked-list->list hs)]) + (match (unison-pair->cons h) + [(cons r h) + (cons (reference->typelink r) + (reify-value h))]))) + +(define (reflect-handlers hs) + (list->chunked-list + (for/list ([h hs]) + (match h + [(cons r h) + (unison-tuple + (typelink->reference r) + (reflect-value h))])))) + +(define (reify-groupref gr0) + (match gr0 + [(unison-data _ t (list r i)) + #:when (= t ref-groupref-group:tag) + (cons (reference->typelink r) i)])) + +(define (parse-continuation orig k0 vs0) + (let rec ([k k0] [vs vs0] [frames '()]) + (match k + [(unison-data _ t (list)) + #:when (= t ref-cont-empty:tag) + (unison-cont-reflected (reverse frames))] + [(unison-data _ t (list l a gr0 k)) + #:when (= t ref-cont-push:tag) + (cond + [(>= (length vs) (+ l a)) + (let*-values + ([(locals int) (split-at vs l)] + [(args rest) (split-at int a)] + [(gr) (reify-groupref gr0)] + [(fm) (unison-frame-push locals args gr)]) + (rec k rest (cons fm frames)))] + [else + (raise + (make-exn:bug + "reify-value: malformed continuation" + orig))])] + [(unison-data _ t (list a rs0 de0 k)) + #:when (= t ref-cont-mark:tag) + (cond + [(>= (length vs) a) + (let*-values + ([(args rest) (split-at vs a)] + [(rs) (map reference->termlink (chunked-list->list rs0))] + [(hs) (reify-handlers de0)] + [(fm) (unison-frame-mark args rs hs)]) + (rec k rest (cons fm frames)))] + [else + (raise + (make-exn:bug + "reify-value: malformed continuation" + orig))])]))) + (define (reify-value v) (match v [(unison-data _ t (list rf rt bs0)) @@ -326,17 +424,15 @@ [(unison-data _ t (list gr bs0)) #:when (= t ref-value-partial:tag) (let ([bs (map reify-value (chunked-list->list bs0))] - [proc (resolve-proc gr)]) - (apply proc bs))] + [proc (build-closure (resolve-proc gr))]) + (struct-copy unison-closure proc [env bs]))] [(unison-data _ t (list vl)) #:when (= t ref-value-vlit:tag) (reify-vlit vl)] - [(unison-data _ t (list bs0 k)) + [(unison-data _ t (list vs0 k)) #:when (= t ref-value-cont:tag) - (raise - (make-exn:bug - "reify-value: unimplemented cont case" - ref-unit-unit))] + (parse-continuation v k + (map reify-value (chunked-list->list vs0)))] [(unison-data r t fs) (raise (make-exn:bug @@ -376,6 +472,18 @@ [else (ref-reference-builtin (string->chunked-string "Float"))])) +(define (reflect-groupref gr) + (match gr + [(unison-groupref-derived h i l) + (ref-groupref-group + (ref-reference-derived + (ref-id-id h i)) + l)] + [(unison-groupref-builtin name) + (ref-groupref-group + (ref-reference-builtin (string->chunked-string name)) + 0)])) + (define (reflect-value v) (match v [(? boolean?) @@ -413,14 +521,35 @@ (ref-value-vlit (ref-vlit-typelink (reflect-typelink v)))] [(unison-code sg) (ref-value-vlit (ref-vlit-code sg))] [(unison-quote q) (ref-value-vlit (ref-vlit-quote q))] - [(unison-closure f as) + [(unison-cont-reflected frames0) + (for/foldr ([k ref-cont-empty] + [vs '()] + #:result + (ref-value-cont + (list->chunked-list (map reflect-value vs)) + k)) + ([frame frames0]) + (match frame + [(unison-frame-push locals args return-to) + (values + (ref-cont-push + (length locals) + (length args) + (reflect-groupref return-to) + k) + (append locals args vs))] + [(unison-frame-mark args refs hs) + (values + (ref-cont-mark + (length args) + (map typelink->reference refs) + (reflect-handlers hs)) + (append args vs))]))] + [(unison-closure gr f as) (ref-value-partial - (function->groupref f) + (reflect-groupref gr) (list->chunked-list (map reflect-value as)))] - [(? procedure?) - (ref-value-partial - (function->groupref v) - empty-chunked-list)] + [(? procedure?) (reflect-value (build-closure v))] [(unison-data rf t fs) (ref-value-data (reflect-typelink rf) @@ -430,25 +559,23 @@ (define (check-sandbox-ok ok l) (remove* ok (check-sandbox l))) -(define (sandbox-proc ok f) - (check-sandbox-ok ok (lookup-function-link f))) - (define (sandbox-scheme-value ok v) (match v [(? chunked-list?) (for/fold ([acc '()]) ([e (in-chunked-list v)]) - (append (sandbox-value ok e) acc))] - [(unison-closure f as) - (for/fold ([acc (sandbox-proc ok f)]) ([a (in-list as)]) + (append (sandbox-scheme-value ok e) acc))] + [(unison-closure gr f as) + (define link (groupref->termlink gr)) + (for/fold ([acc (check-sandbox-ok ok link)]) ([a (in-list as)]) (append (sandbox-scheme-value ok a) acc))] - [(? procedure?) (sandbox-proc ok v)] + [(? procedure?) (sandbox-scheme-value ok (build-closure v))] [(unison-data rf t fs) (for/fold ([acc '()]) ([e (in-list fs)]) (append (sandbox-scheme-value ok e) acc))] [else '()])) (define (check-known l acc) - (if (need-dependency? l) (cons l acc) acc)) + (if (need-code? l) (cons l acc) acc)) ; check sandboxing information for an internal.runtime.Value (define (sandbox-value ok v) @@ -474,11 +601,11 @@ [(unison-quote v) (sandbox-value ok v)])) ; replacment for Value.unsafeValue : a -> Value -(define-unison +(define-unison-builtin (builtin-Value.reflect v) (reflect-value v)) -(define-unison +(define-unison-builtin (builtin-Value.value v) (let ([rv (reflect-value v)]) (unison-quote rv))) @@ -510,77 +637,180 @@ (chunked-list->list (gen-typelink-defns links)))) -(define (gen-code args) - (let-values ([(tl co) (splat-upair args)]) - (match tl - [(unison-termlink-con r t) - (raise "CACH: trying to add code for data constructor")] - [(unison-termlink-builtin name) - (raise "CACH: trying to add code for a builtin")] - [(unison-termlink-derived bs i) - (let* ([sg (unison-code-rep co)] - [r (reflect-derived bs i)] - [ds (cons - (gen-link-def r) - (chunked-list->list (gen-scheme r sg)))] - [dc (decode-term (gen-link-decl r))]) - (append (map decode-syntax ds) (list dc)))]))) +(define (gen-code-decl r) + (define linkstr (chunked-string->string (ref-typelink-name r))) + (define name:link + (string->symbol (string-replace linkstr "typelink" "termlink"))) + (define name:code + (string->symbol (string-replace linkstr "typelink" "code"))) + + `(declare-code ,name:link (unison-code ,name:code))) + +; Given a termlink, code pair, generates associated definition +; and declaration code. Returns multiple results. +; +; This is the runtime loading version. It isn't necessary to generate +; code related definitions, because we already have the code values +; to add directly to the cache. +(define (gen-code:runtime arities tl co) + (match tl + [(unison-termlink-derived bs i) + (define sg (unison-code-rep co)) + (define r (reflect-derived bs i)) + (define ln (decode-syntax (gen-link-def r))) + (define ds (chunked-list->list (gen-scheme arities r sg))) + (define dc (decode-term (gen-link-decl r))) + + (values ln dc (map decode-syntax ds))] + [else + (raise-argument-error + 'gen-code:runtime + "unison-termlink-derived?" + tl)])) + +; Given a termlink, code pair, generates associated definition +; and declaration code. Returns multiple results. +; +; This is the version for compiling to intermediate code. It generates +; code declarations that will recreate the code values in the +; compiled executable. +(define (gen-code:intermed arities tl co) + (match tl + [(unison-termlink-derived bs i) + (define sg (unison-code-rep co)) + (define r (reflect-derived bs i)) + (define ln (decode-syntax (gen-link-def r))) + (define dc (decode-term (gen-link-decl r))) + (define cv (decode-intermediate (gen-code-value r sg))) + (define cd (gen-code-decl r)) + (define ds (chunked-list->list (gen-scheme arities r sg))) + + (values ln dc cv cd (map decode-syntax ds))] + [else + (raise-argument-error + 'gen-code:intermed + "unison-termlink-derived?" + tl)])) + +; Converts a link->code map into an appropriately sorted list +; for code generation. It's necessary to topologically sort +; the code so that values occur after the things they reference. +(define (codemap->link-order defs) + (define input + (for/list ([(tl co) defs]) + (unison-tuple + (termlink->reference tl) + (unison-code-rep co)))) + + (define result (topsort-code-refs (list->chunked-list input))) + + (for/list ([r (in-chunked-list result)]) + (reference->termlink r))) + +; Given a list of termlink, code pairs, returns multiple lists +; of definitions and declarations. The lists are returned as +; multiple results, each one containing a particular type of +; definition. +; +; This is the version for compiling to runtime code. +(define (gen-codes:runtime arities defs) + (for/lists (lndefs lndecs dfns) + ([tl (codemap->link-order defs)]) + (gen-code:runtime arities tl (hash-ref defs tl)))) + +; Given a list of termlink, code pairs, returns multiple lists +; of definitions and declarations. The lists are returned as +; multiple results, each one containing a particular type of +; definition. +; +; This is the version for compiling to intermediate code. +(define (gen-codes:intermed arities defs) + (for/lists (lndefs lndecs codefs codecls dfns) + ([tl (codemap->link-order defs)]) + (gen-code:intermed arities tl (hash-ref defs tl)))) (define (flatten ls) (cond [(null? ls) '()] [else (append (car ls) (flatten (cdr ls)))])) -(define module-count 0) +(define module-count (box 0)) (define (fresh-module-name) - (let ([n module-count]) - (set! module-count (+ n 1)) - (string-append "runtime-module-" (number->string n)))) + (let* ([n (unbox module-count)] + [sn (+ n 1)]) + (if (box-cas! module-count n sn) + (string-append "runtime-module-" (number->string n)) + (fresh-module-name)))) (define (generate-module-name links) - (if (null? links) - (raise "could not generate module name for dynamic code") - (let* ([top (car links)] - [bs (termlink-bytes top)] - [ebs (fresh-module-name)]) - (if (hash-has-key? runtime-module-map bs) - (generate-module-name (cdr links)) - (string->symbol ebs))))) + (string->symbol (fresh-module-name))) (define (register-code udefs) - (for-each - (lambda (p) - (let-values ([(ln co) (splat-upair p)]) - (declare-code ln co))) - udefs)) - -(define (add-module-associations links mname) - (for-each - (lambda (link) - (let ([bs (termlink-bytes link)]) - (if (hash-has-key? runtime-module-map bs) - #f - (hash-set! runtime-module-map bs mname)))) - links)) - -(define (need-dependency? l) - (let ([ln (if (unison-data? l) (reference->termlink l) l)]) - (and (unison-termlink-derived? ln) (not (have-code? ln))))) + (for ([(ln co) udefs]) + (declare-code ln co))) + +(define (runtime-code-loaded? link) + (hash-has-key? runtime-module-term-map (termlink-bytes link))) + +(define (add-module-term-associations links mname) + (for ([link links]) + (define bs (termlink-bytes link)) + (unless (hash-has-key? runtime-module-term-map bs) + (hash-set! runtime-module-term-map bs mname)))) + +(define (add-module-type-associations links mname) + (for ([link links]) + (unless (hash-has-key? runtime-module-type-map link) + (hash-set! runtime-module-type-map link mname)))) + +(define ((assoc-raise name l)) + (raise-argument-error name "declared link" l)) + +(define (termlink->module link + [default (assoc-raise + 'termlink->module + (describe-value link))]) + (termbytes->module (termlink-bytes link) default)) + +(define (termbytes->module bs + [default (assoc-raise + 'termbytes->module + (describe-hash bs))]) + (hash-ref runtime-module-term-map bs default)) + +; Resolves the module in which a typelink is declared. Using a +; canonical typelink is important for abilities, because the +; continuation mechanism uses eq? to compare them. This should +; only be a concern for code, though. +(define (typelink->module link + [default (assoc-raise + 'module-type-association + (describe-value link))]) + (hash-ref runtime-module-type-map link default)) + +(define (need-code? l) + (define ln (if (unison-data? l) (reference->termlink l) l)) + (and (unison-termlink-derived? ln) (not (have-code? ln)))) + +(define (need-code-loaded? l) + (define ln (if (unison-data? l) (reference->termlink l) l)) + (and (unison-termlink-derived? ln) (not (runtime-code-loaded? ln)))) + +(define (have-code-loaded? ln) + (and (unison-termlink-derived? ln) (runtime-code-loaded? ln))) + +(define (need-typelink? l) + (let ([ln (if (unison-data? l) (reference->typelink l) l)]) + (not (hash-has-key? runtime-module-type-map ln)))) (define (resolve-builtin nm) - (dynamic-require - 'unison/primops - nm - (lambda () - (dynamic-require - 'unison/simple-wrappers - nm)))) + (dynamic-require 'unison/primops nm)) (define (termlink->proc tl) (match tl [(unison-termlink-derived bs i) - (let ([mname (hash-ref runtime-module-map bs)]) + (let ([mname (hash-ref runtime-module-term-map bs)]) (parameterize ([current-namespace runtime-namespace]) (dynamic-require `(quote ,mname) (termlink->name tl))))] [(unison-termlink-builtin name) @@ -596,7 +826,7 @@ (string->symbol (string-append "builtin-" tx))))] [1 (bs i) (let ([sym (group-ref-sym gr)] - [mname (hash-ref runtime-module-map bs)]) + [mname (termbytes->module bs)]) (parameterize ([current-namespace runtime-namespace]) (dynamic-require `(quote ,mname) sym)))])) @@ -604,29 +834,67 @@ ; This expects to receive a list of termlink, code pairs, and ; generates a scheme module that contains the corresponding ; definitions. -(define (build-intermediate-module primary dfns0) - (let* ([udefs (chunked-list->list dfns0)] - [pname (termlink->name primary)] - [tmlinks (map ufst udefs)] - [codes (map usnd udefs)] - [tylinks (typelink-deps codes)] - [sdefs (flatten (map gen-code udefs))]) - `((require unison/boot - unison/data-info - unison/primops - unison/primops-generated - unison/builtin-generated - unison/simple-wrappers - unison/compound-wrappers) - - ,@(typelink-defns-code tylinks) - - ,@sdefs - - (handle [ref-exception:typelink] top-exn-handler - (,pname #f))))) - -(define (build-runtime-module mname tylinks tmlinks defs) +(define (build-intermediate-module #:profile [profile? #f] primary dfns0) + (define udefs + (for/hash ([p (in-chunked-list dfns0)] + #:when (need-code-loaded? (ufst p))) + (splat-upair p))) + (define-values (tmlinks codes arities) + (for/lists (ts cs as) + ([(tl co) udefs]) + (values tl co (arity-tuple tl co)))) + + (define pname (termlink->name primary)) + (define tylinks (typelink-deps codes)) + + (define-values + (lndefs lndecs codefs codecls dfns) + (gen-codes:intermed (list->chunked-list arities) udefs)) + + `((require unison/boot + unison/data + unison/data-info + unison/primops + unison/primops-generated + unison/builtin-generated + ,@(if profile? '(profile profile/render-text) '())) + + ,@(typelink-defns-code tylinks) + + ; termlink definitions + ,@lndefs + + ; procedure definitions + ,@(flatten dfns) + + ; code definitions + ,@codefs + + ; code declarations + ,@codecls + + ,(if profile? + `(profile + (handle [ref-exception] top-exn-handler (,pname #f)) + #:threads #t + #:periodic-renderer (list 60.0 render)) + `(handle [ref-exception] top-exn-handler (,pname #f))))) + +(define (extra-requires tyrefs tmrefs) + (define tmreqs + (for/list ([l tmrefs] + #:when (unison-termlink-derived? l)) + (termlink->module l))) + + (define tyreqs + (for/list ([l (map reference->typelink tyrefs)] + #:when (unison-typelink-derived? l)) + (typelink->module l #f))) + + (remove #f (remove-duplicates (append tmreqs tyreqs)))) + + +(define (build-runtime-module mname reqs tylinks tmlinks defs) (define (provided-tylink r) (string->symbol (chunked-string->string @@ -640,8 +908,7 @@ unison/primops unison/primops-generated unison/builtin-generated - unison/simple-wrappers - unison/compound-wrappers) + ,@(map (lambda (s) `(quote ,s)) reqs)) (provide ,@tynames @@ -651,78 +918,212 @@ ,@defs)) -(define (add-runtime-module mname tylinks tmlinks defs) - (eval (build-runtime-module mname tylinks tmlinks defs) +(define (add-runtime-module mname reqs tylinks tmlinks defs) + (eval (build-runtime-module mname reqs tylinks tmlinks defs) runtime-namespace)) (define (code-dependencies co) - (chunked-list->list - (group-term-dependencies - (unison-code-rep co)))) - + (map reference->termlink + (chunked-list->list + (group-term-dependencies + (unison-code-rep co))))) + +; Extracts the main arity of a code value. Only the main entry +; is called from other combinators. +(define (code-arity co) (group-arity (unison-code-rep co))) + +; This adds a synchronization barrier around code loading. It uses +; a lock associated with the namespace, so this it will also be safe +; with regard to concurrent instantiations of any modules that get +; defined. +; +; It's possible that this could be made more fine grained. We were +; running into two issues in practice: +; +; 1. It was possible for a module to think it needs to declare +; some combinators that actually occur in modules that are +; depended upon, resulting in duplicate definiton errors. +; +; 2. It was possible for module-n to depend on module-m, but for +; module-n to be defined an instantiated before module-m was +; actually added to the namespace. +; +; This is due to how we keep track of which runtime definitions are +; in which module. There is a separate map storing those associations, +; and they are not inherently synchronized with the module registry. +; Any other synchronization scheme needs to account for these issues. (define (add-runtime-code mname0 dfns0) - (define (map-links dss) - (map (lambda (ds) (map reference->termlink ds)) dss)) + (namespace-call-with-registry-lock runtime-namespace + (lambda () (add-runtime-code-pre mname0 dfns0)))) - (let ([udefs (chunked-list->list dfns0)]) - (cond - [(not (null? udefs)) - (let* ([tmlinks (map ufst udefs)] - [codes (map usnd udefs)] - [refs (map termlink->reference tmlinks)] - [depss (map code-dependencies codes)] - [tylinks (typelink-deps codes)] - [deps (flatten depss)] - [fdeps (filter need-dependency? deps)] - [rdeps (remove* refs fdeps)]) - (cond - [(null? fdeps) empty-chunked-list] - [(null? rdeps) - (let ([ndefs (map gen-code udefs)] - [sdefs (flatten (map gen-code udefs))] - [mname (or mname0 (generate-module-name tmlinks))]) - (expand-sandbox tmlinks (map-links depss)) - (register-code udefs) - (add-module-associations tmlinks mname) - (add-runtime-module mname tylinks tmlinks sdefs) - empty-chunked-list)] - [else - (list->chunked-list - (map reference->termlink rdeps))]))] - [else empty-chunked-list]))) - -(define (unison-POp-CACH dfns0) (add-runtime-code #f dfns0)) - -(define (unison-POp-LOAD v0) - (let* ([val (unison-quote-val v0)] - [deps (value-term-dependencies val)] - [fldeps (chunked-list->list deps)] - [fdeps (filter need-dependency? (chunked-list->list deps))]) - (if (null? fdeps) - (sum 1 (reify-value val)) - (sum 0 - (list->chunked-list - (map reference->termlink fdeps)))))) - -(define (unison-POp-LKUP tl) (lookup-code tl)) - -(define-unison (builtin-Code.lookup tl) +(define (add-runtime-code-pre mname0 dfns0) + ; flatten and filter out unnecessary definitions + (define udefs + (for/hash ([p (in-chunked-list dfns0)] + #:when (need-code-loaded? (ufst p))) + (splat-upair p))) + + (define-values (tmlinks codes) + (for/lists (fsts snds) + ([(fst snd) udefs]) + (values fst snd))) + + (cond + ; short circuit if we have all the definitions loaded + [(null? udefs) empty-chunked-list] + [else + (define deps (flatten (map code-dependencies codes))) + ; classifying dependencies + ; hdeps - dependencies that are already loaded + ; ldeps - dependencies that we have code for, but need loading + ; ndeps - dependencies that we need code for + ; rdeps - ndeps that haven't been provided in dfns0 + (define-values (nldeps hdeps) (partition need-code-loaded? deps)) + (define-values (ndeps ldeps) (partition need-code? nldeps)) + (define rdeps (remove* tmlinks ndeps)) + (cond + [(not (null? rdeps)) + (list->chunked-list rdeps)] + + [else + ; add in definitions that haven't been loaded yet + (define tdefs + (hash-union udefs (resolve-unloaded ldeps) + #:combine (lambda (_ y) y))) + + (add-runtime-code-proc mname0 tdefs)])])) + +; Given a termlink and a list of dependencies for said link, tests +; if the code is recursive. This is done by seeing if it references +; any link with the same bytes. If it does, it must be (mututally) +; recursive. The only way for two definitions to get the same parent +; hash at this point is if they refer to one another. +(define (detect-recursion link deps) + (define self (termlink-bytes link)) + (ormap (lambda (other) + (match other + [(unison-termlink-derived other _) + (equal? self other)] + [else #f])) + deps)) + +(define (arity-tuple tl co) + (unison-tuple + (termlink->reference tl) + (code-arity co))) + +; Creates and adds a module for given module name and definitions. +; +; Passing #f for mname0 makes the procedure make up a fresh name. +; +; udefs should be a map associating termlinks to their code. It is +; assumed that udefs contains all the associations necessary to load +; the code successfully. So, any dependencies of the code in the map +; are either also in the map, or have already been loaded. The +; procedures that call into this one should have checked these already +; and given appropriate errors if we're missing code. +(define (add-runtime-code-proc mname0 udefs) + ; Unpack the map into component lists + (define-values (tmlinks codes arities depss) + (for/lists (ls cs as ds) + ([(tl co) udefs]) + (values + tl + co + (arity-tuple tl co) + (code-dependencies co)))) + + (define tylinks (chunked-list->list (typelink-deps codes))) + (define-values (ntylinks htylinks) (partition need-typelink? tylinks)) + + (define hdeps (filter have-code-loaded? (flatten depss))) + + (define-values (lndefs lndecs dfns) + (gen-codes:runtime (list->chunked-list arities) udefs)) + (define sdefs (append lndefs (append* dfns) lndecs)) + (define reqs (extra-requires htylinks hdeps)) + (define mname (or mname0 (generate-module-name tmlinks))) + + (expand-sandbox tmlinks depss) + (register-code udefs) + (add-module-type-associations + (map reference->typelink ntylinks) + mname) + (add-module-term-associations tmlinks mname) + (add-runtime-module mname reqs (list->chunked-list ntylinks) tmlinks sdefs) + + ; final result: no dependencies needed + empty-chunked-list) + +; Finds (transitively) code for references that we _know_ the code for, +; but which haven't been loaded into the runtime yet. +(define (resolve-unloaded need #:found [found (make-immutable-hash)]) + (match need + ['() found] + [(cons ln need) + #:when (hash-has-key? found ln) + (resolve-unloaded need #:found found)] + [(cons ln need) + (match (lookup-code ln) + [(unison-sum 0 (list)) + (raise-argument-error + 'resolve-unloaded + "have-code?" + ln)] + [(unison-sum 1 (list co)) + (define deps + (filter need-code-loaded? + (code-dependencies co))) + + (resolve-unloaded + (append need deps) + #:found (hash-set found ln co))])] + [else + (raise-argument-error + 'resolve-unloaded + "dependency list" + need)])) + +(define-unison-builtin (builtin-Code.cache_ dfns0) + (add-runtime-code #f dfns0)) + +(define-unison-builtin (builtin-Value.load v0) + (define val (unison-quote-val v0)) + (define deps + (map reference->termlink + (chunked-list->list (value-term-dependencies val)))) + + (namespace-call-with-registry-lock runtime-namespace + (lambda () + + (define-values (ndeps hdeps) (partition need-code? deps)) + + (cond + [(not (null? ndeps)) + (ref-either-left (list->chunked-list ndeps))] + [else + (define ldeps (filter need-code-loaded? hdeps)) + (define to-load (resolve-unloaded ldeps)) + (add-runtime-code-proc #f to-load) + (ref-either-right (reify-value val))])))) + +(define-unison-builtin (builtin-Code.lookup tl) (match (lookup-code tl) [(unison-sum 0 (list)) ref-optional-none] [(unison-sum 1 (list co)) (ref-optional-some co)])) -(define-unison (builtin-validateSandboxed ok v) +(define-unison-builtin (builtin-validateSandboxed ok v) (let ([l (sandbox-scheme-value (chunked-list->list ok) v)]) (null? l))) -(define-unison (builtin-sandboxLinks tl) (check-sandbox tl)) +(define-unison-builtin (builtin-sandboxLinks tl) (check-sandbox tl)) -(define-unison (builtin-Code.isMissing tl) +(define-unison-builtin (builtin-Code.isMissing tl) (cond [(unison-termlink-builtin? tl) #f] [(unison-termlink-con? tl) #f] [(have-code? tl) #t] [else #f])) -(define-unison (builtin-Value.validateSandboxed ok v) +(define-unison-builtin (builtin-Value.validateSandboxed ok v) (sandbox-quoted (chunked-list->list ok) v)) diff --git a/scheme-libs/racket/unison/primops.ss b/scheme-libs/racket/unison/primops.ss index 225b68acdb..671b1e17c3 100644 --- a/scheme-libs/racket/unison/primops.ss +++ b/scheme-libs/racket/unison/primops.ss @@ -1,1519 +1,58 @@ -; This library implements pimitive operations that are used in -; builtins. There are two different sorts of primitive operations, but -; the difference is essentially irrelevant except for naming schemes. -; -; POps are part of a large enumeration of 'instructions' directly -; implemented in the Haskell runtime. These are referred to using the -; naming scheme `unison-POp-INST` where `INST` is the name of the -; instruction, which is (at the time of this writing) 4 letters. -; -; FOps are 'foreign' functons, which are allowed to be declared more -; flexibly in the Haskell runtime. Each such declaration associates a -; builtin to a Haskell function. For these, the naming shceme is -; `unison-FOp-NAME` where `NAME` is the name of the unison builtin -; associated to the declaration. -; -; Both POps and FOps are always called with exactly the right number -; of arguments, so they may be implemented as ordinary scheme -; definitions with a fixed number of arguments. By implementing the -; POp/FOp, you are expecting the associated unison function(s) to be -; implemented by code generation from the wrappers in -; Unison.Runtime.Builtin, so the POp/FOp implementation must -; take/return arguments that match what is expected in those wrappers. - -#!r6rs -(library (unison primops) - (export - builtin-Float.* - builtin-Float.*:termlink - builtin-Float.>= - builtin-Float.>=:termlink - builtin-Float.<= - builtin-Float.<=:termlink - builtin-Float.> - builtin-Float.>:termlink - builtin-Float.< - builtin-Float.<:termlink - builtin-Float.== - builtin-Float.==:termlink - builtin-Float.fromRepresentation - builtin-Float.fromRepresentation:termlink - builtin-Float.toRepresentation - builtin-Float.toRepresentation:termlink - builtin-Float.ceiling - builtin-Float.ceiling:termlink - builtin-Float.exp - builtin-Float.exp:termlink - builtin-Float.log - builtin-Float.log:termlink - builtin-Float.max - builtin-Float.max:termlink - builtin-Float.min - builtin-Float.min:termlink - builtin-Float.tan - builtin-Float.tan:termlink - builtin-Float.tanh - builtin-Float.tanh:termlink - builtin-Float.logBase - builtin-Float.logBase:termlink - builtin-Float.pow - builtin-Float.pow:termlink - builtin-Int.pow - builtin-Int.pow:termlink - builtin-Int.* - builtin-Int.*:termlink - builtin-Int.+ - builtin-Int.+:termlink - builtin-Int.- - builtin-Int.-:termlink - builtin-Int./ - builtin-Int./:termlink - builtin-Int.increment - builtin-Int.increment:termlink - builtin-Int.negate - builtin-Int.negate:termlink - builtin-Int.fromRepresentation - builtin-Int.fromRepresentation:termlink - builtin-Int.toRepresentation - builtin-Int.toRepresentation:termlink - builtin-Int.signum - builtin-Int.signum:termlink - builtin-Int.trailingZeros - builtin-Int.trailingZeros:termlink - builtin-Int.popCount - builtin-Int.popCount:termlink - builtin-Int.isEven - builtin-Int.isEven:termlink - builtin-Int.isOdd - builtin-Int.isOdd:termlink - builtin-Int.== - builtin-Int.==:termlink - builtin-Int.< - builtin-Int.<:termlink - builtin-Int.<= - builtin-Int.<=:termlink - builtin-Int.> - builtin-Int.>:termlink - builtin-Int.>= - builtin-Int.>=:termlink - builtin-Nat.+ - builtin-Nat.+:termlink - builtin-Nat.drop - builtin-Nat.drop:termlink - builtin-Nat.== - builtin-Nat.==:termlink - builtin-Nat.< - builtin-Nat.<:termlink - builtin-Nat.<= - builtin-Nat.<=:termlink - builtin-Nat.> - builtin-Nat.>:termlink - builtin-Nat.>= - builtin-Nat.>=:termlink - builtin-Nat.isEven - builtin-Nat.isEven:termlink - builtin-Nat.isOdd - builtin-Nat.isOdd:termlink - builtin-Nat.increment - builtin-Nat.increment:termlink - builtin-Nat.popCount - builtin-Nat.popCount:termlink - builtin-Nat.toFloat - builtin-Nat.toFloat:termlink - builtin-Nat.trailingZeros - builtin-Nat.trailingZeros:termlink - builtin-Text.indexOf - builtin-Text.indexOf:termlink - builtin-Text.== - builtin-Text.==:termlink - builtin-Text.!= - builtin-Text.!=:termlink - builtin-Text.<= - builtin-Text.<=:termlink - builtin-Text.>= - builtin-Text.>=:termlink - builtin-Text.< - builtin-Text.<:termlink - builtin-Text.> - builtin-Text.>:termlink - builtin-Bytes.indexOf - builtin-Bytes.indexOf:termlink - builtin-IO.randomBytes - builtin-IO.randomBytes:termlink - builtin-IO.tryEval - builtin-IO.tryEval:termlink - - builtin-Scope.bytearrayOf - builtin-Scope.bytearrayOf:termlink - - builtin-Universal.== - builtin-Universal.==:termlink - builtin-Universal.> - builtin-Universal.>:termlink - builtin-Universal.>= - builtin-Universal.>=:termlink - builtin-Universal.< - builtin-Universal.<:termlink - builtin-Universal.<= - builtin-Universal.<=:termlink - builtin-Universal.compare - builtin-Universal.compare:termlink - builtin-Universal.murmurHash:termlink - - builtin-unsafe.coerceAbilities - builtin-unsafe.coerceAbilities:termlink - - builtin-List.splitLeft - builtin-List.splitLeft:termlink - builtin-List.splitRight - builtin-List.splitRight:termlink - - builtin-Link.Term.toText - builtin-Link.Term.toText:termlink - - builtin-Value.toBuiltin - builtin-Value.toBuiltin:termlink - builtin-Value.fromBuiltin - builtin-Value.fromBuiltin:termlink - builtin-Code.fromGroup - builtin-Code.fromGroup:termlink - builtin-Code.toGroup - builtin-Code.toGroup:termlink - builtin-TermLink.fromReferent - builtin-TermLink.fromReferent:termlink - builtin-TermLink.toReferent - builtin-TermLink.toReferent:termlink - builtin-TypeLink.toReference - builtin-TypeLink.toReference:termlink - - builtin-IO.UDP.clientSocket.impl.v1 - builtin-IO.UDP.clientSocket.impl.v1:termlink - builtin-IO.UDP.UDPSocket.recv.impl.v1 - builtin-IO.UDP.UDPSocket.recv.impl.v1:termlink - builtin-IO.UDP.UDPSocket.send.impl.v1 - builtin-IO.UDP.UDPSocket.send.impl.v1:termlink - builtin-IO.UDP.UDPSocket.close.impl.v1 - builtin-IO.UDP.UDPSocket.close.impl.v1:termlink - builtin-IO.UDP.ListenSocket.close.impl.v1 - builtin-IO.UDP.ListenSocket.close.impl.v1:termlink - builtin-IO.UDP.UDPSocket.toText.impl.v1 - builtin-IO.UDP.UDPSocket.toText.impl.v1:termlink - builtin-IO.UDP.serverSocket.impl.v1 - builtin-IO.UDP.serverSocket.impl.v1:termlink - builtin-IO.UDP.ListenSocket.toText.impl.v1 - builtin-IO.UDP.ListenSocket.toText.impl.v1:termlink - builtin-IO.UDP.ListenSocket.recvFrom.impl.v1 - builtin-IO.UDP.ListenSocket.recvFrom.impl.v1:termlink - builtin-IO.UDP.ClientSockAddr.toText.v1 - builtin-IO.UDP.ClientSockAddr.toText.v1:termlink - builtin-IO.UDP.ListenSocket.sendTo.impl.v1 - builtin-IO.UDP.ListenSocket.sendTo.impl.v1:termlink - - unison-FOp-internal.dataTag - unison-FOp-Char.toText - ; unison-FOp-Code.dependencies - ; unison-FOp-Code.serialize - unison-FOp-IO.closeFile.impl.v3 - unison-FOp-IO.openFile.impl.v3 - ; unison-FOp-IO.isFileEOF.impl.v3 - unison-FOp-IO.putBytes.impl.v3 - unison-FOp-IO.getBytes.impl.v3 - builtin-IO.seekHandle.impl.v3 - builtin-IO.seekHandle.impl.v3:termlink - builtin-IO.getLine.impl.v1 - builtin-IO.getLine.impl.v1:termlink - builtin-IO.getSomeBytes.impl.v1 - builtin-IO.getSomeBytes.impl.v1:termlink - builtin-IO.setBuffering.impl.v3 - builtin-IO.setBuffering.impl.v3:termlink - builtin-IO.getBuffering.impl.v3 - builtin-IO.getBuffering.impl.v3:termlink - builtin-IO.setEcho.impl.v1 - builtin-IO.setEcho.impl.v1:termlink - builtin-IO.isFileOpen.impl.v3 - builtin-IO.isFileOpen.impl.v3:termlink - builtin-IO.ready.impl.v1 - builtin-IO.ready.impl.v1:termlink - builtin-IO.process.call - builtin-IO.process.call:termlink - builtin-IO.getEcho.impl.v1 - builtin-IO.getEcho.impl.v1:termlink - builtin-IO.getArgs.impl.v1 - builtin-IO.getArgs.impl.v1:termlink - builtin-IO.getEnv.impl.v1 - builtin-IO.getEnv.impl.v1:termlink - builtin-IO.getChar.impl.v1 - builtin-IO.getChar.impl.v1:termlink - builtin-IO.getCurrentDirectory.impl.v3 - builtin-IO.getCurrentDirectory.impl.v3:termlink - builtin-IO.removeDirectory.impl.v3 - builtin-IO.removeDirectory.impl.v3:termlink - builtin-IO.renameFile.impl.v3 - builtin-IO.renameFile.impl.v3:termlink - builtin-IO.createTempDirectory.impl.v3 - builtin-IO.createTempDirectory.impl.v3:termlink - builtin-IO.createDirectory.impl.v3 - builtin-IO.createDirectory.impl.v3:termlink - builtin-IO.setCurrentDirectory.impl.v3 - builtin-IO.setCurrentDirectory.impl.v3:termlink - builtin-IO.renameDirectory.impl.v3 - builtin-IO.renameDirectory.impl.v3:termlink - builtin-IO.isDirectory.impl.v3 - builtin-IO.isDirectory.impl.v3:termlink - builtin-IO.isSeekable.impl.v3 - builtin-IO.isSeekable.impl.v3:termlink - builtin-IO.handlePosition.impl.v3 - builtin-IO.handlePosition.impl.v3:termlink - builtin-IO.systemTime.impl.v3 - builtin-IO.systemTime.impl.v3:termlink - builtin-IO.systemTimeMicroseconds.impl.v3 - builtin-IO.systemTimeMicroseconds.impl.v3:termlink - - builtin-Char.Class.is - builtin-Char.Class.is:termlink - builtin-Pattern.captureAs - builtin-Pattern.captureAs:termlink - builtin-Pattern.many.corrected - builtin-Pattern.many.corrected:termlink - builtin-Pattern.isMatch - builtin-Pattern.isMatch:termlink - builtin-IO.fileExists.impl.v3 - builtin-IO.fileExists.impl.v3:termlink - builtin-IO.isFileEOF.impl.v3 - builtin-IO.isFileEOF.impl.v3:termlink - - unison-FOp-IO.getFileSize.impl.v3 - unison-FOp-IO.getFileTimestamp.impl.v3 - ; unison-FOp-IO.fileExists.impl.v3 - unison-FOp-IO.removeFile.impl.v3 - unison-FOp-IO.getTempDirectory.impl.v3 - unison-FOp-Text.fromUtf8.impl.v3 - unison-FOp-Text.repeat - unison-FOp-Text.reverse - unison-FOp-Text.toUtf8 - unison-FOp-Text.toLowercase - unison-FOp-Text.toUppercase - unison-FOp-Pattern.run - unison-FOp-Pattern.isMatch - unison-FOp-Pattern.many - unison-FOp-Pattern.capture - unison-FOp-Pattern.join - unison-FOp-Pattern.or - unison-FOp-Pattern.replicate - unison-FOp-Text.patterns.digit - unison-FOp-Text.patterns.letter - unison-FOp-Text.patterns.punctuation - unison-FOp-Text.patterns.charIn - unison-FOp-Text.patterns.notCharIn - unison-FOp-Text.patterns.anyChar - unison-FOp-Text.patterns.space - unison-FOp-Text.patterns.charRange - unison-FOp-Text.patterns.notCharRange - unison-FOp-Text.patterns.literal - unison-FOp-Text.patterns.eof - unison-FOp-Text.patterns.char - unison-FOp-Char.Class.is - unison-FOp-Char.Class.any - unison-FOp-Char.Class.alphanumeric - unison-FOp-Char.Class.upper - unison-FOp-Char.Class.lower - unison-FOp-Char.Class.number - unison-FOp-Char.Class.punctuation - unison-FOp-Char.Class.symbol - unison-FOp-Char.Class.letter - unison-FOp-Char.Class.whitespace - unison-FOp-Char.Class.control - unison-FOp-Char.Class.printable - unison-FOp-Char.Class.mark - unison-FOp-Char.Class.separator - unison-FOp-Char.Class.or - unison-FOp-Char.Class.range - unison-FOp-Char.Class.anyOf - unison-FOp-Char.Class.and - unison-FOp-Char.Class.not - unison-FOp-Clock.internals.nsec.v1 - unison-FOp-Clock.internals.sec.v1 - unison-FOp-Clock.internals.threadCPUTime.v1 - unison-FOp-Clock.internals.processCPUTime.v1 - unison-FOp-Clock.internals.realtime.v1 - unison-FOp-Clock.internals.monotonic.v1 - builtin-Clock.internals.systemTimeZone.v1 - builtin-Clock.internals.systemTimeZone.v1:termlink - - - ; unison-FOp-Value.serialize - unison-FOp-IO.stdHandle - unison-FOp-IO.getArgs.impl.v1 - - builtin-IO.directoryContents.impl.v3 - builtin-IO.directoryContents.impl.v3:termlink - unison-FOp-IO.systemTimeMicroseconds.v1 - - unison-FOp-ImmutableArray.copyTo! - unison-FOp-ImmutableArray.read - - unison-FOp-MutableArray.copyTo! - unison-FOp-MutableArray.freeze! - unison-FOp-MutableArray.freeze - unison-FOp-MutableArray.read - unison-FOp-MutableArray.write - - unison-FOp-MutableArray.size - unison-FOp-ImmutableArray.size - - unison-FOp-MutableByteArray.size - unison-FOp-ImmutableByteArray.size - - unison-FOp-MutableByteArray.length - unison-FOp-ImmutableByteArray.length - - unison-FOp-ImmutableByteArray.copyTo! - unison-FOp-ImmutableByteArray.read8 - unison-FOp-ImmutableByteArray.read16be - unison-FOp-ImmutableByteArray.read24be - unison-FOp-ImmutableByteArray.read32be - unison-FOp-ImmutableByteArray.read40be - unison-FOp-ImmutableByteArray.read48be - unison-FOp-ImmutableByteArray.read56be - unison-FOp-ImmutableByteArray.read64be - - unison-FOp-MutableByteArray.copyTo! - unison-FOp-MutableByteArray.freeze! - unison-FOp-MutableByteArray.write8 - unison-FOp-MutableByteArray.write16be - unison-FOp-MutableByteArray.write32be - unison-FOp-MutableByteArray.write64be - unison-FOp-MutableByteArray.read8 - unison-FOp-MutableByteArray.read16be - unison-FOp-MutableByteArray.read24be - unison-FOp-MutableByteArray.read32be - unison-FOp-MutableByteArray.read40be - unison-FOp-MutableByteArray.read64be - - unison-FOp-Scope.bytearray - unison-FOp-Scope.bytearrayOf - unison-FOp-Scope.array - unison-FOp-Scope.arrayOf - unison-FOp-Scope.ref - - unison-FOp-IO.bytearray - unison-FOp-IO.bytearrayOf - unison-FOp-IO.array - unison-FOp-IO.arrayOf - - unison-FOp-IO.ref - unison-FOp-Ref.read - unison-FOp-Ref.write - unison-FOp-Ref.readForCas - unison-FOp-Ref.Ticket.read - unison-FOp-Ref.cas - - unison-FOp-Promise.new - unison-FOp-Promise.read - unison-FOp-Promise.tryRead - unison-FOp-Promise.write - - unison-FOp-IO.delay.impl.v3 - unison-POp-FORK - unison-FOp-IO.kill.impl.v3 - - unison-FOp-Handle.toText - unison-FOp-Socket.toText - unison-FOp-ThreadId.toText - - unison-POp-ABSF - unison-POp-ACOS - unison-POp-ACSH - unison-POp-ADDF - unison-POp-ASIN - unison-POp-ASNH - unison-POp-ATAN - unison-POp-ATN2 - unison-POp-ATNH - unison-POp-CEIL - unison-POp-FLOR - unison-POp-COSF - unison-POp-COSH - unison-POp-DIVF - unison-POp-DIVI - unison-POp-EQLF - unison-POp-EQLI - unison-POp-SUBF - unison-POp-SUBI - unison-POp-SGNI - unison-POp-LEQF - unison-POp-SINF - unison-POp-SINH - unison-POp-TRNF - unison-POp-RNDF - unison-POp-SQRT - unison-POp-TANH - unison-POp-TANF - unison-POp-TZRO - unison-POp-POPC - unison-POp-ITOF - - unison-POp-ADDN - unison-POp-ANDN - unison-POp-BLDS - unison-POp-CATS - unison-POp-CATT - unison-POp-CATB - unison-POp-CMPU - unison-POp-COMN - unison-POp-CONS - unison-POp-DBTX - unison-POp-DECI - unison-POp-INCI - unison-POp-DECN - unison-POp-INCN - unison-POp-DIVN - unison-POp-DRPB - unison-POp-DRPS - unison-POp-DRPT - unison-POp-EQLN - unison-POp-EQLT - unison-POp-EXPF - unison-POp-LEQT - unison-POp-EQLU - unison-POp-EROR - unison-POp-FTOT - unison-POp-IDXB - unison-POp-IDXS - unison-POp-IORN - unison-POp-ITOT - unison-POp-LEQN - ; unison-POp-LKUP - unison-POp-LZRO - unison-POp-MULN - unison-POp-MODN - unison-POp-NTOT - unison-POp-PAKT - unison-POp-SHLI - unison-POp-SHLN - unison-POp-SHRI - unison-POp-SHRN - unison-POp-SIZS - unison-POp-SIZT - unison-POp-SIZB - unison-POp-SNOC - unison-POp-SUBN - unison-POp-SUBI - unison-POp-TAKS - unison-POp-TAKT - unison-POp-TAKB - unison-POp-TRCE - unison-POp-PRNT - unison-POp-TTON - unison-POp-TTOI - unison-POp-TTOF - unison-POp-UPKT - unison-POp-XORN - unison-POp-VALU - unison-POp-VWLS - unison-POp-UCNS - unison-POp-USNC - unison-POp-FLTB - unison-POp-MAXF - unison-POp-MINF - unison-POp-MULF - unison-POp-MULI - unison-POp-NEGI - unison-POp-NTOF - unison-POp-POWF - unison-POp-POWI - unison-POp-POWN - - unison-POp-UPKB - unison-POp-PAKB - unison-POp-ADDI - unison-POp-MULI - unison-POp-MODI - unison-POp-LEQI - unison-POp-LOGB - unison-POp-LOGF - unison-POp-POWN - unison-POp-VWRS - unison-POp-SPLL - unison-POp-SPLR - - unison-FOp-Bytes.gzip.compress - unison-FOp-Bytes.gzip.decompress - unison-FOp-Bytes.zlib.compress - unison-FOp-Bytes.zlib.decompress - unison-FOp-Bytes.toBase16 - unison-FOp-Bytes.toBase32 - unison-FOp-Bytes.toBase64 - unison-FOp-Bytes.toBase64UrlUnpadded - unison-FOp-Bytes.fromBase16 - unison-FOp-Bytes.fromBase32 - unison-FOp-Bytes.fromBase64 - unison-FOp-Bytes.fromBase64UrlUnpadded - unison-FOp-Bytes.encodeNat16be - unison-FOp-Bytes.encodeNat16le - unison-FOp-Bytes.encodeNat32be - unison-FOp-Bytes.encodeNat32le - unison-FOp-Bytes.encodeNat64be - unison-FOp-Bytes.encodeNat64le - unison-FOp-Bytes.decodeNat16be - unison-FOp-Bytes.decodeNat16le - unison-FOp-Bytes.decodeNat32be - unison-FOp-Bytes.decodeNat32le - unison-FOp-Bytes.decodeNat64be - unison-FOp-Bytes.decodeNat64le - - unison-FOp-crypto.hashBytes - unison-FOp-crypto.hmacBytes - unison-FOp-crypto.HashAlgorithm.Md5 - unison-FOp-crypto.HashAlgorithm.Sha1 - unison-FOp-crypto.HashAlgorithm.Sha2_256 - unison-FOp-crypto.HashAlgorithm.Sha2_512 - unison-FOp-crypto.HashAlgorithm.Sha3_256 - unison-FOp-crypto.HashAlgorithm.Sha3_512 - unison-FOp-crypto.HashAlgorithm.Blake2s_256 - unison-FOp-crypto.HashAlgorithm.Blake2b_256 - unison-FOp-crypto.HashAlgorithm.Blake2b_512 - - unison-FOp-IO.clientSocket.impl.v3 - unison-FOp-IO.closeSocket.impl.v3 - unison-FOp-IO.socketReceive.impl.v3 - unison-FOp-IO.socketSend.impl.v3 - unison-FOp-IO.socketPort.impl.v3 - unison-FOp-IO.serverSocket.impl.v3 - unison-FOp-IO.socketAccept.impl.v3 - unison-FOp-IO.listen.impl.v3 - unison-FOp-Tls.ClientConfig.default - unison-FOp-Tls.ClientConfig.certificates.set - unison-FOp-Tls.decodeCert.impl.v3 - unison-FOp-Tls.encodeCert - unison-FOp-Tls.newServer.impl.v3 - unison-FOp-Tls.decodePrivateKey - unison-FOp-Tls.encodePrivateKey - unison-FOp-Tls.ServerConfig.default - unison-FOp-Tls.handshake.impl.v3 - unison-FOp-Tls.newClient.impl.v3 - unison-FOp-Tls.receive.impl.v3 - unison-FOp-Tls.send.impl.v3 - unison-FOp-Tls.terminate.impl.v3 - - ; fake builtins - builtin-murmurHashBytes) - - (import (rnrs) - (only (srfi :13) string-reverse) - (racket performance-hint) - (only (racket flonum) - fl< - fl> - fl<= - fl>= - fl=) - (rename - (only (racket) - car - cdr - exact-integer? - exact-nonnegative-integer? - foldl - integer-length - bytes->string/utf-8 - string->bytes/utf-8 - exn:fail:contract? - file-stream-buffer-mode - with-handlers - match - modulo - quotient - regexp-match-positions - sequence-ref - vector-copy! - bytes-copy! - sub1 - add1 - exn:break? - exn:fail? - exn:fail:read? - exn:fail:filesystem? - exn:fail:network? - exn:fail:contract:divide-by-zero? - exn:fail:contract:non-fixnum-result?) - (car icar) (cdr icdr)) - (only (racket string) - string-contains? - string-replace) - (unison arithmetic) - (unison bytevector) - (unison core) - (only (unison boot) - define-unison - referent->termlink - termlink->referent - typelink->reference - clamp-integer - clamp-natural - wrap-natural - exn:bug->exception - raise-unison-exception - bit64 - bit63 - nbit63) - (unison data) - (unison data-info) - (unison math) - (unison chunked-seq) - (unison chunked-bytes) - (unison string-search) - (unison bytes-nat) - (unison pattern) - (unison crypto) - (unison io) - (unison io-handles) - (unison murmurhash) - (unison tls) - (unison tcp) - (unison udp) - (unison gzip) - (unison zlib) - (unison concurrent) - (racket random)) - - (define-builtin-link Float.*) - (define-builtin-link Float.fromRepresentation) - (define-builtin-link Float.toRepresentation) - (define-builtin-link Float.ceiling) - (define-builtin-link Float.exp) - (define-builtin-link Float.log) - (define-builtin-link Float.max) - (define-builtin-link Float.min) - (define-builtin-link Float.tan) - (define-builtin-link Float.tanh) - (define-builtin-link Float.logBase) - (define-builtin-link Float.pow) - (define-builtin-link Float.>) - (define-builtin-link Float.<) - (define-builtin-link Float.>=) - (define-builtin-link Float.<=) - (define-builtin-link Float.==) - (define-builtin-link Int.pow) - (define-builtin-link Int.*) - (define-builtin-link Int.+) - (define-builtin-link Int.-) - (define-builtin-link Int./) - (define-builtin-link Int.>) - (define-builtin-link Int.<) - (define-builtin-link Int.>=) - (define-builtin-link Int.<=) - (define-builtin-link Int.==) - (define-builtin-link Int.isEven) - (define-builtin-link Int.isOdd) - (define-builtin-link Int.increment) - (define-builtin-link Int.negate) - (define-builtin-link Int.fromRepresentation) - (define-builtin-link Int.toRepresentation) - (define-builtin-link Int.signum) - (define-builtin-link Int.trailingZeros) - (define-builtin-link Int.popCount) - (define-builtin-link Nat.increment) - (define-builtin-link Nat.popCount) - (define-builtin-link Nat.toFloat) - (define-builtin-link Nat.trailingZeros) - (define-builtin-link Nat.+) - (define-builtin-link Nat.>) - (define-builtin-link Nat.<) - (define-builtin-link Nat.>=) - (define-builtin-link Nat.<=) - (define-builtin-link Nat.==) - (define-builtin-link Nat.drop) - (define-builtin-link Nat.isEven) - (define-builtin-link Nat.isOdd) - (define-builtin-link Text.indexOf) - (define-builtin-link Text.>) - (define-builtin-link Text.<) - (define-builtin-link Text.>=) - (define-builtin-link Text.<=) - (define-builtin-link Text.==) - (define-builtin-link Text.!=) - (define-builtin-link Bytes.indexOf) - (define-builtin-link IO.randomBytes) - (define-builtin-link IO.tryEval) - (define-builtin-link List.splitLeft) - (define-builtin-link List.splitRight) - (define-builtin-link Value.toBuiltin) - (define-builtin-link Value.fromBuiltin) - (define-builtin-link Code.fromGroup) - (define-builtin-link Code.toGroup) - (define-builtin-link TermLink.fromReferent) - (define-builtin-link TermLink.toReferent) - (define-builtin-link TypeLink.toReference) - (define-builtin-link IO.seekHandle.impl.v3) - (define-builtin-link IO.getLine.impl.v1) - (define-builtin-link IO.getSomeBytes.impl.v1) - (define-builtin-link IO.setBuffering.impl.v3) - (define-builtin-link IO.getBuffering.impl.v3) - (define-builtin-link IO.setEcho.impl.v1) - (define-builtin-link IO.isFileOpen.impl.v3) - (define-builtin-link IO.ready.impl.v1) - (define-builtin-link IO.process.call) - (define-builtin-link IO.getEcho.impl.v1) - (define-builtin-link IO.getArgs.impl.v1) - (define-builtin-link IO.getEnv.impl.v1) - (define-builtin-link IO.getChar.impl.v1) - (define-builtin-link IO.getCurrentDirectory.impl.v3) - (define-builtin-link IO.directoryContents.impl.v3) - (define-builtin-link IO.removeDirectory.impl.v3) - (define-builtin-link IO.renameFile.impl.v3) - (define-builtin-link IO.createTempDirectory.impl.v3) - (define-builtin-link IO.createDirectory.impl.v3) - (define-builtin-link IO.setCurrentDirectory.impl.v3) - (define-builtin-link IO.renameDirectory.impl.v3) - (define-builtin-link IO.fileExists.impl.v3) - (define-builtin-link IO.isDirectory.impl.v3) - (define-builtin-link IO.isFileEOF.impl.v3) - (define-builtin-link IO.isSeekable.impl.v3) - (define-builtin-link IO.handlePosition.impl.v3) - (define-builtin-link IO.systemTime.impl.v3) - (define-builtin-link IO.systemTimeMicroseconds.impl.v3) - (define-builtin-link Universal.==) - (define-builtin-link Universal.>) - (define-builtin-link Universal.<) - (define-builtin-link Universal.>=) - (define-builtin-link Universal.<=) - (define-builtin-link Universal.compare) - (define-builtin-link Universal.murmurHash) - (define-builtin-link Pattern.captureAs) - (define-builtin-link Pattern.many.corrected) - (define-builtin-link Pattern.isMatch) - (define-builtin-link Char.Class.is) - (define-builtin-link Scope.bytearrayOf) - (define-builtin-link unsafe.coerceAbilities) - (define-builtin-link Clock.internals.systemTimeZone.v1) - - (begin-encourage-inline - (define-unison (builtin-Value.toBuiltin v) (unison-quote v)) - (define-unison (builtin-Value.fromBuiltin v) - (unison-quote-val v)) - (define-unison (builtin-Code.fromGroup sg) (unison-code sg)) - (define-unison (builtin-Code.toGroup co) - (unison-code-rep co)) - (define-unison (builtin-TermLink.fromReferent rf) - (referent->termlink rf)) - (define-unison (builtin-TermLink.toReferent tl) - (termlink->referent tl)) - (define-unison (builtin-TypeLink.toReference tl) - (typelink->reference tl)) - (define-unison (builtin-murmurHashBytes bs) - (murmurhash-bytes (chunked-bytes->bytes bs))) - - (define-unison (builtin-IO.randomBytes n) - (bytes->chunked-bytes (crypto-random-bytes n))) - - (define-unison (builtin-List.splitLeft n s) - (match (unison-POp-SPLL n s) - [(unison-sum 0 fs) ref-seqview-empty] - [(unison-sum 1 (list l r)) (ref-seqview-elem l r)])) - - (define-unison (builtin-List.splitRight n s) - (match (unison-POp-SPLR n s) - [(unison-sum 0 fs) ref-seqview-empty] - [(unison-sum 1 (list l r)) (ref-seqview-elem l r)])) - - (define-unison (builtin-Float.> x y) (fl> x y)) - (define-unison (builtin-Float.< x y) (fl< x y)) - (define-unison (builtin-Float.>= x y) (fl>= x y)) - (define-unison (builtin-Float.<= x y) (fl<= x y)) - (define-unison (builtin-Float.== x y) (fl= x y)) - - (define-unison (builtin-Int.> x y) (> x y)) - (define-unison (builtin-Int.< x y) (< x y)) - (define-unison (builtin-Int.>= x y) (>= x y)) - (define-unison (builtin-Int.<= x y) (<= x y)) - (define-unison (builtin-Int.== x y) (= x y)) - (define-unison (builtin-Int.isEven x) (even? x)) - (define-unison (builtin-Int.isOdd x) (odd? x)) - - (define-unison (builtin-Nat.> x y) (> x y)) - (define-unison (builtin-Nat.< x y) (< x y)) - (define-unison (builtin-Nat.>= x y) (>= x y)) - (define-unison (builtin-Nat.<= x y) (<= x y)) - (begin-encourage-inline - (define-unison (builtin-Nat.== x y) (= x y))) - - (define-unison (builtin-Nat.isEven x) (even? x)) - (define-unison (builtin-Nat.isOdd x) (odd? x)) - - ; Note: chunked-string x y) - (not (chunked-string= x y) (chunked-string x y) - (case (universal-compare x y) [(>) #t] [else #f])) - (define-unison (builtin-Universal.< x y) - (case (universal-compare x y) [(<) #t] [else #f])) - (define-unison (builtin-Universal.<= x y) - (case (universal-compare x y) [(>) #f] [else #t])) - (define-unison (builtin-Universal.>= x y) - (case (universal-compare x y) [(<) #f] [else #t])) - (define-unison (builtin-Universal.compare x y) - (case (universal-compare x y) - [(>) 1] [(<) -1] [else 0])) - - (define-unison (builtin-Scope.bytearrayOf i n) - (make-bytevector n i)) - - (define-builtin-link Link.Type.toText) - (define-unison (builtin-Link.Type.toText ln) - (string->chunked-string (typelink->string ln))) - - (define-builtin-link Link.Term.toText) - (define-unison (builtin-Link.Term.toText ln) - (string->chunked-string (termlink->string ln))) - - (define-unison (builtin-Char.Class.is cc c) - (pattern-match? cc (string->chunked-string (string c)))) - - (define-unison (builtin-Pattern.captureAs c p) - (capture-as c p)) - - (define-unison (builtin-Pattern.many.corrected p) (many p)) - - (define-unison (builtin-Pattern.isMatch p s) - (pattern-match? p s)) - - (define-unison (builtin-unsafe.coerceAbilities f) f) - - (define (unison-POp-UPKB bs) - (build-chunked-list - (chunked-bytes-length bs) - (lambda (i) (chunked-bytes-ref bs i)))) - - (define (unison-POp-ADDI i j) (clamp-integer (+ i j))) - (define (unison-POp-MULI i j) (clamp-integer (* i j))) - (define (unison-POp-MODI i j) (clamp-integer (modulo i j))) - (define (unison-POp-LEQI a b) (bool (<= a b))) - (define (unison-POp-POWN m n) (clamp-natural (expt m n))) - (define unison-POp-LOGF log) - - (define (reify-exn thunk) - (guard - (e [else - (sum 0 '() (exception->string e) ref-unit-unit)]) - (thunk))) - - ; Core implemented primops, upon which primops-in-unison can be built. - (define (unison-POp-ADDN m n) (clamp-natural (+ m n))) - (define (unison-POp-ANDN m n) (bitwise-and m n)) - (define unison-POp-BLDS - (lambda args-list - (fold-right (lambda (e l) (chunked-list-add-first l e)) empty-chunked-list args-list))) - (define (unison-POp-CATS l r) (chunked-list-append l r)) - (define (unison-POp-CATT l r) (chunked-string-append l r)) - (define (unison-POp-CATB l r) (chunked-bytes-append l r)) - (define (unison-POp-CMPU l r) (ord (universal-compare l r))) - (define (unison-POp-COMN n) (wrap-natural (bitwise-not n))) - (define (unison-POp-CONS x xs) (chunked-list-add-first xs x)) - (define (unison-POp-DECI n) (clamp-integer (sub1 n))) - (define (unison-POp-INCI n) (clamp-integer (add1 n))) - (define (unison-POp-DECN n) (wrap-natural (sub1 n))) - (define (unison-POp-INCN n) (clamp-natural (add1 n))) - (define (unison-POp-DIVN m n) (quotient m n)) - (define (unison-POp-DRPB n bs) (chunked-bytes-drop bs n)) - (define (unison-POp-DRPS n l) (chunked-list-drop l n)) - (define (unison-POp-DRPT n t) (chunked-string-drop t n)) - (define (unison-POp-EQLN m n) (bool (= m n))) - (define (unison-POp-EQLT s t) (bool (equal? s t))) - (define (unison-POp-LEQT s t) (bool (chunked-stringstring fnm)]) - (put-string p snm) - (put-string p ": ") - (display (describe-value x) p) - (raise (make-exn:bug snm x)))) - (define (unison-POp-FTOT f) - (define base (number->string f)) - (define dotted - (if (string-contains? base ".") - base - (string-replace base "e" ".0e"))) - (string->chunked-string - (string-replace dotted "+" ""))) - (define (unison-POp-IDXB n bs) - (guard (x [else none]) - (some (chunked-bytes-ref bs n)))) - (define (unison-POp-IDXS n l) - (guard (x [else none]) - (some (chunked-list-ref l n)))) - (define (unison-POp-IORN m n) (bitwise-ior m n)) - (define (unison-POp-ITOT n) - (string->chunked-string (number->string n))) - (define (unison-POp-LEQN m n) (bool (fx<=? m n))) - (define (unison-POp-LZRO m) (- 64 (integer-length m))) - (define (unison-POp-MULN m n) (clamp-natural (* m n))) - (define (unison-POp-MODN m n) (modulo m n)) - (define (unison-POp-NTOT n) (string->chunked-string (number->string n))) - (define (unison-POp-PAKB l) - (build-chunked-bytes - (chunked-list-length l) - (lambda (i) (chunked-list-ref l i)))) - (define (unison-POp-PAKT l) - (build-chunked-string - (chunked-list-length l) - (lambda (i) (chunked-list-ref l i)))) - (define (unison-POp-SHLI i k) - (clamp-integer (bitwise-arithmetic-shift-left i k))) - (define (unison-POp-SHLN n k) - (clamp-natural (bitwise-arithmetic-shift-left n k))) - (define (unison-POp-SHRI i k) (bitwise-arithmetic-shift-right i k)) - (define (unison-POp-SHRN n k) (bitwise-arithmetic-shift-right n k)) - (define (unison-POp-SIZS l) (chunked-list-length l)) - (define (unison-POp-SIZT t) (chunked-string-length t)) - (define (unison-POp-SIZB b) (chunked-bytes-length b)) - (define (unison-POp-SNOC xs x) (chunked-list-add-last xs x)) - (define (unison-POp-SUBN m n) (clamp-integer (- m n))) - (define (unison-POp-SUBI m n) (clamp-integer (- m n))) - (define (unison-POp-TAKS n s) (chunked-list-take s n)) - (define (unison-POp-TAKT n t) (chunked-string-take t n)) - (define (unison-POp-TAKB n t) (chunked-bytes-take t n)) - - (define (->optional v) - (if v - (ref-optional-some v) - ref-optional-none)) - - (define-unison (builtin-Text.indexOf n h) - (->optional (chunked-string-index-of h n))) - (define-unison (builtin-Bytes.indexOf n h) - (->optional (chunked-bytes-index-of h n))) - - ;; TODO currently only runs in low-level tracing support - (define (unison-POp-DBTX x) - (sum 1 (string->chunked-string (describe-value x)))) - - (define (unison-FOp-Handle.toText h) - (string->chunked-string (describe-value h))) - (define (unison-FOp-Socket.toText s) - (string->chunked-string (describe-value s))) - (define (unison-FOp-ThreadId.toText tid) - (string->chunked-string (describe-value tid))) - - (define (unison-POp-TRCE s x) - (display "trace: ") - (display (chunked-string->string s)) - (newline) - (display (describe-value x)) - (newline)) - (define (unison-POp-PRNT s) - (display (chunked-string->string s)) - (newline)) - (define (unison-POp-TTON s) - (let ([mn (string->number (chunked-string->string s))]) - (if (and (exact-nonnegative-integer? mn) (< mn bit64)) - (some mn) - none))) - (define (unison-POp-TTOI s) - (let ([mn (string->number (chunked-string->string s))]) - (if (and (exact-integer? mn) (>= mn nbit63) (< mn bit63)) - (some mn) - none))) - (define (unison-POp-TTOF s) - (let ([mn (string->number (chunked-string->string s))]) - (if mn (some mn) none))) - (define (unison-POp-UPKT s) - (build-chunked-list - (chunked-string-length s) - (lambda (i) (chunked-string-ref s i)))) - (define (unison-POp-VWLS l) - (if (chunked-list-empty? l) - (sum 0) - (let-values ([(t h) (chunked-list-pop-first l)]) - (sum 1 h t)))) - (define (unison-POp-VWRS l) - (if (chunked-list-empty? l) - (sum 0) - (let-values ([(t h) (chunked-list-pop-last l)]) - (sum 1 t h)))) - (define (unison-POp-SPLL i s) - (if (< (chunked-list-length s) i) - (sum 0) - (let-values ([(l r) (chunked-list-split-at s i)]) - (sum 1 l r)))) - (define (unison-POp-SPLR i s) ; TODO write test that stresses this - (let ([len (chunked-list-length s) ]) - (if (< len i) - (sum 0) - (let-values ([(l r) (chunked-list-split-at s (- len i))]) - (sum 1 l r))))) - - (define (unison-POp-UCNS s) - (if (chunked-string-empty? s) - (sum 0) - (let-values ([(t h) (chunked-string-pop-first s)]) - (sum 1 (char h) t)))) - - (define (unison-POp-USNC s) - (if (chunked-string-empty? s) - (sum 0) - (let-values ([(t h) (chunked-string-pop-last s)]) - (sum 1 t (char h))))) - - ;; TODO flatten operation on Bytes is a no-op for now (and possibly ever) - (define (unison-POp-FLTB b) b) - - (define (unison-POp-XORN m n) (bitwise-xor m n)) - (define (unison-POp-VALU c) (decode-value c)) - - (define (unison-FOp-ImmutableByteArray.read16be bs n) - (reify-exn - (lambda () - (sum 1 (bytevector-u16-ref bs n 'big))))) - - (define (unison-FOp-ImmutableByteArray.read24be bs n) - (reify-exn - (lambda () - (sum 1 (bytevector-u24-ref bs n 'big))))) - - (define (unison-FOp-ImmutableByteArray.read32be bs n) - (reify-exn - (lambda () - (sum 1 (bytevector-u32-ref bs n 'big))))) - - (define (unison-FOp-ImmutableByteArray.read40be bs n) - (reify-exn - (lambda () - (sum 1 (bytevector-u40-ref bs n 'big))))) - - (define (unison-FOp-ImmutableByteArray.read48be bs n) - (reify-exn - (lambda () - (sum 1 (bytevector-u48-ref bs n 'big))))) - - (define (unison-FOp-ImmutableByteArray.read56be bs n) - (reify-exn - (lambda () - (sum 1 (bytevector-u56-ref bs n 'big))))) - - (define (unison-FOp-ImmutableByteArray.read64be bs n) - (reify-exn - (lambda () - (sum 1 (bytevector-u64-ref bs n 'big))))) - - (define unison-FOp-internal.dataTag unison-data-tag) - - (define (unison-FOp-IO.getBytes.impl.v3 p n) - (reify-exn - (lambda () - (right - (bytes->chunked-bytes - (get-bytevector-n p n)))))) - - (define (unison-FOp-IO.putBytes.impl.v3 p bs) - (begin - (put-bytevector p (chunked-bytes->bytes bs)) - (flush-output-port p) - (sum 1 #f))) - - (define (unison-FOp-Char.toText c) (string->chunked-string (string (integer->char c)))) - - (define (unison-FOp-IO.getArgs.impl.v1) - (sum 1 (cdr (command-line)))) - - (define unison-FOp-IO.systemTimeMicroseconds.v1 current-microseconds) - - ;; TODO should we convert Bytes -> Text directly without the intermediate conversions? - (define (unison-FOp-Text.fromUtf8.impl.v3 b) - (with-handlers - ([exn:fail:contract? - (lambda (e) - (exception - ref-iofailure:typelink - (string->chunked-string - (string-append - "Invalid UTF-8 stream: " - (describe-value b))) - (exception->string e)))]) - (right (string->chunked-string (bytes->string/utf-8 (chunked-bytes->bytes b)))))) - - ;; TODO should we convert Text -> Bytes directly without the intermediate conversions? - (define (unison-FOp-Text.toUtf8 s) - (bytes->chunked-bytes (string->bytes/utf-8 (chunked-string->string s)))) - - (define-unison (builtin-IO.isFileEOF.impl.v3 p) - (ref-either-right (port-eof? p))) - - (define (unison-FOp-IO.closeFile.impl.v3 h) - (if (input-port? h) - (close-input-port h) - (close-output-port h)) - (right none)) - - (define (unison-FOp-Text.repeat n t) - (let loop ([cnt 0] - [acc empty-chunked-string]) - (if (= cnt n) - acc - (loop (+ cnt 1) (chunked-string-append acc t))))) - - (define (unison-FOp-Text.reverse s) - (chunked-string-foldMap-chunks - s - string-reverse - (lambda (acc c) (chunked-string-append c acc)))) - - (define (unison-FOp-Text.toLowercase s) - (chunked-string-foldMap-chunks s string-downcase chunked-string-append)) - - (define (unison-FOp-Text.toUppercase s) - (chunked-string-foldMap-chunks s string-upcase chunked-string-append)) - - (define (unison-FOp-Pattern.run p s) - (let* ([r (pattern-match p s)]) - (if r (sum 1 (icdr r) (icar r)) (sum 0)))) - - (define (unison-FOp-Pattern.isMatch p s) (bool (pattern-match? p s))) - (define (unison-FOp-Pattern.many p) (many p)) - (define (unison-FOp-Pattern.capture p) (capture p)) - (define (unison-FOp-Pattern.join ps) - (join* ps)) - (define (unison-FOp-Pattern.or p1 p2) (choice p1 p2)) - (define (unison-FOp-Pattern.replicate n m p) (replicate p n m)) - - (define (unison-FOp-Text.patterns.digit) digit) - (define (unison-FOp-Text.patterns.letter) letter) - (define (unison-FOp-Text.patterns.punctuation) punctuation) - (define (unison-FOp-Text.patterns.charIn cs) (chars cs)) - (define (unison-FOp-Text.patterns.notCharIn cs) (not-chars cs)) - (define (unison-FOp-Text.patterns.anyChar) any-char) - (define (unison-FOp-Text.patterns.space) space) - (define (unison-FOp-Text.patterns.charRange a z) (char-range (integer->char a) (integer->char z))) - (define (unison-FOp-Text.patterns.notCharRange a z) (not-char-range (integer->char a) (integer->char z))) - (define (unison-FOp-Text.patterns.literal s) (literal s)) - (define (unison-FOp-Text.patterns.eof) eof) - (define (unison-FOp-Text.patterns.char cc) cc) - (define (unison-FOp-Char.Class.is cc c) - (unison-FOp-Pattern.isMatch cc (unison-FOp-Char.toText c))) - (define (unison-FOp-Char.Class.any) (unison-FOp-Text.patterns.anyChar)) - (define (unison-FOp-Char.Class.punctuation) - (unison-FOp-Text.patterns.punctuation)) - (define (unison-FOp-Char.Class.letter) (unison-FOp-Text.patterns.letter)) - (define (unison-FOp-Char.Class.alphanumeric) alphanumeric) - (define (unison-FOp-Char.Class.upper) upper) - (define (unison-FOp-Char.Class.lower) lower) - (define (unison-FOp-Char.Class.number) number) - (define (unison-FOp-Char.Class.symbol) symbol) - (define (unison-FOp-Char.Class.whitespace) space) - (define (unison-FOp-Char.Class.control) control) - (define (unison-FOp-Char.Class.printable) printable) - (define (unison-FOp-Char.Class.mark) mark) - (define (unison-FOp-Char.Class.separator) separator) - (define (unison-FOp-Char.Class.or p1 p2) (char-class-or p1 p2)) - (define (unison-FOp-Char.Class.range a z) - (unison-FOp-Text.patterns.charRange a z)) - (define (unison-FOp-Char.Class.anyOf cs) (unison-FOp-Text.patterns.charIn cs)) - (define (unison-FOp-Char.Class.and cc1 cc2) (char-class-and cc1 cc2)) - (define (unison-FOp-Char.Class.not cc) (char-class-not cc)) - - (define (catch-array thunk) - (reify-exn thunk)) - - (define (unison-FOp-ImmutableArray.read vec i) - (catch-array - (lambda () - (sum 1 (vector-ref vec i))))) - - (define (unison-FOp-ImmutableArray.copyTo! dst doff src soff n) - (catch-array - (lambda () - (vector-copy! dst doff src soff n) - (sum 1)))) - - (define (unison-FOp-MutableArray.copyTo! dst doff src soff l) - (catch-array - (lambda () - (vector-copy! dst doff src soff l) - (sum 1)))) - - (define unison-FOp-MutableArray.freeze! freeze-vector!) - - (define unison-FOp-MutableArray.freeze freeze-subvector) - - (define (unison-FOp-MutableArray.read src i) - (catch-array - (lambda () - (sum 1 (vector-ref src i))))) - - (define (unison-FOp-MutableArray.write dst i x) - (catch-array - (lambda () - (vector-set! dst i x) - (sum 1)))) - - (define (unison-FOp-ImmutableByteArray.copyTo! dst doff src soff n) - (catch-array - (lambda () - (bytes-copy! dst doff src soff n) - (sum 1)))) - - (define (unison-FOp-ImmutableByteArray.read8 arr i) - (catch-array - (lambda () - (sum 1 (bytevector-u8-ref arr i))))) - - (define (unison-FOp-MutableByteArray.copyTo! dst doff src soff l) - (catch-array - (lambda () - (bytes-copy! dst doff src soff l) - (sum 1)))) - - (define unison-FOp-MutableByteArray.freeze! freeze-bytevector!) - - (define (unison-FOp-MutableByteArray.write8 arr i b) - (catch-array - (lambda () - (bytevector-u8-set! arr i b) - (sum 1)))) - - (define (unison-FOp-MutableByteArray.write16be arr i b) - (catch-array - (lambda () - (bytevector-u16-set! arr i b 'big) - (sum 1)))) - - (define (unison-FOp-MutableByteArray.write32be arr i b) - (catch-array - (lambda () - (bytevector-u32-set! arr i b 'big) - (sum 1)))) - - (define (unison-FOp-MutableByteArray.write64be arr i b) - (catch-array - (lambda () - (bytevector-u64-set! arr i b 'big) - (sum 1)))) - - (define (unison-FOp-MutableByteArray.read8 arr i) - (catch-array - (lambda () - (sum 1 (bytevector-u8-ref arr i))))) - - (define (unison-FOp-MutableByteArray.read16be arr i) - (catch-array - (lambda () - (sum 1 (bytevector-u16-ref arr i 'big))))) - - (define (unison-FOp-MutableByteArray.read24be arr i) - (catch-array - (lambda () - (sum 1 (bytevector-u24-ref arr i 'big))))) - - (define (unison-FOp-MutableByteArray.read32be arr i) - (catch-array - (lambda () - (sum 1 (bytevector-u32-ref arr i 'big))))) - - (define (unison-FOp-MutableByteArray.read40be arr i) - (catch-array - (lambda () - (sum 1 (bytevector-u40-ref arr i 'big))))) - - (define (unison-FOp-MutableByteArray.read64be arr i) - (catch-array - (lambda () - (sum 1 (bytevector-u64-ref arr i 'big))))) - - (define (unison-FOp-Scope.bytearray n) (make-bytevector n)) - (define (unison-FOp-IO.bytearray n) (make-bytevector n)) - - (define (unison-FOp-Scope.array n) (make-vector n)) - (define (unison-FOp-IO.array n) (make-vector n)) - - (define (unison-FOp-Scope.bytearrayOf b n) (make-bytevector n b)) - (define (unison-FOp-IO.bytearrayOf b n) (make-bytevector n b)) - - (define (unison-FOp-Scope.arrayOf v n) (make-vector n v)) - (define (unison-FOp-IO.arrayOf v n) (make-vector n v)) - - (define unison-FOp-MutableByteArray.length bytevector-length) - (define unison-FOp-ImmutableByteArray.length bytevector-length) - (define unison-FOp-MutableByteArray.size bytevector-length) - (define unison-FOp-ImmutableByteArray.size bytevector-length) - (define unison-FOp-MutableArray.size vector-length) - (define unison-FOp-ImmutableArray.size vector-length) - - (define (unison-POp-FORK thunk) (fork thunk)) - (define (unison-FOp-IO.delay.impl.v3 micros) (sleep micros)) - (define (unison-FOp-IO.kill.impl.v3 threadId) (kill threadId)) - (define (unison-FOp-Scope.ref a) (ref-new a)) - (define (unison-FOp-IO.ref a) (ref-new a)) - (define (unison-FOp-Ref.read ref) (ref-read ref)) - (define (unison-FOp-Ref.write ref a) (ref-write ref a)) - (define (unison-FOp-Ref.readForCas ref) (ref-read ref)) - (define (unison-FOp-Ref.Ticket.read ticket) ticket) - (define (unison-FOp-Ref.cas ref ticket value) (ref-cas ref ticket value)) - (define (unison-FOp-Promise.new) (promise-new)) - (define (unison-FOp-Promise.read promise) (promise-read promise)) - (define (unison-FOp-Promise.tryRead promise) (promise-try-read promise)) - (define (unison-FOp-Promise.write promise a) (promise-write promise a))) - - - (define (exn:io? e) - (or (exn:fail:read? e) - (exn:fail:filesystem? e) - (exn:fail:network? e))) - - (define (exn:arith? e) - (or (exn:fail:contract:divide-by-zero? e) - (exn:fail:contract:non-fixnum-result? e))) - - (define-unison (builtin-IO.tryEval thunk) - (with-handlers - ([exn:break? - (lambda (e) - (raise-unison-exception - ref-threadkilledfailure:typelink - (string->chunked-string "thread killed") - ref-unit-unit))] - [exn:io? - (lambda (e) - (raise-unison-exception - ref-iofailure:typelink - (exception->string e) - ref-unit-unit))] - [exn:arith? - (lambda (e) - (raise-unison-exception - ref-arithfailure:typelink - (exception->string e) - ref-unit-unit))] - [exn:bug? (lambda (e) (exn:bug->exception e))] - [exn:fail? - (lambda (e) - (raise-unison-exception - ref-runtimefailure:typelink - (exception->string e) - ref-unit-unit))] - [(lambda (x) #t) - (lambda (e) - (raise-unison-exception - ref-miscfailure:typelink - (exception->string e) - ref-unit-unit))]) - (thunk ref-unit-unit))) - - (declare-builtin-link builtin-Float.*) - (declare-builtin-link builtin-Float.fromRepresentation) - (declare-builtin-link builtin-Float.toRepresentation) - (declare-builtin-link builtin-Float.ceiling) - (declare-builtin-link builtin-Float.exp) - (declare-builtin-link builtin-Float.log) - (declare-builtin-link builtin-Float.max) - (declare-builtin-link builtin-Float.min) - (declare-builtin-link builtin-Float.tan) - (declare-builtin-link builtin-Float.tanh) - (declare-builtin-link builtin-Float.logBase) - (declare-builtin-link builtin-Float.pow) - (declare-builtin-link builtin-Float.>) - (declare-builtin-link builtin-Float.<) - (declare-builtin-link builtin-Float.>=) - (declare-builtin-link builtin-Float.<=) - (declare-builtin-link builtin-Float.==) - (declare-builtin-link builtin-Int.pow) - (declare-builtin-link builtin-Int.*) - (declare-builtin-link builtin-Int.+) - (declare-builtin-link builtin-Int.-) - (declare-builtin-link builtin-Int./) - (declare-builtin-link builtin-Int.>) - (declare-builtin-link builtin-Int.<) - (declare-builtin-link builtin-Int.>=) - (declare-builtin-link builtin-Int.<=) - (declare-builtin-link builtin-Int.==) - (declare-builtin-link builtin-Int.isEven) - (declare-builtin-link builtin-Int.isOdd) - (declare-builtin-link builtin-Int.increment) - (declare-builtin-link builtin-Int.negate) - (declare-builtin-link builtin-Int.fromRepresentation) - (declare-builtin-link builtin-Int.toRepresentation) - (declare-builtin-link builtin-Int.signum) - (declare-builtin-link builtin-Int.trailingZeros) - (declare-builtin-link builtin-Int.popCount) - (declare-builtin-link builtin-Nat.increment) - (declare-builtin-link builtin-Nat.popCount) - (declare-builtin-link builtin-Nat.toFloat) - (declare-builtin-link builtin-Nat.trailingZeros) - (declare-builtin-link builtin-Nat.+) - (declare-builtin-link builtin-Nat.>) - (declare-builtin-link builtin-Nat.<) - (declare-builtin-link builtin-Nat.>=) - (declare-builtin-link builtin-Nat.<=) - (declare-builtin-link builtin-Nat.==) - (declare-builtin-link builtin-Nat.drop) - (declare-builtin-link builtin-Nat.isEven) - (declare-builtin-link builtin-Nat.isOdd) - (declare-builtin-link builtin-Text.indexOf) - (declare-builtin-link builtin-Text.>) - (declare-builtin-link builtin-Text.<) - (declare-builtin-link builtin-Text.>=) - (declare-builtin-link builtin-Text.<=) - (declare-builtin-link builtin-Text.==) - (declare-builtin-link builtin-Text.!=) - (declare-builtin-link builtin-Bytes.indexOf) - (declare-builtin-link builtin-IO.randomBytes) - (declare-builtin-link builtin-IO.tryEval) - (declare-builtin-link builtin-List.splitLeft) - (declare-builtin-link builtin-List.splitRight) - (declare-builtin-link builtin-Value.toBuiltin) - (declare-builtin-link builtin-Value.fromBuiltin) - (declare-builtin-link builtin-Code.fromGroup) - (declare-builtin-link builtin-Code.toGroup) - (declare-builtin-link builtin-TermLink.fromReferent) - (declare-builtin-link builtin-TermLink.toReferent) - (declare-builtin-link builtin-TypeLink.toReference) - (declare-builtin-link builtin-IO.seekHandle.impl.v3) - (declare-builtin-link builtin-IO.getLine.impl.v1) - (declare-builtin-link builtin-IO.getSomeBytes.impl.v1) - (declare-builtin-link builtin-IO.setBuffering.impl.v3) - (declare-builtin-link builtin-IO.getBuffering.impl.v3) - (declare-builtin-link builtin-IO.setEcho.impl.v1) - (declare-builtin-link builtin-IO.isFileOpen.impl.v3) - (declare-builtin-link builtin-IO.ready.impl.v1) - (declare-builtin-link builtin-IO.process.call) - (declare-builtin-link builtin-IO.getEcho.impl.v1) - (declare-builtin-link builtin-IO.getArgs.impl.v1) - (declare-builtin-link builtin-IO.getEnv.impl.v1) - (declare-builtin-link builtin-IO.getChar.impl.v1) - (declare-builtin-link builtin-IO.directoryContents.impl.v3) - (declare-builtin-link builtin-IO.getCurrentDirectory.impl.v3) - (declare-builtin-link builtin-IO.removeDirectory.impl.v3) - (declare-builtin-link builtin-IO.renameFile.impl.v3) - (declare-builtin-link builtin-IO.createTempDirectory.impl.v3) - (declare-builtin-link builtin-IO.createDirectory.impl.v3) - (declare-builtin-link builtin-IO.setCurrentDirectory.impl.v3) - (declare-builtin-link builtin-IO.renameDirectory.impl.v3) - (declare-builtin-link builtin-IO.fileExists.impl.v3) - (declare-builtin-link builtin-IO.isDirectory.impl.v3) - (declare-builtin-link builtin-IO.isFileEOF.impl.v3) - (declare-builtin-link builtin-IO.isSeekable.impl.v3) - (declare-builtin-link builtin-IO.handlePosition.impl.v3) - (declare-builtin-link builtin-IO.systemTime.impl.v3) - (declare-builtin-link builtin-IO.systemTimeMicroseconds.impl.v3) - (declare-builtin-link builtin-Universal.==) - (declare-builtin-link builtin-Universal.>) - (declare-builtin-link builtin-Universal.<) - (declare-builtin-link builtin-Universal.>=) - (declare-builtin-link builtin-Universal.<=) - (declare-builtin-link builtin-Universal.compare) - (declare-builtin-link builtin-Pattern.isMatch) - (declare-builtin-link builtin-Scope.bytearrayOf) - (declare-builtin-link builtin-Char.Class.is) - (declare-builtin-link builtin-Pattern.many.corrected) - (declare-builtin-link builtin-unsafe.coerceAbilities) - (declare-builtin-link builtin-Clock.internals.systemTimeZone.v1) - ) +; This library re-exports all of the builtin operation modules. +; Builtins are now directly implemented, rather than using the +; implementation details of the Haskell interpreter. The individual +; modules are divided to be somewhat more organized, but downstream +; modules can just require this one to get them all. +#lang racket/base + +(provide + (all-from-out + unison/primops/array + unison/primops/bytes + unison/primops/concurrent + unison/primops/crypto + unison/primops/io + unison/primops/io-handles + unison/primops/list + unison/primops/math + unison/primops/misc + unison/primops/pattern + unison/primops/ref + unison/primops/tcp + unison/primops/text + unison/primops/tls + unison/primops/udp + unison/primops/universal) + + unison-POp-BLDS + unison-FOp-internal.dataTag) + +(require + unison/primops/array + unison/primops/bytes + unison/primops/concurrent + unison/primops/crypto + unison/primops/io + unison/primops/io-handles + unison/primops/list + unison/primops/math + unison/primops/misc + unison/primops/pattern + unison/primops/ref + unison/primops/tcp + unison/primops/text + unison/primops/tls + unison/primops/udp + unison/primops/universal) + +(require unison/chunked-seq + unison/core + unison/data + racket/match) + +; BLDS occurs directly in list literal code +(define (unison-POp-BLDS . xs) + (vector->chunked-list (list->vector xs))) + +; occurs in some replacement code for the racket compiler +(define (unison-FOp-internal.dataTag v) (unison-data-tag v)) diff --git a/scheme-libs/racket/unison/primops/array.rkt b/scheme-libs/racket/unison/primops/array.rkt new file mode 100644 index 0000000000..c6937d2cd8 --- /dev/null +++ b/scheme-libs/racket/unison/primops/array.rkt @@ -0,0 +1,229 @@ +#lang racket/base + +(require unison/boot + unison/bytevector + unison/data + unison/data-info) + +(require + rnrs/bytevectors-6 + (only-in racket/unsafe/ops + [unsafe-vector*->immutable-vector! freeze-vector!])) + +(provide + builtin-ImmutableArray.copyTo! + builtin-ImmutableArray.copyTo!:termlink + builtin-ImmutableArray.read + builtin-ImmutableArray.read:termlink + builtin-ImmutableArray.size + builtin-ImmutableArray.size:termlink + builtin-ImmutableByteArray.copyTo! + builtin-ImmutableByteArray.copyTo!:termlink + builtin-ImmutableByteArray.read16be + builtin-ImmutableByteArray.read16be:termlink + builtin-ImmutableByteArray.read24be + builtin-ImmutableByteArray.read24be:termlink + builtin-ImmutableByteArray.read32be + builtin-ImmutableByteArray.read32be:termlink + builtin-ImmutableByteArray.read40be + builtin-ImmutableByteArray.read40be:termlink + builtin-ImmutableByteArray.read64be + builtin-ImmutableByteArray.read64be:termlink + builtin-ImmutableByteArray.read8 + builtin-ImmutableByteArray.read8:termlink + builtin-ImmutableByteArray.size + builtin-ImmutableByteArray.size:termlink + + builtin-MutableArray.copyTo! + builtin-MutableArray.copyTo!:termlink + builtin-MutableArray.freeze + builtin-MutableArray.freeze:termlink + builtin-MutableArray.freeze! + builtin-MutableArray.freeze!:termlink + builtin-MutableArray.read + builtin-MutableArray.read:termlink + builtin-MutableArray.size + builtin-MutableArray.size:termlink + builtin-MutableArray.write + builtin-MutableArray.write:termlink + builtin-MutableByteArray.copyTo! + builtin-MutableByteArray.copyTo!:termlink + builtin-MutableByteArray.freeze! + builtin-MutableByteArray.freeze!:termlink + builtin-MutableByteArray.read16be + builtin-MutableByteArray.read16be:termlink + builtin-MutableByteArray.read24be + builtin-MutableByteArray.read24be:termlink + builtin-MutableByteArray.read32be + builtin-MutableByteArray.read32be:termlink + builtin-MutableByteArray.read40be + builtin-MutableByteArray.read40be:termlink + builtin-MutableByteArray.read64be + builtin-MutableByteArray.read64be:termlink + builtin-MutableByteArray.read8 + builtin-MutableByteArray.read8:termlink + builtin-MutableByteArray.size + builtin-MutableByteArray.size:termlink + builtin-MutableByteArray.write16be + builtin-MutableByteArray.write16be:termlink + builtin-MutableByteArray.write32be + builtin-MutableByteArray.write32be:termlink + builtin-MutableByteArray.write64be + builtin-MutableByteArray.write64be:termlink + builtin-MutableByteArray.write8 + builtin-MutableByteArray.write8:termlink + + builtin-Scope.array + builtin-Scope.array:termlink + builtin-Scope.arrayOf + builtin-Scope.arrayOf:termlink + builtin-Scope.bytearray + builtin-Scope.bytearray:termlink + builtin-Scope.bytearrayOf + builtin-Scope.bytearrayOf:termlink) + + +(define-syntax handle-array + (syntax-rules () + [(_ ex ...) + (with-handlers + ([exn:fail:contract? + (lambda (e) + (request + ref-exception + 0 + (ref-failure-failure + ref-arrayfailure:typelink + (string->chunked-string (exception->string e)) + (unison-any-any ref-unit-unit))))]) + ex ...)])) + +(define-unison-builtin + (builtin-ImmutableArray.copyTo! dst doff src soff n) + (handle-array + (vector-copy! dst doff src soff (+ soff n)) + ref-unit-unit)) + +(define-unison-builtin (builtin-ImmutableArray.read arr i) + (handle-array (vector-ref arr i))) + +(define-unison-builtin (builtin-ImmutableArray.size arr) + (vector-length arr)) + +(define-unison-builtin + (builtin-ImmutableByteArray.copyTo! dst doff src soff n) + (handle-array + (bytes-copy! dst doff src soff (+ soff n)) + ref-unit-unit)) + +(define-unison-builtin (builtin-ImmutableByteArray.read16be arr i) + (handle-array (bytevector-u16-ref arr i 'big))) + +(define-unison-builtin (builtin-ImmutableByteArray.read24be arr i) + (handle-array (bytevector-u24-ref arr i 'big))) + +(define-unison-builtin (builtin-ImmutableByteArray.read32be arr i) + (handle-array (bytevector-u32-ref arr i 'big))) + +(define-unison-builtin (builtin-ImmutableByteArray.read40be arr i) + (handle-array (bytevector-u40-ref arr i 'big))) + +(define-unison-builtin (builtin-ImmutableByteArray.read64be arr i) + (handle-array (bytevector-u64-ref arr i 'big))) + +(define-unison-builtin (builtin-ImmutableByteArray.read8 arr i) + (handle-array (bytevector-u8-ref arr i))) + +(define-unison-builtin (builtin-ImmutableByteArray.size arr) + (bytevector-length arr)) + +(define-unison-builtin (builtin-MutableArray.copyTo! dst doff src soff l) + (handle-array + (vector-copy! dst doff src soff (+ soff l)) + ref-unit-unit)) + +(define-unison-builtin (builtin-MutableArray.freeze arr i j) + (freeze-subvector arr i j)) + +(define-unison-builtin (builtin-MutableArray.freeze! arr) + (freeze-vector! arr)) + +(define-unison-builtin (builtin-MutableArray.read arr i) + (handle-array (vector-ref arr i))) + +(define-unison-builtin (builtin-MutableArray.size arr) + (vector-length arr)) + +(define-unison-builtin (builtin-MutableArray.write dst i x) + (handle-array + (vector-set! dst i x) + ref-unit-unit)) + +(define-unison-builtin + (builtin-MutableByteArray.copyTo! dst doff src soff l) + (handle-array + (bytes-copy! dst doff src soff (+ soff l)) + ref-unit-unit)) + +(define-unison-builtin (builtin-MutableByteArray.freeze! arr) + (freeze-bytevector! arr)) + +(define-unison-builtin (builtin-MutableByteArray.read16be arr i) + (handle-array (bytevector-u16-ref arr i 'big))) + +(define-unison-builtin (builtin-MutableByteArray.read24be arr i) + (handle-array (bytevector-u24-ref arr i 'big))) + +(define-unison-builtin (builtin-MutableByteArray.read32be arr i) + (handle-array (bytevector-u32-ref arr i 'big))) + +(define-unison-builtin (builtin-MutableByteArray.read40be arr i) + (handle-array (bytevector-u40-ref arr i 'big))) + +(define-unison-builtin (builtin-MutableByteArray.read64be arr i) + (handle-array (bytevector-u64-ref arr i 'big))) + +(define-unison-builtin (builtin-MutableByteArray.read8 arr i) + (handle-array (bytevector-u8-ref arr i))) + +(define-unison-builtin (builtin-MutableByteArray.size arr) + (bytevector-length arr)) + +(define-unison-builtin (builtin-MutableByteArray.write16be arr i m) + (handle-array + (bytevector-u16-set! arr i m 'big) + ref-unit-unit)) + +(define-unison-builtin (builtin-MutableByteArray.write32be arr i m) + (handle-array + (bytevector-u32-set! arr i m 'big) + ref-unit-unit)) + +(define-unison-builtin (builtin-MutableByteArray.write64be arr i m) + (handle-array + (bytevector-u64-set! arr i m 'big) + ref-unit-unit)) + +(define-unison-builtin (builtin-MutableByteArray.write8 arr i m) + (handle-array + (bytevector-u8-set! arr i m) + ref-unit-unit)) + +(define-unison-builtin (builtin-Scope.array n) + (make-vector n)) + +(define-unison-builtin (builtin-Scope.arrayOf v n) + (make-vector n v)) + +(define-unison-builtin (builtin-Scope.bytearray n) + (make-bytes n)) + +(define-unison-builtin (builtin-Scope.bytearrayOf i n) + (make-bytes n i)) + +(define (freeze-subvector src off len0) + (define len (min len0 (- (vector-length src) off))) + (define dst (make-vector len)) + + (vector-copy! dst 0 src off (+ off len)) + (freeze-vector! dst)) diff --git a/scheme-libs/racket/unison/primops/bytes.rkt b/scheme-libs/racket/unison/primops/bytes.rkt new file mode 100644 index 0000000000..6259fdf7e4 --- /dev/null +++ b/scheme-libs/racket/unison/primops/bytes.rkt @@ -0,0 +1,222 @@ + +#lang racket/base + +(require unison/boot + unison/bytes-nat + unison/chunked-bytes + unison/chunked-seq + unison/data + unison/data-info + unison/gzip + unison/string-search + unison/zlib) + +(provide + builtin-Bytes.++ + builtin-Bytes.++:termlink + builtin-Bytes.at + builtin-Bytes.at:termlink + builtin-Bytes.decodeNat16be + builtin-Bytes.decodeNat16be:termlink + builtin-Bytes.decodeNat16le + builtin-Bytes.decodeNat16le:termlink + builtin-Bytes.decodeNat32be + builtin-Bytes.decodeNat32be:termlink + builtin-Bytes.decodeNat32le + builtin-Bytes.decodeNat32le:termlink + builtin-Bytes.decodeNat64be + builtin-Bytes.decodeNat64be:termlink + builtin-Bytes.decodeNat64le + builtin-Bytes.decodeNat64le:termlink + builtin-Bytes.drop + builtin-Bytes.drop:termlink + builtin-Bytes.empty + builtin-Bytes.empty:termlink + builtin-Bytes.encodeNat16be + builtin-Bytes.encodeNat16be:termlink + builtin-Bytes.encodeNat16le + builtin-Bytes.encodeNat16le:termlink + builtin-Bytes.encodeNat32be + builtin-Bytes.encodeNat32be:termlink + builtin-Bytes.encodeNat32le + builtin-Bytes.encodeNat32le:termlink + builtin-Bytes.encodeNat64be + builtin-Bytes.encodeNat64be:termlink + builtin-Bytes.encodeNat64le + builtin-Bytes.encodeNat64le:termlink + builtin-Bytes.flatten + builtin-Bytes.flatten:termlink + builtin-Bytes.fromBase16 + builtin-Bytes.fromBase16:termlink + builtin-Bytes.fromBase32 + builtin-Bytes.fromBase32:termlink + builtin-Bytes.fromBase64 + builtin-Bytes.fromBase64:termlink + builtin-Bytes.fromBase64UrlUnpadded + builtin-Bytes.fromBase64UrlUnpadded:termlink + builtin-Bytes.fromList + builtin-Bytes.fromList:termlink + builtin-Bytes.gzip.compress + builtin-Bytes.gzip.compress:termlink + builtin-Bytes.gzip.decompress + builtin-Bytes.gzip.decompress:termlink + builtin-Bytes.indexOf + builtin-Bytes.indexOf:termlink + builtin-Bytes.size + builtin-Bytes.size:termlink + builtin-Bytes.take + builtin-Bytes.take:termlink + builtin-Bytes.toBase16 + builtin-Bytes.toBase16:termlink + builtin-Bytes.toBase32 + builtin-Bytes.toBase32:termlink + builtin-Bytes.toBase64 + builtin-Bytes.toBase64:termlink + builtin-Bytes.toBase64UrlUnpadded + builtin-Bytes.toBase64UrlUnpadded:termlink + builtin-Bytes.toList + builtin-Bytes.toList:termlink + builtin-Bytes.zlib.compress + builtin-Bytes.zlib.compress:termlink + builtin-Bytes.zlib.decompress + builtin-Bytes.zlib.decompress:termlink) + +(define-unison-builtin (builtin-Bytes.++ l r) + (chunked-bytes-append l r)) + +(define-unison-builtin (builtin-Bytes.at n bs) + (with-handlers + ([exn:fail:contract? (lambda (e) ref-optional-none)]) + (ref-optional-some (chunked-bytes-ref bs n)))) + +(define-unison-builtin (builtin-Bytes.decodeNat16be bs) + (decodeNatBe bs 2)) + +(define-unison-builtin (builtin-Bytes.decodeNat16le bs) + (decodeNatLe bs 2)) + +(define-unison-builtin (builtin-Bytes.decodeNat32be bs) + (decodeNatBe bs 4)) + +(define-unison-builtin (builtin-Bytes.decodeNat32le bs) + (decodeNatLe bs 4)) + +(define-unison-builtin (builtin-Bytes.decodeNat64be bs) + (decodeNatBe bs 8)) + +(define-unison-builtin (builtin-Bytes.decodeNat64le bs) + (decodeNatLe bs 8)) + +(define-unison-builtin (builtin-Bytes.drop n bs) + (chunked-bytes-drop bs n)) + +(define-unison-builtin #:hints [value] (builtin-Bytes.empty) + empty-chunked-bytes) + +(define-unison-builtin (builtin-Bytes.encodeNat16be n) + (encodeNatBe n 2)) + +(define-unison-builtin (builtin-Bytes.encodeNat16le n) + (encodeNatLe n 2)) + +(define-unison-builtin (builtin-Bytes.encodeNat32be n) + (encodeNatBe n 4)) + +(define-unison-builtin (builtin-Bytes.encodeNat32le n) + (encodeNatLe n 4)) + +(define-unison-builtin (builtin-Bytes.encodeNat64be n) + (encodeNatBe n 8)) + +(define-unison-builtin (builtin-Bytes.encodeNat64le n) + (encodeNatLe n 8)) + +; Note: the current implementation has no mechanism for +; flattening the representation, but in the event this changes, +; this should be revisited. +(define-unison-builtin (builtin-Bytes.flatten bs) bs) + +(define-unison-builtin (builtin-Bytes.fromBase16 bs) + (with-handlers + ([exn:fail? (lambda (e) (ref-either-left (exception->string e)))]) + (ref-either-right (base16-decode bs)))) + +(define-unison-builtin (builtin-Bytes.fromBase32 bs) + (with-handlers + ([exn:fail? (lambda (e) (ref-either-left (exception->string e)))]) + (ref-either-right (base32-decode bs)))) + +(define-unison-builtin (builtin-Bytes.fromBase64 bs) + (with-handlers + ([exn:fail? (lambda (e) (ref-either-left (exception->string e)))]) + (ref-either-right (base64-decode bs)))) + +(define-unison-builtin (builtin-Bytes.fromBase64UrlUnpadded bs) + (with-handlers + ([exn:fail? (lambda (e) (ref-either-left (exception->string e)))]) + (ref-either-right (base64-decode bs #:padded? #f)))) + +(define-unison-builtin (builtin-Bytes.fromList l) + (build-chunked-bytes + (chunked-list-length l) + (lambda (i) (chunked-list-ref l i)))) + +(define-unison-builtin (builtin-Bytes.gzip.compress bs) + (bytes->chunked-bytes (gzip-bytes (chunked-bytes->bytes bs)))) + +(define-unison-builtin (builtin-Bytes.gzip.decompress bs) + (with-handlers + [[exn:fail? (lambda (e) (ref-either-left (exception->string e)))]] + (ref-either-right + (bytes->chunked-bytes + (gunzip-bytes + (chunked-bytes->bytes bs)))))) + +(define-unison-builtin (builtin-Bytes.size bs) + (chunked-bytes-length bs)) + +(define-unison-builtin (builtin-Bytes.take n bs) + (chunked-bytes-take bs n)) + +(define-unison-builtin (builtin-Bytes.toBase16 bs) + (base16-encode bs)) + +(define-unison-builtin (builtin-Bytes.toBase32 bs) + (base32-encode bs)) + +(define-unison-builtin (builtin-Bytes.toBase64 bs) + (base64-encode bs)) + +(define-unison-builtin (builtin-Bytes.toBase64UrlUnpadded bs) + (base64-encode bs #:pad? #f)) + +(define-unison-builtin (builtin-Bytes.toList bs) + (build-chunked-list + (chunked-bytes-length bs) + (lambda (i) (chunked-bytes-ref bs i)))) + +(define-unison-builtin (builtin-Bytes.zlib.compress bs) + (bytes->chunked-bytes + (zlib-deflate-bytes + (chunked-bytes->bytes bs)))) + +(define-unison-builtin (builtin-Bytes.zlib.decompress bs) + (with-handlers + [[exn:fail? + (lambda (e) + (ref-either-left + (ref-failure-failure + ref-miscfailure:typelink + (exception->string e) + (unison-any-any ref-unit-unit))))]] + (ref-either-right + (bytes->chunked-bytes + (zlib-inflate-bytes + (chunked-bytes->bytes bs)))))) + +(define-unison-builtin (builtin-Bytes.indexOf n h) + (define v (chunked-bytes-index-of h n)) + + (if v + (ref-optional-some v) + ref-optional-none)) diff --git a/scheme-libs/racket/unison/primops/concurrent.rkt b/scheme-libs/racket/unison/primops/concurrent.rkt new file mode 100644 index 0000000000..b873a0e743 --- /dev/null +++ b/scheme-libs/racket/unison/primops/concurrent.rkt @@ -0,0 +1,53 @@ + +#lang racket/base + +(require unison/boot + unison/concurrent + unison/data + unison/data-info) + +(provide + builtin-IO.delay.impl.v3 + builtin-IO.delay.impl.v3:termlink + builtin-IO.forkComp.v2 + builtin-IO.forkComp.v2:termlink + builtin-IO.kill.impl.v3 + builtin-IO.kill.impl.v3:termlink + + builtin-Promise.new + builtin-Promise.new:termlink + builtin-Promise.read + builtin-Promise.read:termlink + builtin-Promise.tryRead + builtin-Promise.tryRead:termlink + builtin-Promise.write + builtin-Promise.write:termlink + builtin-ThreadId.toText + builtin-ThreadId.toText:termlink) + + +(define-unison-builtin (builtin-Promise.new _) (promise-new)) + +(define-unison-builtin (builtin-Promise.read p) (promise-read p)) + +(define-unison-builtin (builtin-Promise.tryRead p) (promise-try-read p)) + +(define-unison-builtin (builtin-Promise.write p v) (promise-write p v)) + +(define-unison-builtin (builtin-ThreadId.toText tid) + (string->chunked-string (describe-value tid))) + +(define-unison-builtin (builtin-IO.delay.impl.v3 micros) + ; TODO: this seems like it should have error handling, but it hadn't + ; been implemented yet. + (sleep micros) + (ref-either-right ref-unit-unit)) + +(define-unison-builtin (builtin-IO.forkComp.v2 k) + (fork (lambda () (k ref-unit-unit)))) + +(define-unison-builtin (builtin-IO.kill.impl.v3 tid) + ; TODO: this seems like it should have error handling, but it hadn't + ; been implemented yet. + (kill tid) + (ref-either-right ref-unit-unit)) diff --git a/scheme-libs/racket/unison/primops/crypto.rkt b/scheme-libs/racket/unison/primops/crypto.rkt new file mode 100644 index 0000000000..8a0607b998 --- /dev/null +++ b/scheme-libs/racket/unison/primops/crypto.rkt @@ -0,0 +1,438 @@ +#lang racket/base + +(require ffi/unsafe + ffi/unsafe/define + racket/exn + racket/runtime-path + (for-syntax racket/base) + openssl/libcrypto + unison/boot + unison/chunked-seq + racket/bool + (only-in openssl/sha1 bytes->hex-string hex-string->bytes) + + ) + +(provide + builtin-crypto.HashAlgorithm.Blake2b_256 + builtin-crypto.HashAlgorithm.Blake2b_256:termlink + builtin-crypto.HashAlgorithm.Blake2b_512 + builtin-crypto.HashAlgorithm.Blake2b_512:termlink + builtin-crypto.HashAlgorithm.Blake2s_256 + builtin-crypto.HashAlgorithm.Blake2s_256:termlink + builtin-crypto.HashAlgorithm.Md5 + builtin-crypto.HashAlgorithm.Md5:termlink + builtin-crypto.HashAlgorithm.Sha1 + builtin-crypto.HashAlgorithm.Sha1:termlink + builtin-crypto.HashAlgorithm.Sha2_256 + builtin-crypto.HashAlgorithm.Sha2_256:termlink + builtin-crypto.HashAlgorithm.Sha2_512 + builtin-crypto.HashAlgorithm.Sha2_512:termlink + builtin-crypto.HashAlgorithm.Sha3_256 + builtin-crypto.HashAlgorithm.Sha3_256:termlink + builtin-crypto.HashAlgorithm.Sha3_512 + builtin-crypto.HashAlgorithm.Sha3_512:termlink + builtin-crypto.hashBytes + builtin-crypto.hashBytes:termlink + builtin-crypto.hmacBytes + builtin-crypto.hmacBytes:termlink + builtin-crypto.Ed25519.verify.impl + builtin-crypto.Ed25519.verify.impl:termlink + builtin-crypto.Ed25519.sign.impl + builtin-crypto.Ed25519.sign.impl:termlink) + +(define-runtime-path libb2-so '(so "libb2" ("1" #f))) + +(define libb2 + (with-handlers [[exn:fail? exn->string]] + (ffi-lib libb2-so '("1" #f)))) + +(define _EVP-pointer (_cpointer 'EVP)) + +; returns a function that, when called, either +; 1) raises an exception, if libcrypto failed to load, or +; 2) returns a pair of (_EVP-pointer bits) +(define (lc-algo name bits) + (if (string? libcrypto) + (raise (error 'libcrypto "~a\n~a" name libcrypto)) + (let ([getter (get-ffi-obj name libcrypto (_fun -> _EVP-pointer))]) + (cons (getter) bits)))) + +(define (check v who) + (unless (= 1 v) + (error who "failed with return value ~a" v))) + +(define EVP_Digest + (if (string? libcrypto) + (lambda _ (raise (error 'libcrypto "EVP_Digest\n~a" libcrypto))) + (get-ffi-obj "EVP_Digest" libcrypto + (_fun + _pointer ; input + _int ; input-len + _pointer ; output + _pointer ; null + _EVP-pointer ; algorithm + _pointer ; null + -> (r : _int) + -> (unless (= 1 r) + (error 'EVP_Digest "failed with return value ~a" r)))))) + +(define HMAC + (if (string? libcrypto) + (lambda _ (raise (error 'libcrypto "HMAC\n~a" libcrypto))) + (get-ffi-obj "HMAC" libcrypto + (_fun + _EVP-pointer ; algorithm + _pointer ; key + _int ; key-len + _pointer ; input + _int ; input-len + _pointer ; output pointer + _pointer ; null + -> _pointer ; unused + )))) + +(define (libb2-raw fn) + (if (string? libb2) + (lambda _ (raise (error 'libb2 "~a\n~a" fn libb2))) + (get-ffi-obj fn libb2 + (_fun + _pointer ; output + _pointer ; input + _pointer ; key + _int ; output-len + _int ; input-len + _int ; key-len + -> (r : _int) + -> (unless (= 0 r) + (error 'blake2 "~a failed with return value ~a" fn r)))))) + +(define blake2b-raw (libb2-raw "blake2b")) +(define blake2s-raw (libb2-raw "blake2s")) + +(define-unison-builtin #:hints [value] + (builtin-crypto.HashAlgorithm.Md5) + (lc-algo "EVP_md5" 128)) + +(define-unison-builtin #:hints [value] + (builtin-crypto.HashAlgorithm.Sha1) + (lc-algo "EVP_sha1" 160)) + +(define-unison-builtin #:hints [value] + (builtin-crypto.HashAlgorithm.Sha2_256) + (lc-algo "EVP_sha256" 256)) + +(define-unison-builtin #:hints [value] + (builtin-crypto.HashAlgorithm.Sha2_512) + (lc-algo "EVP_sha512" 512)) + +(define-unison-builtin #:hints [value] + (builtin-crypto.HashAlgorithm.Sha3_256) + (lc-algo "EVP_sha3_256" 256)) + +(define-unison-builtin #:hints [value] + (builtin-crypto.HashAlgorithm.Sha3_512) + (lc-algo "EVP_sha3_512" 512)) + +(define _EVP_PKEY-pointer (_cpointer 'EVP_PKEY)) +(define _EVP_MD_CTX-pointer (_cpointer 'EVP_MD_CTX)) + +(define EVP_MD_CTX_new + (if (string? libcrypto) + (lambda _ (raise (error 'libcrypto "EVP_MD_CTX_create\n~a" libcrypto))) + (get-ffi-obj "EVP_MD_CTX_new" libcrypto + (_fun -> _EVP_MD_CTX-pointer + )))) + +; EVP_PKEY_new_raw_private_key(int type, NULL, const unsigned char *key, size_t keylen); +(define EVP_PKEY_new_raw_private_key + (if (string? libcrypto) + (lambda _ (raise (error 'libcrypto "EVP_PKEY_new_raw_private_key\n~a" libcrypto))) + (get-ffi-obj "EVP_PKEY_new_raw_private_key" libcrypto + (_fun + _int ; type + _pointer ; engine (null) + _pointer ; key + _int ; key-len + -> _EVP_PKEY-pointer + )))) + +; EVP_DigestSignInit(hctx, NULL, EVP_sha256(), NULL, pkey) +(define EVP_DigestSignInit + (if (string? libcrypto) + (lambda _ (raise (error 'libcrypto "EVP_DigestSignInit\n~a" libcrypto))) + (get-ffi-obj "EVP_DigestSignInit" libcrypto + (_fun + _EVP_MD_CTX-pointer + _pointer ; (null) + _pointer ; (null) + _pointer ; (null) + _EVP_PKEY-pointer ; pkey + -> _int + )))) + +; EVP_DigestSign(hctx, output, output-len-ptr, input-data, input-data-len) +(define EVP_DigestSign + (if (string? libcrypto) + (lambda _ (raise (error 'libcrypto "EVP_DigestSign\n~a" libcrypto))) + (get-ffi-obj "EVP_DigestSign" libcrypto + (_fun + _EVP_MD_CTX-pointer + _pointer ; output + (_ptr o _int) ; output-len (null prolly) + _pointer ; input-data + _int ; input-data-len + -> _int + )))) + +; EVP_PKEY_new_raw_public_key(int type, NULL, const unsigned char *key, size_t keylen); +(define EVP_PKEY_new_raw_public_key + (if (string? libcrypto) + (lambda _ (raise (error 'libcrypto "EVP_PKEY_new_raw_public_key\n~a" libcrypto))) + (get-ffi-obj "EVP_PKEY_new_raw_public_key" libcrypto + (_fun + _int ; type + _pointer ; engine (null) + _pointer ; key + _int ; key-len + -> _EVP_PKEY-pointer + )))) + +; int EVP_DigestVerifyInit(EVP_MD_CTX *ctx, EVP_PKEY_CTX **pctx, +; const EVP_MD *type, ENGINE *e, EVP_PKEY *pkey); +(define EVP_DigestVerifyInit + (if (string? libcrypto) + (lambda _ (raise (error 'libcrypto "EVP_DigestVerifyInit\n~a" libcrypto))) + (get-ffi-obj "EVP_DigestVerifyInit" libcrypto + (_fun + _EVP_MD_CTX-pointer + _pointer ; (null) + _pointer ; (null) + _pointer ; (null) + _EVP_PKEY-pointer ; pkey + -> _int + )))) + +; int EVP_DigestVerify(EVP_MD_CTX *ctx, const unsigned char *sig, +; size_t siglen, const unsigned char *tbs, size_t tbslen); +(define EVP_DigestVerify + (if (string? libcrypto) + (lambda _ (raise (error 'libcrypto "EVP_DigestVerify\n~a" libcrypto))) + (get-ffi-obj "EVP_DigestVerify" libcrypto + (_fun + _EVP_MD_CTX-pointer + _pointer ; signature + _int ; signature-len + _pointer ; input-data + _int ; input-data-len + -> _int + )))) + + +(define EVP_PKEY_ED25519 1087) +(define (evpSign-raw seed input) + (let* ([ctx (EVP_MD_CTX_new)] + [pkey (EVP_PKEY_new_raw_private_key EVP_PKEY_ED25519 #f seed (bytes-length seed))]) + (if (false? pkey) + (raise (error "Invalid seed provided.")) + (if (<= (EVP_DigestSignInit ctx #f #f #f pkey) 0) + (raise (error "Initializing signing failed")) + (let* ([output (make-bytes 64)]) + (if (<= (EVP_DigestSign ctx output input (bytes-length input)) 0) + (raise (error "Running digest failed")) + output)))))) + +(define (evpVerify-raw public-key input signature) + (let* ([ctx (EVP_MD_CTX_new)] + [pkey (EVP_PKEY_new_raw_public_key EVP_PKEY_ED25519 #f public-key (bytes-length public-key))]) + (if (false? pkey) + (raise (error "Invalid seed provided.")) + (if (<= (EVP_DigestVerifyInit ctx #f #f #f pkey) 0) + (raise (error "Initializing Verify failed")) + (if (<= (EVP_DigestVerify ctx signature (bytes-length signature) input (bytes-length input)) 0) + #f + #t))))) + +(define-unison-builtin + (builtin-crypto.Ed25519.sign.impl seed _ignored_pubkey input) + (bytes->chunked-bytes + (evpSign-raw + (chunked-bytes->bytes seed) + (chunked-bytes->bytes input)))) + +(define-unison-builtin + (builtin-crypto.Ed25519.verify.impl public-key input signature) + (evpVerify-raw + (chunked-bytes->bytes public-key) + (chunked-bytes->bytes input) + (chunked-bytes->bytes signature))) + +(define-unison-builtin #:hints [value] + (builtin-crypto.HashAlgorithm.Blake2s_256) + (cons 'blake2s 256)) +(define-unison-builtin #:hints [value] + (builtin-crypto.HashAlgorithm.Blake2b_512) + (cons 'blake2b 512)) + +; This one isn't provided by libcrypto, for some reason +(define-unison-builtin #:hints [value] + (builtin-crypto.HashAlgorithm.Blake2b_256) + (cons 'blake2b 256)) + +; kind is a pair of (algorithm bits) +; where algorithm is either an EVP_pointer for libcrypto functions, +; or the tag 'blake2b for libb2 function. +(define-unison-builtin (builtin-crypto.hashBytes kind input) + (bytes->chunked-bytes + (hashBytes-raw kind (chunked-bytes->bytes input)))) + +; kind is a pair of (algorithm bits) +; where algorithm is either an EVP_pointer for libcrypto functions, +; or the tag 'blake2b for libb2 function. +(define (hashBytes-raw kind input) + (let* ([bytes (/ (cdr kind) 8)] + [output (make-bytes bytes)] + [algo (car kind)]) + (case algo + ['blake2b (blake2b-raw output input #f bytes (bytes-length input) 0)] + ['blake2s (blake2s-raw output input #f bytes (bytes-length input) 0)] + [else (EVP_Digest input (bytes-length input) output #f algo #f)]) + + output)) + +; Mutates and returns the first argument +(define (xor one two) + (for ([i (in-range (bytes-length one))]) + (bytes-set! one i + (bitwise-xor + (bytes-ref one i) + (bytes-ref two i)))) + one) + +; doing the blake hmac by hand. libcrypto +; supports hmac natively, so we just defer to that +(define (hmacBlake kind key input) + (let* + ([bytes (/ (cdr kind) 8)] + [blocksize (case (car kind) ['blake2b 128] ['blake2s 64])] + + [key_ + (let ([key_ (make-bytes blocksize 0)]) + (bytes-copy! key_ 0 + (if (< blocksize (bytes-length key)) + (hashBytes-raw kind key) + key)) + key_)] + + [opad (xor (make-bytes blocksize #x5c) key_)] + [ipad (xor (make-bytes blocksize #x36) key_)] + + [full (bytes-append + opad + (hashBytes-raw kind (bytes-append ipad input)))]) + (hashBytes-raw kind full))) + +(define-unison-builtin (builtin-crypto.hmacBytes kind key input) + (bytes->chunked-bytes + (hmacBytes-raw + kind + (chunked-bytes->bytes key) + (chunked-bytes->bytes input)))) + +(define (hmacBytes-raw kind key input) + (case (car kind) + ['blake2b (hmacBlake kind key input)] + ['blake2s (hmacBlake kind key input)] + [else + (let* ([bytes (/ (cdr kind) 8)] + [output (make-bytes bytes)] + [algo (car kind)]) + (HMAC algo key (bytes-length key) input (bytes-length input) output #f) + output)])) + + +; These will only be evaluated by `raco test` +(module+ test + (require rackunit + (only-in openssl/sha1 bytes->hex-string hex-string->bytes)) + + (test-case "ed25519 sign" + (check-equal? + (bytes->hex-string + (evpSign-raw + (hex-string->bytes "0000000000000000000000000000000000000000000000000000000000000000") #"")) + "8f895b3cafe2c9506039d0e2a66382568004674fe8d237785092e40d6aaf483e4fc60168705f31f101596138ce21aa357c0d32a064f423dc3ee4aa3abf53f803")) + + (test-case "ed25519 verify" + (check-equal? + (evpVerify-raw + (hex-string->bytes "3b6a27bcceb6a42d62a3a8d02a6f0d73653215771de243a63ac048a18b59da29") + #"" + (hex-string->bytes "8f895b3cafe2c9506039d0e2a66382568004674fe8d237785092e40d6aaf483e4fc60168705f31f101596138ce21aa357c0d32a064f423dc3ee4aa3abf53f803") + ) + #t)) + + (test-case "sha1 hmac" + (check-equal? + (bytes->hex-string (hmacBytes-raw (builtin-crypto.HashAlgorithm.Sha1) #"key" #"message")) + "2088df74d5f2146b48146caf4965377e9d0be3a4")) + + (test-case "blake2b-256 hmac" + (check-equal? + (bytes->hex-string (hmacBytes-raw (builtin-crypto.HashAlgorithm.Blake2b_256) #"key" #"message")) + "442d98a3872d3f56220f89e2b23d0645610b37c33dd3315ef224d0e39ada6751")) + + (test-case "blake2b-512 hmac" + (check-equal? + (bytes->hex-string (hmacBytes-raw (builtin-crypto.HashAlgorithm.Blake2b_512) #"key" #"message")) + "04e9ada930688cde75eec939782eed653073dd621d7643f813702976257cf037d325b50eedd417c01b6ad1f978fbe2980a93d27d854044e8626df6fa279d6680")) + + (test-case "blake2s-256 hmac" + (check-equal? + (bytes->hex-string (hmacBytes-raw (builtin-crypto.HashAlgorithm.Blake2s_256) #"key" #"message")) + "bba8fa28708ae80d249e317318c95c859f3f77512be23910d5094d9110454d6f")) + + (test-case "md5 basic" + (check-equal? + (bytes->hex-string (hashBytes-raw (builtin-crypto.HashAlgorithm.Md5) #"")) + "d41d8cd98f00b204e9800998ecf8427e")) + + (test-case "sha1 basic" + (check-equal? + (bytes->hex-string (hashBytes-raw (builtin-crypto.HashAlgorithm.Sha1) #"")) + "da39a3ee5e6b4b0d3255bfef95601890afd80709")) + + (test-case "sha2-256 basic" + (check-equal? + (bytes->hex-string (hashBytes-raw (builtin-crypto.HashAlgorithm.Sha2_256) #"")) + "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")) + + (test-case "sha2-512 basic" + (check-equal? + (bytes->hex-string (hashBytes-raw (builtin-crypto.HashAlgorithm.Sha2_512) #"")) + "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e")) + + (test-case "sha3-256 basic" + (check-equal? + (bytes->hex-string (hashBytes-raw (builtin-crypto.HashAlgorithm.Sha3_256) #"")) + "a7ffc6f8bf1ed76651c14756a061d662f580ff4de43b49fa82d80a4b80f8434a")) + + (test-case "sha3-512 basic" + (check-equal? + (bytes->hex-string (hashBytes-raw (builtin-crypto.HashAlgorithm.Sha3_512) #"")) + "a69f73cca23a9ac5c8b567dc185a756e97c982164fe25859e0d1dcc1475c80a615b2123af1f5f94c11e3e9402c3ac558f500199d95b6d3e301758586281dcd26")) + + (test-case "blake2s_256 basic" + (check-equal? + (bytes->hex-string (hashBytes-raw (builtin-crypto.HashAlgorithm.Blake2s_256) #"")) + "69217a3079908094e11121d042354a7c1f55b6482ca1a51e1b250dfd1ed0eef9")) + + (test-case "blake2b_256 basic" + (check-equal? + (bytes->hex-string (hashBytes-raw (builtin-crypto.HashAlgorithm.Blake2b_256) #"")) + "0e5751c026e543b2e8ab2eb06099daa1d1e5df47778f7787faab45cdf12fe3a8")) + + (test-case "blake2b_512 basic" + (check-equal? + (bytes->hex-string (hashBytes-raw (builtin-crypto.HashAlgorithm.Blake2b_512) #"")) + "786a02f742015903c6c6fd852552d272912f4740e15847618a86e217f71f5419d25e1031afee585313896444934eb04b903a685b1448b755d56f701afe9be2ce"))) diff --git a/scheme-libs/racket/unison/primops/io-handles.rkt b/scheme-libs/racket/unison/primops/io-handles.rkt new file mode 100644 index 0000000000..94724dca6f --- /dev/null +++ b/scheme-libs/racket/unison/primops/io-handles.rkt @@ -0,0 +1,305 @@ +#lang racket/base + +(require racket/string + rnrs/io/ports-6 + (only-in rnrs standard-error-port standard-input-port standard-output-port) + (only-in racket + empty? + match + with-output-to-string + system/exit-code + system + false?) + unison/boot + unison/data + unison/chunked-seq + unison/data + unison/data-info + unison/chunked-seq + unison/data + ) + +(provide + builtin-Handle.toText + builtin-Handle.toText:termlink + + builtin-IO.closeFile.impl.v3 + builtin-IO.closeFile.impl.v3:termlink + builtin-IO.getBytes.impl.v3 + builtin-IO.getBytes.impl.v3:termlink + builtin-IO.stdHandle + builtin-IO.stdHandle:termlink + builtin-IO.openFile.impl.v3 + builtin-IO.openFile.impl.v3:termlink + builtin-IO.putBytes.impl.v3 + builtin-IO.putBytes.impl.v3:termlink + builtin-IO.seekHandle.impl.v3 + builtin-IO.seekHandle.impl.v3:termlink + builtin-IO.getLine.impl.v1 + builtin-IO.getLine.impl.v1:termlink + builtin-IO.getSomeBytes.impl.v1 + builtin-IO.getSomeBytes.impl.v1:termlink + builtin-IO.getBuffering.impl.v3 + builtin-IO.getBuffering.impl.v3:termlink + builtin-IO.setBuffering.impl.v3 + builtin-IO.setBuffering.impl.v3:termlink + builtin-IO.getEcho.impl.v1 + builtin-IO.getEcho.impl.v1:termlink + builtin-IO.setEcho.impl.v1 + builtin-IO.setEcho.impl.v1:termlink + builtin-IO.getChar.impl.v1 + builtin-IO.getChar.impl.v1:termlink + builtin-IO.isFileOpen.impl.v3 + builtin-IO.isFileOpen.impl.v3:termlink + builtin-IO.isSeekable.impl.v3 + builtin-IO.isSeekable.impl.v3:termlink + builtin-IO.handlePosition.impl.v3 + builtin-IO.handlePosition.impl.v3:termlink + builtin-IO.process.call + builtin-IO.process.call:termlink + builtin-IO.ready.impl.v1 + builtin-IO.ready.impl.v1:termlink + +; Still to implement: +; handlePosition.impl.v3 +; isSeekable.impl.v3 +; getChar.impl.v1 + ) + +; typeLink msg any +(define (Exception typeLink message payload) + (let* ([a (unison-any-any payload)] + [msg (string->chunked-string message)] + [f (ref-failure-failure typeLink msg a)]) + (ref-either-left f))) + +(define-unison-builtin + (builtin-IO.isFileOpen.impl.v3 port) + (ref-either-right (not (port-closed? port)))) + +(define-unison-builtin + (builtin-IO.ready.impl.v1 port) + (if (byte-ready? port) + (ref-either-right #t) + (if (port-eof? port) + (Exception ref-iofailure:typelink "EOF" port) + (ref-either-right #f)))) + +(define-unison-builtin + (builtin-IO.isSeekable.impl.v3 handle) + (ref-either-right + (port-has-set-port-position!? handle))) + +(define-unison-builtin + (builtin-IO.handlePosition.impl.v3 handle) + (ref-either-right (port-position handle))) + +(define-unison-builtin + (builtin-IO.seekHandle.impl.v3 handle mode amount) + (data-case mode + (0 () + (set-port-position! handle amount) + (ref-either-right none)) + (1 () + (let ([current (port-position handle)]) + (set-port-position! handle (+ current amount)) + (ref-either-right none))) + (2 () + (Exception + ref-iofailure:typelink + "SeekFromEnd not supported" + 0)))) + +(define-unison-builtin + (builtin-IO.getLine.impl.v1 handle) + (let* ([line (read-line handle)]) + (if (eof-object? line) + (ref-either-right (string->chunked-string "")) + (ref-either-right (string->chunked-string line)) + ))) + +(define-unison-builtin + (builtin-IO.getChar.impl.v1 handle) + (let* ([char (read-char handle)]) + (if (eof-object? char) + (Exception + ref-iofailure:typelink + "End of file reached" + ref-unit-unit) + (ref-either-right char)))) + +(define-unison-builtin + (builtin-IO.getSomeBytes.impl.v1 handle nbytes) + (let* ([buffer (make-bytes nbytes)] + [line (read-bytes-avail! buffer handle)]) + (cond + [(eof-object? line) + (ref-either-right (bytes->chunked-bytes #""))] + [(procedure? line) + (Exception + ref-iofailure:typelink + "getSomeBytes.impl: special value returned" + ref-unit-unit)] + [else + (ref-either-right + (bytes->chunked-bytes + (if (< line nbytes) + (subbytes buffer 0 line) + buffer)))]))) + +(define-unison-builtin + (builtin-IO.getBuffering.impl.v3 handle) + (case (file-stream-buffer-mode handle) + [(none) (ref-either-right ref-buffermode-no-buffering)] + [(line) (ref-either-right + ref-buffermode-line-buffering)] + [(block) (ref-either-right + ref-buffermode-block-buffering)] + [(#f) (Exception + ref-iofailure:typelink + "Unable to determine buffering mode of handle" + ref-unit-unit)] + [else (Exception + ref-iofailure:typelink + "Unexpected response from file-stream-buffer-mode" + ref-unit-unit)])) + +(define-unison-builtin + (builtin-IO.setBuffering.impl.v3 handle mode) + (data-case mode + (0 () + (file-stream-buffer-mode handle 'none) + (ref-either-right none)) + (1 () + (file-stream-buffer-mode handle 'line) + (ref-either-right none)) + (2 () + (file-stream-buffer-mode handle 'block) + (ref-either-right none)) + (3 (size) + (Exception + ref-iofailure:typelink + "Sized block buffering not supported" + ref-unit-unit)))) + +(define (with-buffer-mode port mode) + (file-stream-buffer-mode port mode) + port) + +(define stdin (with-buffer-mode (standard-input-port) 'none)) +(define stdout (with-buffer-mode (standard-output-port) 'line)) +(define stderr (with-buffer-mode (standard-error-port) 'line)) + +(define-unison-builtin (builtin-IO.stdHandle sth) + (match sth + [(unison-data r t (list)) + (=> break) + (cond + [(= t ref-stdhandle-stdin:tag) stdin] + [(= t ref-stdhandle-stdout:tag) stdout] + [(= t ref-stdhandle-stderr:tag) stderr] + [else (break)])] + [else + (raise (make-exn:bug "invalid standard handle" sth))])) + +(define-unison-builtin + (builtin-IO.getEcho.impl.v1 handle) + (if (eq? handle stdin) + (ref-either-right (get-stdin-echo)) + (Exception + ref-iofailure:typelink + "getEcho only supported on stdin" + ref-unit-unit))) + +(define-unison-builtin + (builtin-IO.setEcho.impl.v1 handle echo) + (if (eq? handle stdin) + (begin + (if echo + (system "stty echo") + (system "stty -echo")) + (ref-either-right none)) + (Exception + ref-iofailure:typelink + "setEcho only supported on stdin" + ref-unit-unit))) + +(define (get-stdin-echo) + (let ([current (with-output-to-string (lambda () (system "stty -a")))]) + (string-contains? current " echo "))) + +(define-unison-builtin (builtin-IO.openFile.impl.v3 name mode) + (define fn (chunked-string->string name)) + + (match mode + [(unison-data r t _) + (=> break) + (ref-either-right + (cond + [(= t ref-filemode-read:tag) + (open-input-file fn)] + [(= t ref-filemode-write:tag) + (open-output-file fn #:exists 'truncate)] + [(= t ref-filemode-append:tag) + (open-output-file fn #:exists 'append)] + [(= t ref-filemode-readwrite:tag) + (open-input-output-file fn #:exists 'can-update)] + ; break back to outer match + [else (break)]))] + [else + (ref-either-left + (ref-failure-failure + ref-iofailure:typelink + (string->chunked-string "invalid file mode") + (unison-any-any mode)))])) + +;; From https://github.com/sorawee/shlex/blob/5de06500e8c831cfc8dffb99d57a76decc02c569/main.rkt (MIT License) +;; with is a port of https://github.com/python/cpython/blob/bf2f76ec0976c09de79c8827764f30e3b6fba776/Lib/shlex.py#L325 +(define unsafe-pattern #rx"[^a-zA-Z0-9_@%+=:,./-]") +(define (quote-arg s) + (if (non-empty-string? s) + (if (regexp-match unsafe-pattern s) + (string-append "'" (string-replace s "'" "'\"'\"'") "'") + s) + "''")) + +(define-unison-builtin + (builtin-IO.process.call command arguments) + (system/exit-code + (string-join (cons + (chunked-string->string command) + (map (lambda (arg) (quote-arg (chunked-string->string arg))) + (vector->list + (chunked-list->vector arguments)))) + " "))) + +(define-unison-builtin (builtin-Handle.toText h) + (string->chunked-string (describe-value h))) + +(define-unison-builtin (builtin-IO.getBytes.impl.v3 h n) + (with-handlers + ; TODO: seems like we should catch more + [[exn:fail:contract? + (lambda (e) + (ref-either-left + (ref-failure-failure + ref-iofailure:typelink + (exception->string e) + ref-unit-unit)))]] + (ref-either-right + (bytes->chunked-bytes + (read-bytes n h))))) + +(define-unison-builtin (builtin-IO.putBytes.impl.v3 h bs) + ; TODO: error checking? + (write-bytes (chunked-bytes->bytes bs) h) + (flush-output h) + (ref-either-right ref-unit-unit)) + +(define-unison-builtin (builtin-IO.closeFile.impl.v3 h) + ; TODO: review this implementation; moved from primops.ss + (if (input-port? h) + (close-input-port h) + (close-output-port h)) + (ref-either-right ref-unit-unit)) + diff --git a/scheme-libs/racket/unison/primops/io.rkt b/scheme-libs/racket/unison/primops/io.rkt new file mode 100644 index 0000000000..cb9265e618 --- /dev/null +++ b/scheme-libs/racket/unison/primops/io.rkt @@ -0,0 +1,320 @@ +#lang racket/base +(require unison/boot + unison/chunked-seq + unison/data + unison/data-info + racket/exn + racket/file + racket/fixnum + racket/flonum + (only-in racket + date-dst? + date-time-zone-offset + date*-time-zone-name + false? + vector-map) + racket/random + (only-in + rnrs/arithmetic/flonums-6 + flmod)) +(require racket/file) + +(provide + builtin-Clock.internals.systemTimeZone.v1 + builtin-Clock.internals.systemTimeZone.v1:termlink + builtin-Clock.internals.monotonic.v1 + builtin-Clock.internals.monotonic.v1:termlink + builtin-Clock.internals.nsec.v1 + builtin-Clock.internals.nsec.v1:termlink + builtin-Clock.internals.processCPUTime.v1 + builtin-Clock.internals.processCPUTime.v1:termlink + builtin-Clock.internals.realtime.v1 + builtin-Clock.internals.realtime.v1:termlink + builtin-Clock.internals.sec.v1 + builtin-Clock.internals.sec.v1:termlink + builtin-Clock.internals.threadCPUTime.v1 + builtin-Clock.internals.threadCPUTime.v1:termlink + + builtin-IO.getFileTimestamp.impl.v3 + builtin-IO.getFileTimestamp.impl.v3:termlink + builtin-IO.getFileSize.impl.v3 + builtin-IO.getFileSize.impl.v3:termlink + builtin-IO.getTempDirectory.impl.v3 + builtin-IO.getTempDirectory.impl.v3:termlink + builtin-IO.randomBytes + builtin-IO.randomBytes:termlink + builtin-IO.removeFile.impl.v3 + builtin-IO.removeFile.impl.v3:termlink + builtin-IO.systemTimeMicroseconds.v1 + builtin-IO.systemTimeMicroseconds.v1:termlink + builtin-IO.tryEval + builtin-IO.tryEval:termlink + + builtin-IO.isFileEOF.impl.v3 + builtin-IO.isFileEOF.impl.v3:termlink + builtin-IO.fileExists.impl.v3 + builtin-IO.fileExists.impl.v3:termlink + builtin-IO.renameFile.impl.v3 + builtin-IO.renameFile.impl.v3:termlink + builtin-IO.createDirectory.impl.v3 + builtin-IO.createDirectory.impl.v3:termlink + builtin-IO.removeDirectory.impl.v3 + builtin-IO.removeDirectory.impl.v3:termlink + builtin-IO.directoryContents.impl.v3 + builtin-IO.directoryContents.impl.v3:termlink + builtin-IO.setCurrentDirectory.impl.v3 + builtin-IO.setCurrentDirectory.impl.v3:termlink + builtin-IO.renameDirectory.impl.v3 + builtin-IO.renameDirectory.impl.v3:termlink + builtin-IO.isDirectory.impl.v3 + builtin-IO.isDirectory.impl.v3:termlink + builtin-IO.systemTime.impl.v3 + builtin-IO.systemTime.impl.v3:termlink + builtin-IO.systemTimeMicroseconds.impl.v3 + builtin-IO.systemTimeMicroseconds.impl.v3:termlink + builtin-IO.createTempDirectory.impl.v3 + builtin-IO.createTempDirectory.impl.v3:termlink + + builtin-IO.getArgs.impl.v1 + builtin-IO.getArgs.impl.v1:termlink + builtin-IO.getEnv.impl.v1 + builtin-IO.getEnv.impl.v1:termlink + builtin-IO.getCurrentDirectory.impl.v3 + builtin-IO.getCurrentDirectory.impl.v3:termlink + + ) + +(define (failure-result ty msg vl) + (ref-either-left + (ref-failure-failure + ty + (string->chunked-string msg) + (unison-any-any vl)))) + +(define (exn-failure e) + (failure-result + ref-iofailure:typelink + (exn->string e) + ref-unit-unit)) + +(define-unison-builtin (builtin-IO.getFileSize.impl.v3 path) + (with-handlers + [[exn:fail:filesystem? exn-failure]] + (ref-either-right (file-size (chunked-string->string path))))) + +(define-unison-builtin (builtin-IO.getFileTimestamp.impl.v3 path) + (with-handlers + [[exn:fail:filesystem? exn-failure]] + (ref-either-right + (file-or-directory-modify-seconds + (chunked-string->string path))))) + +; in haskell, it's not just file but also directory +(define-unison-builtin + (builtin-IO.fileExists.impl.v3 path) + (let ([path-string (chunked-string->string path)]) + (ref-either-right + (or + (file-exists? path-string) + (directory-exists? path-string))))) + +(define-unison-builtin (builtin-IO.removeFile.impl.v3 path) + (delete-file (chunked-string->string path)) + (ref-either-right ref-unit-unit)) + +(define-unison-builtin (builtin-IO.getTempDirectory.impl.v3 _) + (ref-either-right + (string->chunked-string + (path->string (find-system-path 'temp-dir))))) + +(define-unison-builtin + (builtin-IO.setCurrentDirectory.impl.v3 path) + (current-directory (chunked-string->string path)) + (ref-either-right none)) + +(define-unison-builtin + (builtin-IO.directoryContents.impl.v3 path) + (with-handlers + [[exn:fail:filesystem? + (lambda (e) + (failure-result + ref-iofailure:typelink + (exception->string e) + ref-unit-unit))]] + (let* ([dirps (directory-list (chunked-string->string path))] + [dirss (map path->string dirps)]) + (ref-either-right + (vector->chunked-list + (list->vector + (map + string->chunked-string + (list* "." ".." dirss)))))))) + + +(define-unison-builtin + (builtin-IO.createTempDirectory.impl.v3 prefix) + (ref-either-right + (string->chunked-string + (path->string + (make-temporary-directory* + (string->bytes/utf-8 + (chunked-string->string prefix)) #""))))) + +(define-unison-builtin + (builtin-IO.createDirectory.impl.v3 file) + (make-directory (chunked-string->string file)) + (ref-either-right none)) + +(define-unison-builtin + (builtin-IO.removeDirectory.impl.v3 file) + (delete-directory/files (chunked-string->string file)) + (ref-either-right none)) + +(define-unison-builtin + (builtin-IO.isDirectory.impl.v3 path) + (ref-either-right + (directory-exists? (chunked-string->string path)))) + +(define-unison-builtin + (builtin-IO.renameDirectory.impl.v3 old new) + (rename-file-or-directory (chunked-string->string old) + (chunked-string->string new)) + (ref-either-right none)) + +(define-unison-builtin + (builtin-IO.renameFile.impl.v3 old new) + (rename-file-or-directory (chunked-string->string old) + (chunked-string->string new)) + (ref-either-right none)) + +(define-unison-builtin + (builtin-IO.systemTime.impl.v3 unit) + (ref-either-right (current-seconds))) + +(define-unison-builtin + (builtin-IO.systemTimeMicroseconds.impl.v3 unit) + (ref-either-right (inexact->exact (* 1000 (current-inexact-milliseconds))))) + +(define-unison-builtin + (builtin-Clock.internals.systemTimeZone.v1 secs) + (let* ([d (seconds->date secs)]) + (list->unison-tuple + (list + (date-time-zone-offset d) + (if (date-dst? d) 1 0) + (date*-time-zone-name d))))) + +(define-unison-builtin (builtin-Clock.internals.threadCPUTime.v1 _) + (ref-either-right + (integer->time + (current-process-milliseconds (current-thread))))) + +(define-unison-builtin (builtin-Clock.internals.processCPUTime.v1 _) + (ref-either-right + (integer->time + (current-process-milliseconds #f)))) + +(define-unison-builtin (builtin-Clock.internals.realtime.v1 _) + (ref-either-right + (float->time + (current-inexact-milliseconds)))) + +(define-unison-builtin (builtin-Clock.internals.monotonic.v1 _) + (ref-either-right + (float->time + (current-inexact-monotonic-milliseconds)))) + +(define (integer->time msecs) + (unison-timespec + (truncate (/ msecs 1000)) + (* (modulo msecs 1000) 1000000))) + +(define (float->time msecs) + (unison-timespec + (trunc (/ msecs 1000)) + (trunc (* (flmod msecs 1000.0) 1000000)))) + +; +(define (trunc f) (inexact->exact (truncate f))) + +(define-unison-builtin (builtin-Clock.internals.sec.v1 ts) + (unison-timespec-sec ts)) + +(define-unison-builtin (builtin-Clock.internals.nsec.v1 ts) + (unison-timespec-nsec ts)) + +(define-unison-builtin (builtin-IO.systemTimeMicroseconds.v1 _) + (current-microseconds)) + +(define-unison-builtin (builtin-IO.tryEval thunk) + (with-handlers + ([exn:break? + (lambda (e) + (raise-unison-exception + ref-threadkilledfailure:typelink + (string->chunked-string "thread killed") + ref-unit-unit))] + [exn:io? + (lambda (e) + (raise-unison-exception + ref-iofailure:typelink + (exception->string e) + ref-unit-unit))] + [exn:arith? + (lambda (e) + (raise-unison-exception + ref-arithfailure:typelink + (exception->string e) + ref-unit-unit))] + [exn:bug? (lambda (e) (exn:bug->exception e))] + [exn:fail? + (lambda (e) + (raise-unison-exception + ref-runtimefailure:typelink + (exception->string e) + ref-unit-unit))] + [(lambda (x) #t) + (lambda (e) + (raise-unison-exception + ref-miscfailure:typelink + (exception->string e) + ref-unit-unit))]) + (thunk ref-unit-unit))) + +(define-unison-builtin (builtin-IO.randomBytes n) + (bytes->chunked-bytes (crypto-random-bytes n))) + +(define-unison-builtin (builtin-IO.isFileEOF.impl.v3 p) + (ref-either-right (eof-object? (peek-byte p)))) + +(define-unison-builtin (builtin-IO.getArgs.impl.v1 unit) + (ref-either-right + (vector->chunked-list + (vector-map string->chunked-string + (current-command-line-arguments))))) + +(define-unison-builtin (builtin-IO.getEnv.impl.v1 key) + (define value + (environment-variables-ref + (current-environment-variables) + (string->bytes/utf-8 (chunked-string->string key)))) + + (if (false? value) + (ref-either-left + (ref-failure-failure + ref-iofailure:typelink + "environmental variable not found" + (unison-any-any key))) + + (ref-either-right + (string->chunked-string (bytes->string/utf-8 value))))) + +(define-unison-builtin (builtin-IO.getCurrentDirectory.impl.v3 unit) + (ref-either-right + (string->chunked-string (path->string (current-directory))))) + + + +(define (current-microseconds) + (fl->fx (* 1000 (current-inexact-milliseconds)))) + diff --git a/scheme-libs/racket/unison/primops/list.rkt b/scheme-libs/racket/unison/primops/list.rkt new file mode 100644 index 0000000000..cb7b52dab8 --- /dev/null +++ b/scheme-libs/racket/unison/primops/list.rkt @@ -0,0 +1,83 @@ + +#lang racket/base + +(require unison/boot + unison/chunked-seq + unison/data + unison/data-info) + +(provide + builtin-List.++ + builtin-List.++:termlink + builtin-List.at + builtin-List.at:termlink + builtin-List.cons + builtin-List.cons:termlink + builtin-List.drop + builtin-List.drop:termlink + builtin-List.size + builtin-List.size:termlink + builtin-List.snoc + builtin-List.snoc:termlink + builtin-List.splitLeft + builtin-List.splitLeft:termlink + builtin-List.splitRight + builtin-List.splitRight:termlink + builtin-List.take + builtin-List.take:termlink + builtin-List.viewl + builtin-List.viewl:termlink + builtin-List.viewr + builtin-List.viewr:termlink) + + +(define-unison-builtin (builtin-List.++ xs ys) + (chunked-list-append xs ys)) + +(define-unison-builtin (builtin-List.at n xs) + (with-handlers + ([exn:fail:contract? (lambda (e) ref-optional-none)]) + (ref-optional-some (chunked-list-ref xs n)))) + +(define-unison-builtin (builtin-List.cons x xs) + (chunked-list-add-first xs x)) + +(define-unison-builtin (builtin-List.drop n xs) + (chunked-list-drop xs n)) + +(define-unison-builtin (builtin-List.size xs) + (chunked-list-length xs)) + +(define-unison-builtin (builtin-List.snoc xs x) + (chunked-list-add-last xs x)) + +(define-unison-builtin (builtin-List.take n xs) + (chunked-list-take xs n)) + +(define-unison-builtin (builtin-List.viewl xs) + (if (chunked-list-empty? xs) + ref-seqview-empty + (let-values ([(t h) (chunked-list-pop-first xs)]) + (ref-seqview-elem h t)))) + +(define-unison-builtin (builtin-List.viewr xs) + (if (chunked-list-empty? xs) + ref-seqview-empty + (let-values ([(t h) (chunked-list-pop-last xs)]) + (ref-seqview-elem t h)))) + +(define-unison-builtin (builtin-List.splitLeft n s) + (if (< (chunked-list-length s) n) + ref-seqview-empty + (let-values ([(l r) (chunked-list-split-at s n)]) + (ref-seqview-elem l r)))) + +; Copied TODO: write test that stresses this +(define-unison-builtin (builtin-List.splitRight n s) + (define len (chunked-list-length s)) + + (if (< len n) + ref-seqview-empty + (let-values ([(l r) (chunked-list-split-at s (- len n))]) + (ref-seqview-elem l r)))) + diff --git a/scheme-libs/racket/unison/primops/math.rkt b/scheme-libs/racket/unison/primops/math.rkt new file mode 100644 index 0000000000..94aa47f7d8 --- /dev/null +++ b/scheme-libs/racket/unison/primops/math.rkt @@ -0,0 +1,493 @@ +#lang racket/base + +(require unison/boot + unison/chunked-seq + unison/data + unison/data-info + + (except-in math/base sum) + + racket/fixnum + racket/flonum + + (only-in racket/string + string-contains? + string-replace) + + (only-in rnrs/arithmetic/bitwise-6 + bitwise-bit-count + bitwise-first-bit-set)) + +(provide + builtin-Float.+ + builtin-Float.+:termlink + builtin-Float.* + builtin-Float.*:termlink + builtin-Float.- + builtin-Float.-:termlink + builtin-Float./ + builtin-Float./:termlink + builtin-Float.>= + builtin-Float.>=:termlink + builtin-Float.<= + builtin-Float.<=:termlink + builtin-Float.> + builtin-Float.>:termlink + builtin-Float.< + builtin-Float.<:termlink + builtin-Float.== + builtin-Float.==:termlink + builtin-Float.abs + builtin-Float.abs:termlink + builtin-Float.acos + builtin-Float.acos:termlink + builtin-Float.acosh + builtin-Float.acosh:termlink + builtin-Float.asin + builtin-Float.asin:termlink + builtin-Float.asinh + builtin-Float.asinh:termlink + builtin-Float.atan + builtin-Float.atan:termlink + builtin-Float.atan2 + builtin-Float.atan2:termlink + builtin-Float.atanh + builtin-Float.atanh:termlink + builtin-Float.cos + builtin-Float.cos:termlink + builtin-Float.cosh + builtin-Float.cosh:termlink + builtin-Float.fromText + builtin-Float.fromText:termlink + builtin-Float.sin + builtin-Float.sin:termlink + builtin-Float.sinh + builtin-Float.sinh:termlink + builtin-Float.toText + builtin-Float.toText:termlink + builtin-Float.truncate + builtin-Float.truncate:termlink + builtin-Float.exp + builtin-Float.exp:termlink + builtin-Float.fromRepresentation + builtin-Float.fromRepresentation:termlink + builtin-Float.log + builtin-Float.log:termlink + builtin-Float.max + builtin-Float.max:termlink + builtin-Float.min + builtin-Float.min:termlink + builtin-Float.pow + builtin-Float.pow:termlink + builtin-Float.sqrt + builtin-Float.sqrt:termlink + builtin-Float.tan + builtin-Float.tan:termlink + builtin-Float.tanh + builtin-Float.tanh:termlink + builtin-Float.toRepresentation + builtin-Float.toRepresentation:termlink + builtin-Float.logBase + builtin-Float.logBase:termlink + builtin-Float.fromRepresentation + builtin-Float.fromRepresentation:termlink + builtin-Float.toRepresentation + builtin-Float.toRepresentation:termlink + builtin-Float.ceiling + builtin-Float.ceiling:termlink + + + builtin-Int.+ + builtin-Int.+:termlink + builtin-Int.* + builtin-Int.*:termlink + builtin-Int.- + builtin-Int.-:termlink + builtin-Int./ + builtin-Int./:termlink + builtin-Int.== + builtin-Int.==:termlink + builtin-Int.< + builtin-Int.<:termlink + builtin-Int.<= + builtin-Int.<=:termlink + builtin-Int.> + builtin-Int.>:termlink + builtin-Int.>= + builtin-Int.>=:termlink + builtin-Int.and + builtin-Int.and:termlink + builtin-Int.complement + builtin-Int.complement:termlink + builtin-Int.fromRepresentation + builtin-Int.fromRepresentation:termlink + builtin-Int.fromText + builtin-Int.fromText:termlink + builtin-Int.increment + builtin-Int.increment:termlink + builtin-Int.isEven + builtin-Int.isEven:termlink + builtin-Int.isOdd + builtin-Int.isOdd:termlink + builtin-Int.leadingZeros + builtin-Int.leadingZeros:termlink + builtin-Int.mod + builtin-Int.mod:termlink + builtin-Int.negate + builtin-Int.negate:termlink + builtin-Int.or + builtin-Int.or:termlink + builtin-Int.popCount + builtin-Int.popCount:termlink + builtin-Int.shiftLeft + builtin-Int.shiftLeft:termlink + builtin-Int.shiftRight + builtin-Int.shiftRight:termlink + builtin-Int.signum + builtin-Int.signum:termlink + builtin-Int.toFloat + builtin-Int.toFloat:termlink + builtin-Int.toRepresentation + builtin-Int.toRepresentation:termlink + builtin-Int.toText + builtin-Int.toText:termlink + builtin-Int.truncate0 + builtin-Int.truncate0:termlink + builtin-Int.xor + builtin-Int.xor:termlink + builtin-Int.pow + builtin-Int.pow:termlink + builtin-Int.trailingZeros + builtin-Int.trailingZeros:termlink + + + builtin-Nat.+ + builtin-Nat.+:termlink + builtin-Nat.* + builtin-Nat.*:termlink + builtin-Nat./ + builtin-Nat./:termlink + builtin-Nat.== + builtin-Nat.==:termlink + builtin-Nat.< + builtin-Nat.<:termlink + builtin-Nat.<= + builtin-Nat.<=:termlink + builtin-Nat.> + builtin-Nat.>:termlink + builtin-Nat.>= + builtin-Nat.>=:termlink + builtin-Nat.and + builtin-Nat.and:termlink + builtin-Nat.complement + builtin-Nat.complement:termlink + builtin-Nat.drop + builtin-Nat.drop:termlink + builtin-Nat.increment + builtin-Nat.increment:termlink + builtin-Nat.isEven + builtin-Nat.isEven:termlink + builtin-Nat.isOdd + builtin-Nat.isOdd:termlink + builtin-Nat.fromText + builtin-Nat.fromText:termlink + builtin-Nat.leadingZeros + builtin-Nat.leadingZeros:termlink + builtin-Nat.mod + builtin-Nat.mod:termlink + builtin-Nat.or + builtin-Nat.or:termlink + builtin-Nat.popCount + builtin-Nat.popCount:termlink + builtin-Nat.pow + builtin-Nat.pow:termlink + builtin-Nat.shiftLeft + builtin-Nat.shiftLeft:termlink + builtin-Nat.shiftRight + builtin-Nat.shiftRight:termlink + builtin-Nat.sub + builtin-Nat.sub:termlink + builtin-Nat.toFloat + builtin-Nat.toFloat:termlink + builtin-Nat.toInt + builtin-Nat.toInt:termlink + builtin-Nat.toText + builtin-Nat.toText:termlink + builtin-Nat.trailingZeros + builtin-Nat.trailingZeros:termlink + builtin-Nat.xor + builtin-Nat.xor:termlink) + + +(define-unison-builtin (builtin-Float.* x y) (fl* x y)) + +(define-unison-builtin (builtin-Float.+ x y) (fl+ x y)) + +(define-unison-builtin (builtin-Float.- x y) (fl- x y)) + +(define-unison-builtin (builtin-Float./ x y) (fl/ x y)) + +(define-unison-builtin (builtin-Float.> x y) (fl> x y)) + +(define-unison-builtin (builtin-Float.< x y) (fl< x y)) + +(define-unison-builtin (builtin-Float.>= x y) (fl>= x y)) + +(define-unison-builtin (builtin-Float.<= x y) (fl<= x y)) + +(define-unison-builtin (builtin-Float.== x y) (fl= x y)) + +(define-unison-builtin (builtin-Float.abs x) (flabs x)) + +(define-unison-builtin (builtin-Float.acos x) (flacos x)) + +(define-unison-builtin (builtin-Float.acosh x) (acosh x)) + +(define-unison-builtin (builtin-Float.asin x) (flasin x)) + +(define-unison-builtin (builtin-Float.asinh x) (asinh x)) + +(define-unison-builtin (builtin-Float.atan x) (flatan x)) + +(define-unison-builtin (builtin-Float.atan2 y x) (atan y x)) + +(define-unison-builtin (builtin-Float.atanh x) (atanh x)) + +(define-unison-builtin (builtin-Float.cos x) (flcos x)) + +(define-unison-builtin (builtin-Float.cosh x) (cosh x)) + +(define-unison-builtin (builtin-Float.fromText t) + (define mn (string->number (chunked-string->string t))) + + (if mn + (ref-optional-some mn) + ref-optional-none)) + +(define-unison-builtin (builtin-Float.sin x) (flsin x)) + +(define-unison-builtin (builtin-Float.sinh x) (sinh x)) + +(define-unison-builtin (builtin-Float.toText x) + (define base (number->string x)) + (define dotted + (if (string-contains? base ".") + base + (string-replace base "e" ".0e"))) + + (string->chunked-string + (string-replace dotted "+" ""))) + +(define-unison-builtin (builtin-Float.truncate x) + (cond + [(or (= x +inf.0) + (= x -inf.0) + (eqv? x +nan.0) + (eqv? x +nan.f)) + 0] + [else (clamp-integer (inexact->exact (truncate x)))])) + +(define-unison-builtin (builtin-Float.logBase base num) + (log num base)) + +(define-unison-builtin (builtin-Float.exp n) (exp n)) + +(define-unison-builtin (builtin-Float.log n) (log n)) + +(define-unison-builtin (builtin-Float.max n m) (max n m)) + +(define-unison-builtin (builtin-Float.min n m) (min n m)) + +(define-unison-builtin (builtin-Float.tan n) (tan n)) + +(define-unison-builtin (builtin-Float.tanh n) (tanh n)) + +(define-unison-builtin (builtin-Float.pow n m) (expt n m)) + +(define-unison-builtin (builtin-Float.sqrt x) (sqrt x)) + +(define-unison-builtin (builtin-Float.ceiling x) + (clamp-integer (fl->exact-integer (ceiling x)))) + +; If someone can suggest a better mechanism for these, +; that would be appreciated. +(define-unison-builtin (builtin-Float.toRepresentation fl) + (integer-bytes->integer + (real->floating-point-bytes fl 8 #t) ; big endian + #f ; unsigned + #t)) ; big endian + +(define-unison-builtin (builtin-Float.fromRepresentation n) + (floating-point-bytes->real + (integer->integer-bytes n 8 #f #t) ; unsigned, big endian + #t)) ; big endian + + + +(define-unison-builtin (builtin-Int.toRepresentation i) + (integer-bytes->integer + (integer->integer-bytes i 8 #t #t) ; signed, big endian + #f #t)) ; unsigned, big endian + +(define-unison-builtin (builtin-Int.fromRepresentation n) + (integer-bytes->integer + (integer->integer-bytes n 8 #f #t) ; unsigned, big endian + #t #t)) ; signed, big endian + +(define-unison-builtin (builtin-Int.and i j) (bitwise-and i j)) + +(define-unison-builtin (builtin-Int.complement i) + (clamp-integer (bitwise-not i))) + +(define-unison-builtin (builtin-Int.fromText t) + (define mn (string->number (chunked-string->string t))) + + (if (and (exact-integer? mn) (>= mn nbit63) (< mn bit63)) + (ref-optional-some mn) + ref-optional-none)) + +; more complicated due to negatives +(define-unison-builtin (builtin-Int.leadingZeros i) + (define len (integer-length i)) + (if (< len 0) + 0 + (- 64 len))) + +(define-unison-builtin (builtin-Int.mod i j) + (clamp-integer (modulo i j))) + +(define-unison-builtin (builtin-Int.or i j) (bitwise-ior i j)) + +(define-unison-builtin (builtin-Int.shiftLeft i k) + (clamp-integer (arithmetic-shift i k))) + +(define-unison-builtin (builtin-Int.shiftRight i k) + (arithmetic-shift i (- k))) + +(define-unison-builtin (builtin-Int.toFloat i) (exact->inexact i)) + +(define-unison-builtin (builtin-Int.toText i) + (string->chunked-string (number->string i))) + +(define-unison-builtin (builtin-Int.truncate0 i) (if (< i 0) 0 i)) + +(define-unison-builtin (builtin-Int.xor i j) (bitwise-xor i j)) + +(define-unison-builtin (builtin-Int.* n m) (clamp-integer (* n m))) + +(define-unison-builtin (builtin-Int.pow n m) (clamp-integer (expt n m))) + +(define-unison-builtin (builtin-Int.trailingZeros i) + (define bit (bitwise-first-bit-set i)) + + (if (= -1 bit) 64 bit)) + +; todo: review +(define-unison-builtin (builtin-Int.popCount i) + (modulo (bitwise-bit-count i) 65)) + +(define-unison-builtin (builtin-Int.increment i) + (clamp-integer (add1 i))) + +(define-unison-builtin (builtin-Int.negate i) + (if (> i nbit63) (- i) i)) + +(define-unison-builtin (builtin-Int.+ i j) (clamp-integer (+ i j))) + +(define-unison-builtin (builtin-Int.- i j) (clamp-integer (- i j))) + +(define-unison-builtin (builtin-Int./ i j) (floor (/ i j))) + +(define-unison-builtin (builtin-Int.signum i) (sgn i)) + +(define-unison-builtin (builtin-Int.> x y) (> x y)) + +(define-unison-builtin (builtin-Int.< x y) (< x y)) + +(define-unison-builtin (builtin-Int.>= x y) (>= x y)) + +(define-unison-builtin (builtin-Int.<= x y) (<= x y)) + +(define-unison-builtin (builtin-Int.== x y) (= x y)) + +(define-unison-builtin (builtin-Int.isEven x) (even? x)) + +(define-unison-builtin (builtin-Int.isOdd x) (odd? x)) + + + +(define-unison-builtin (builtin-Nat.> x y) (> x y)) + +(define-unison-builtin (builtin-Nat.< x y) (< x y)) + +(define-unison-builtin (builtin-Nat.>= x y) (>= x y)) + +(define-unison-builtin (builtin-Nat.<= x y) (<= x y)) + +(define-unison-builtin (builtin-Nat.== x y) (= x y)) + +(define-unison-builtin (builtin-Nat.isEven x) (even? x)) + +(define-unison-builtin (builtin-Nat.isOdd x) (odd? x)) + +(define-unison-builtin (builtin-Nat.+ m n) (clamp-natural (+ m n))) + +(define-unison-builtin (builtin-Nat.drop m n) (natural-max0 (- m n))) + +(define-unison-builtin (builtin-Nat.increment n) + (clamp-natural (add1 n))) + +(define-unison-builtin (builtin-Nat.* m n) (clamp-natural (* m n))) + +(define-unison-builtin (builtin-Nat./ m n) (quotient m n)) + +(define-unison-builtin (builtin-Nat.and m n) (bitwise-and m n)) + +(define-unison-builtin (builtin-Nat.toFloat n) (->fl n)) + +(define-unison-builtin (builtin-Nat.complement m) + (wrap-natural (bitwise-not m))) + +(define-unison-builtin (builtin-Nat.fromText t) + (define mn (string->number (chunked-string->string t))) + + (if (and (exact-nonnegative-integer? mn) (< mn bit64)) + (ref-optional-some mn) + ref-optional-none)) + +(define-unison-builtin (builtin-Nat.leadingZeros m) + (- 64 (integer-length m))) + +(define-unison-builtin (builtin-Nat.mod m n) (modulo m n)) + +(define-unison-builtin (builtin-Nat.or m n) (bitwise-ior m n)) + +(define-unison-builtin (builtin-Nat.pow m n) + (clamp-natural (expt m n))) + +(define-unison-builtin (builtin-Nat.shiftLeft m k) + (clamp-natural (arithmetic-shift m k))) + +(define-unison-builtin (builtin-Nat.shiftRight m k) + (arithmetic-shift m (- k))) + +(define-unison-builtin (builtin-Nat.sub m n) + (clamp-integer (- m n))) + +(define-unison-builtin (builtin-Nat.toInt m) + ; might need to wrap + (clamp-integer m)) + +(define-unison-builtin (builtin-Nat.toText m) + (string->chunked-string (number->string m))) + +(define-unison-builtin (builtin-Nat.xor m n) (bitwise-xor m n)) + +(define-unison-builtin (builtin-Nat.trailingZeros n) + (define bit (bitwise-first-bit-set n)) + + (if (= -1 bit) 64 bit)) + +(define-unison-builtin (builtin-Nat.popCount n) + (bitwise-bit-count n)) + diff --git a/scheme-libs/racket/unison/primops/misc.rkt b/scheme-libs/racket/unison/primops/misc.rkt new file mode 100644 index 0000000000..17a49bd083 --- /dev/null +++ b/scheme-libs/racket/unison/primops/misc.rkt @@ -0,0 +1,128 @@ + +#lang racket/base + +(require unison/boot + unison/chunked-seq + unison/data + unison/data-info + unison/murmurhash) + +(require racket/match) + +(provide + builtin-Boolean.not + builtin-Boolean.not:termlink + + builtin-Any.Any + builtin-Any.Any:termlink + builtin-Any.unsafeExtract + builtin-Any.unsafeExtract:termlink + + builtin-Debug.toText + builtin-Debug.toText:termlink + builtin-Debug.trace + builtin-Debug.trace:termlink + builtin-Debug.watch + builtin-Debug.watch:termlink + + builtin-Scope.run + builtin-Scope.run:termlink + + builtin-bug + builtin-bug:termlink + + builtin-Universal.murmurHash:termlink + + builtin-unsafe.coerceAbilities + builtin-unsafe.coerceAbilities:termlink + + builtin-jumpCont + builtin-jumpCont:termlink + builtin-todo + builtin-todo:termlink + + builtin-Link.Term.toText + builtin-Link.Term.toText:termlink + + builtin-Value.toBuiltin + builtin-Value.toBuiltin:termlink + builtin-Value.fromBuiltin + builtin-Value.fromBuiltin:termlink + builtin-Code.fromGroup + builtin-Code.fromGroup:termlink + builtin-Code.toGroup + builtin-Code.toGroup:termlink + builtin-TermLink.fromReferent + builtin-TermLink.fromReferent:termlink + builtin-TermLink.toReferent + builtin-TermLink.toReferent:termlink + builtin-TypeLink.toReference + builtin-TypeLink.toReference:termlink + + + ; fake builtins + builtin-murmurHashBytes) + + + +(define-unison-builtin (builtin-Boolean.not b) (not b)) + +(define-unison-builtin (builtin-Any.Any x) (unison-any-any x)) + +(define-unison-builtin (builtin-Any.unsafeExtract x) + (match x + [(unison-data r t (list x)) x])) + +(define-unison-builtin (builtin-Debug.toText v) + (ref-optional-some + (ref-either-left + (string->chunked-string + (describe-value v))))) + +(define-unison-builtin (builtin-Debug.trace msg v) + (display "trace: ") + (displayln (chunked-string->string msg)) + (displayln (describe-value v)) + ref-unit-unit) + +(define-unison-builtin (builtin-Debug.watch msg v) + (displayln (chunked-string->string msg)) + v) + +(define-unison-builtin (builtin-bug x) + (raise (make-exn:bug "builtin.bug" x))) + +(define-unison-builtin (builtin-jumpCont k v) (k v)) + +(define-unison-builtin (builtin-todo x) + (raise (make-exn:bug "builtin.todo" x))) + +(define-unison-builtin (builtin-Scope.run k) + (k ref-unit-unit)) + +(define-builtin-link Universal.murmurHash) + +(define-unison-builtin (builtin-murmurHashBytes bs) + (murmurhash-bytes (chunked-bytes->bytes bs))) + +(define-unison-builtin (builtin-unsafe.coerceAbilities f) f) + +(define-unison-builtin (builtin-Link.Term.toText ln) + (string->chunked-string (termlink->string ln))) + +(define-unison-builtin (builtin-Value.toBuiltin v) (unison-quote v)) +(define-unison-builtin (builtin-Value.fromBuiltin v) + (unison-quote-val v)) +(define-unison-builtin (builtin-Code.fromGroup sg) (unison-code sg)) +(define-unison-builtin (builtin-Code.toGroup co) + (unison-code-rep co)) +(define-unison-builtin (builtin-TermLink.fromReferent rf) + (referent->termlink rf)) +(define-unison-builtin (builtin-TermLink.toReferent tl) + (termlink->referent tl)) +(define-unison-builtin (builtin-TypeLink.toReference tl) + (typelink->reference tl)) + +(define-unison-builtin (builtin-Link.Type.toText ln) + (string->chunked-string (typelink->string ln))) + diff --git a/scheme-libs/racket/unison/primops/pattern.rkt b/scheme-libs/racket/unison/primops/pattern.rkt new file mode 100644 index 0000000000..c06b614977 --- /dev/null +++ b/scheme-libs/racket/unison/primops/pattern.rkt @@ -0,0 +1,213 @@ +#lang racket/base + +(require (except-in unison/boot control) + unison/data + unison/data-info + unison/pattern) + +(provide + builtin-Char.Class.alphanumeric + builtin-Char.Class.alphanumeric:termlink + builtin-Char.Class.and + builtin-Char.Class.and:termlink + builtin-Char.Class.any + builtin-Char.Class.any:termlink + builtin-Char.Class.anyOf + builtin-Char.Class.anyOf:termlink + builtin-Char.Class.control + builtin-Char.Class.control:termlink + builtin-Char.Class.letter + builtin-Char.Class.letter:termlink + builtin-Char.Class.lower + builtin-Char.Class.lower:termlink + builtin-Char.Class.mark + builtin-Char.Class.mark:termlink + builtin-Char.Class.not + builtin-Char.Class.not:termlink + builtin-Char.Class.number + builtin-Char.Class.number:termlink + builtin-Char.Class.or + builtin-Char.Class.or:termlink + builtin-Char.Class.printable + builtin-Char.Class.printable:termlink + builtin-Char.Class.punctuation + builtin-Char.Class.punctuation:termlink + builtin-Char.Class.range + builtin-Char.Class.range:termlink + builtin-Char.Class.separator + builtin-Char.Class.separator:termlink + builtin-Char.Class.symbol + builtin-Char.Class.symbol:termlink + builtin-Char.Class.upper + builtin-Char.Class.upper:termlink + builtin-Char.Class.whitespace + builtin-Char.Class.whitespace:termlink + + builtin-Pattern.capture + builtin-Pattern.capture:termlink + builtin-Pattern.join + builtin-Pattern.join:termlink + builtin-Pattern.many + builtin-Pattern.many:termlink + builtin-Pattern.or + builtin-Pattern.or:termlink + builtin-Pattern.replicate + builtin-Pattern.replicate:termlink + builtin-Pattern.run + builtin-Pattern.run:termlink + + builtin-Char.Class.is + builtin-Char.Class.is:termlink + builtin-Pattern.captureAs + builtin-Pattern.captureAs:termlink + builtin-Pattern.many.corrected + builtin-Pattern.many.corrected:termlink + builtin-Pattern.isMatch + builtin-Pattern.isMatch:termlink + + builtin-Text.patterns.anyChar + builtin-Text.patterns.anyChar:termlink + builtin-Text.patterns.char + builtin-Text.patterns.char:termlink + builtin-Text.patterns.charIn + builtin-Text.patterns.charIn:termlink + builtin-Text.patterns.charRange + builtin-Text.patterns.charRange:termlink + builtin-Text.patterns.digit + builtin-Text.patterns.digit:termlink + builtin-Text.patterns.eof + builtin-Text.patterns.eof:termlink + builtin-Text.patterns.letter + builtin-Text.patterns.letter:termlink + builtin-Text.patterns.literal + builtin-Text.patterns.literal:termlink + builtin-Text.patterns.notCharIn + builtin-Text.patterns.notCharIn:termlink + builtin-Text.patterns.notCharRange + builtin-Text.patterns.notCharRange:termlink + builtin-Text.patterns.punctuation + builtin-Text.patterns.punctuation:termlink + builtin-Text.patterns.space + builtin-Text.patterns.space:termlink) + + +(define-unison-builtin #:hints [value] (builtin-Char.Class.alphanumeric) + alphanumeric) + +(define-unison-builtin (builtin-Char.Class.and l r) + (char-class-and l r)) + +(define-unison-builtin #:hints [value] (builtin-Char.Class.any) + any-char) + +(define-unison-builtin (builtin-Char.Class.anyOf cs) + (chars cs)) + +(define-unison-builtin #:hints [value] (builtin-Char.Class.control) + control) + +(define-unison-builtin #:hints [value] (builtin-Char.Class.letter) + letter) + +(define-unison-builtin #:hints [value] (builtin-Char.Class.lower) + lower) + +(define-unison-builtin #:hints [value] (builtin-Char.Class.mark) + mark) + +(define-unison-builtin (builtin-Char.Class.not c) + (char-class-not c)) + +(define-unison-builtin #:hints [value] (builtin-Char.Class.number) + number) + +(define-unison-builtin (builtin-Char.Class.or l r) + (char-class-or l r)) + +(define-unison-builtin #:hints [value] (builtin-Char.Class.printable) + printable) + +(define-unison-builtin #:hints [value] (builtin-Char.Class.punctuation) + punctuation) + +(define-unison-builtin (builtin-Char.Class.range l u) + (char-range l u)) + +(define-unison-builtin #:hints [value] (builtin-Char.Class.separator) + separator) + +(define-unison-builtin #:hints [value] (builtin-Char.Class.symbol) + symbol) + +(define-unison-builtin #:hints [value] (builtin-Char.Class.upper) + upper) + +(define-unison-builtin #:hints [value] (builtin-Char.Class.whitespace) + space) + + +(define-unison-builtin (builtin-Pattern.capture p) (capture p)) + +(define-unison-builtin (builtin-Pattern.join ps) (join* ps)) + +(define-unison-builtin (builtin-Pattern.many p) (many p)) + +(define-unison-builtin (builtin-Pattern.or l r) (choice l r)) + +(define-unison-builtin (builtin-Pattern.replicate m n p) + (replicate p m n)) + +(define-unison-builtin (builtin-Pattern.run p t) + (let ([r (pattern-match p t)]) + (if r + (ref-optional-some (unison-tuple (cdr r) (car r))) + ref-optional-none))) + + +(define-unison-builtin #:hints [value] (builtin-Text.patterns.anyChar) + any-char) + +(define-unison-builtin (builtin-Text.patterns.char cc) cc) + +(define-unison-builtin (builtin-Text.patterns.charIn cs) + (chars cs)) + +(define-unison-builtin (builtin-Text.patterns.charRange c d) + (char-range c d)) + +(define-unison-builtin #:hints [value] (builtin-Text.patterns.digit) + digit) + +(define-unison-builtin #:hints [value] (builtin-Text.patterns.eof) + eof) + +(define-unison-builtin #:hints [value] (builtin-Text.patterns.letter) + letter) + +(define-unison-builtin (builtin-Text.patterns.literal t) + (literal t)) + +(define-unison-builtin (builtin-Text.patterns.notCharIn cs) + (not-chars cs)) + +(define-unison-builtin (builtin-Text.patterns.notCharRange c d) + (not-char-range c d)) + +(define-unison-builtin #:hints [value] + (builtin-Text.patterns.punctuation) + punctuation) + +(define-unison-builtin #:hints [value] (builtin-Text.patterns.space) + space) + +(define-unison-builtin (builtin-Char.Class.is cc c) + (pattern-match? cc (string->chunked-string (string c)))) + +(define-unison-builtin (builtin-Pattern.captureAs c p) + (capture-as c p)) + +(define-unison-builtin (builtin-Pattern.many.corrected p) (many p)) + +(define-unison-builtin (builtin-Pattern.isMatch p s) + (pattern-match? p s)) + diff --git a/scheme-libs/racket/unison/primops/ref.rkt b/scheme-libs/racket/unison/primops/ref.rkt new file mode 100644 index 0000000000..8b64ec4f9e --- /dev/null +++ b/scheme-libs/racket/unison/primops/ref.rkt @@ -0,0 +1,44 @@ +#lang racket/base + +(require unison/boot + unison/concurrent + unison/data + unison/data-info) + +(provide + builtin-IO.ref + builtin-IO.ref:termlink + builtin-Ref.Ticket.read + builtin-Ref.Ticket.read:termlink + builtin-Ref.cas + builtin-Ref.cas:termlink + builtin-Ref.read + builtin-Ref.read:termlink + builtin-Ref.readForCas + builtin-Ref.readForCas:termlink + builtin-Ref.write + builtin-Ref.write:termlink + builtin-Scope.ref + builtin-Scope.ref:termlink) + + +(define-unison-builtin (builtin-IO.ref v) + (ref-new v)) + +(define-unison-builtin (builtin-Ref.Ticket.read r) r) + +(define-unison-builtin (builtin-Ref.cas ref ticket value) + (ref-cas ref ticket value)) + +(define-unison-builtin (builtin-Ref.read r) + (ref-read r)) + +(define-unison-builtin (builtin-Ref.readForCas r) + (ref-read r)) + +(define-unison-builtin (builtin-Ref.write r v) + (ref-write r v) + ref-unit-unit) + +(define-unison-builtin (builtin-Scope.ref v) + (ref-new v)) diff --git a/scheme-libs/racket/unison/primops/tcp.rkt b/scheme-libs/racket/unison/primops/tcp.rkt new file mode 100644 index 0000000000..4a3c8f3cf6 --- /dev/null +++ b/scheme-libs/racket/unison/primops/tcp.rkt @@ -0,0 +1,150 @@ +; TCP primitives! +#lang racket/base +(require racket/exn + racket/match + racket/tcp + unison/boot + unison/data + unison/data-info + unison/chunked-seq + unison/network-utils) + +(provide + builtin-IO.clientSocket.impl.v3 + builtin-IO.clientSocket.impl.v3:termlink + builtin-IO.closeSocket.impl.v3 + builtin-IO.closeSocket.impl.v3:termlink + builtin-IO.listen.impl.v3 + builtin-IO.listen.impl.v3:termlink + builtin-IO.serverSocket.impl.v3 + builtin-IO.serverSocket.impl.v3:termlink + builtin-IO.socketAccept.impl.v3 + builtin-IO.socketAccept.impl.v3:termlink + builtin-IO.socketPort.impl.v3 + builtin-IO.socketPort.impl.v3:termlink + builtin-IO.socketReceive.impl.v3 + builtin-IO.socketReceive.impl.v3:termlink + builtin-IO.socketSend.impl.v3 + builtin-IO.socketSend.impl.v3:termlink + builtin-Socket.toText + builtin-Socket.toText:termlink) + +(define-unison-builtin (builtin-IO.closeSocket.impl.v3 socket) + (handle-errors + (if (socket-pair? socket) + (begin + (close-input-port (socket-pair-input socket)) + (close-output-port (socket-pair-output socket))) + (tcp-close socket)) + (ref-either-right ref-unit-unit))) + +; string string -> either failure socket-pair +(define-unison-builtin (builtin-IO.clientSocket.impl.v3 host port) + (handle-errors + (let-values + ([(input output) (tcp-connect + (chunked-string->string host) + (string->number + (chunked-string->string port)))]) + (ref-either-right (socket-pair input output))))) + +; socket bytes -> either failure () +(define-unison-builtin (builtin-IO.socketSend.impl.v3 socket data) + (if (not (socket-pair? socket)) + (ref-either-left + (ref-failure-failure + ref-iofailure:typelink + (string->chunked-string "Cannot send on a server socket") + (unison-any-any ref-unit-unit))) + (begin + (write-bytes (chunked-bytes->bytes data) (socket-pair-output socket)) + (flush-output (socket-pair-output socket)) + (ref-either-right ref-unit-unit)))) + +; socket int -> either failure bytes +(define-unison-builtin (builtin-IO.socketReceive.impl.v3 socket amt) + (if (not (socket-pair? socket)) + (ref-either-left + (ref-failure-failure + ref-iofailure:typelink + (string->chunked-string "Cannot receive on a server socket") + (unison-any-any ref-unit-unit))) + + (handle-errors + (define buffer (make-bytes amt)) + (define read + (read-bytes-avail! buffer (socket-pair-input socket))) + + (ref-either-right + (bytes->chunked-bytes (subbytes buffer 0 read)))))) + +; socket -> either failure nat +(define-unison-builtin (builtin-IO.socketPort.impl.v3 socket) + (define-values (_ local-port __ ___) + (tcp-addresses + (if (socket-pair? socket) + (socket-pair-input socket) + socket) + #t)) + + (ref-either-right local-port)) + +(define (left-fail-exn e) + (ref-either-left + (ref-failure-failure + ref-iofailure:typelink + (exception->string e) + (unison-any-any ref-unit-unit)))) + +(define (left-fail-k e) + (ref-either-left + (ref-failure-failure + ref-miscfailure:typelink + (string->chunked-string "Unknown exception") + (unison-any-any ref-unit-unit)))) + +; optional string -> string -> either failure socket +(define-unison-builtin (builtin-IO.serverSocket.impl.v3 mhost cport) + (define hostname + (match mhost + [(unison-data r t (list host)) + #:when (= t ref-optional-some:tag) + (chunked-string->string host)] + [else #f])) + + (define port (chunked-string->string cport)) + + (with-handlers + [[exn:fail:network? left-fail-exn] + [exn:fail:contract? left-fail-exn] + [(lambda _ #t) left-fail-k]] + + (ref-either-right + (tcp-listen + (string->number port) + 2048 + #t + (if (equal? "0" hostname) #f hostname))))) + +; NOTE: This is a no-op because racket's public TCP stack doesn't have separate operations for +; "bind" vs "listen". We've decided to have `serverSocket` do the "bind & listen", and have +; this do nothing. +; If we want ~a little better parity with the haskell implementation, we might set a flag or +; something on the listener, and error if you try to `accept` on a server socket that you haven't +; called `listen` on yet. +(define-unison-builtin (builtin-IO.listen.impl.v3 _listener) + (ref-either-right ref-unit-unit)) + +(define-unison-builtin (builtin-IO.socketAccept.impl.v3 listener) + (if (socket-pair? listener) + (ref-either-left + (ref-failure-failure + ref-iofailure:typelink + (string->chunked-string "Cannot accept on a non-server socket") + (unison-any-any ref-unit-unit))) + + (let-values ([(input output) (tcp-accept listener)]) + (ref-either-right (socket-pair input output))))) + +(define-unison-builtin (builtin-Socket.toText s) + (string->chunked-string (describe-value s))) diff --git a/scheme-libs/racket/unison/primops/text.rkt b/scheme-libs/racket/unison/primops/text.rkt new file mode 100644 index 0000000000..7d4681ceeb --- /dev/null +++ b/scheme-libs/racket/unison/primops/text.rkt @@ -0,0 +1,178 @@ + +#lang racket/base + +(require unison/boot + unison/chunked-seq + (only-in unison/core + chunked-string-foldMap-chunks + chunked-string= + builtin-Text.>=:termlink + builtin-Text.< + builtin-Text.<:termlink + builtin-Text.> + builtin-Text.>:termlink + builtin-Text.++ + builtin-Text.++:termlink + builtin-Text.drop + builtin-Text.drop:termlink + builtin-Text.empty + builtin-Text.empty:termlink + builtin-Text.fromCharList + builtin-Text.fromCharList:termlink + builtin-Text.fromUtf8.impl.v3 + builtin-Text.fromUtf8.impl.v3:termlink + builtin-Text.repeat + builtin-Text.repeat:termlink + builtin-Text.reverse + builtin-Text.reverse:termlink + builtin-Text.size + builtin-Text.size:termlink + builtin-Text.take + builtin-Text.take:termlink + builtin-Text.toCharList + builtin-Text.toCharList:termlink + builtin-Text.toLowercase + builtin-Text.toLowercase:termlink + builtin-Text.toUppercase + builtin-Text.toUppercase:termlink + builtin-Text.toUtf8 + builtin-Text.toUtf8:termlink + builtin-Text.uncons + builtin-Text.uncons:termlink + builtin-Text.unsnoc + builtin-Text.unsnoc:termlink) + + +(define-unison-builtin (builtin-Char.fromNat n) + (integer->char n)) + +(define-unison-builtin (builtin-Char.toNat c) + (char->integer c)) + +(define-unison-builtin (builtin-Char.toText c) + (string->chunked-string (string c))) + +(define-unison-builtin (builtin-Text.repeat n t) + (let loop ([i 0] + [acc empty-chunked-string]) + (if (= i n) + acc + (loop (add1 i) (chunked-string-append acc t))))) + +(define-unison-builtin (builtin-Text.reverse t) + (chunked-string-foldMap-chunks + t + string-reverse + (lambda (acc c) (chunked-string-append c acc)))) + +(define-unison-builtin (builtin-Text.size t) (chunked-string-length t)) + +(define-unison-builtin (builtin-Text.take n t) (chunked-string-take t n)) + +(define-unison-builtin (builtin-Text.toCharList t) + (build-chunked-list + (chunked-string-length t) + (lambda (i) (chunked-string-ref t i)))) + +(define-unison-builtin (builtin-Text.toLowercase t) + (chunked-string-foldMap-chunks t string-downcase chunked-string-append)) + +(define-unison-builtin (builtin-Text.toUppercase t) + (chunked-string-foldMap-chunks t string-upcase chunked-string-append)) + +(define-unison-builtin (builtin-Text.toUtf8 t) + (bytes->chunked-bytes + (string->bytes/utf-8 + (chunked-string->string t)))) + +(define-unison-builtin (builtin-Text.uncons s) + (cond + [(chunked-string-empty? s) ref-optional-none] + [else + (let-values ([(t c) (chunked-string-pop-first s)]) + (ref-optional-some (unison-tuple c t)))])) + +(define-unison-builtin (builtin-Text.unsnoc s) + (cond + [(chunked-string-empty? s) ref-optional-none] + [else + (let-values ([(t c) (chunked-string-pop-last s)]) + (ref-optional-some (unison-tuple t c)))])) + +; Note: chunked-string x y) + (not (chunked-string= x y) (chunked-stringoptional v) + (if v + (ref-optional-some v) + ref-optional-none)) + +(define-unison-builtin (builtin-Text.indexOf n h) + (->optional (chunked-string-index-of h n))) + +(define-unison-builtin (builtin-Text.++ t u) + (chunked-string-append t u)) + +(define-unison-builtin (builtin-Text.drop n t) + (chunked-string-drop t n)) + +(define-unison-builtin #:hints [value] (builtin-Text.empty) + empty-chunked-string) + +(define-unison-builtin (builtin-Text.fromCharList cs) + (build-chunked-string + (chunked-list-length cs) + (lambda (i) (chunked-list-ref cs i)))) + +(define-unison-builtin (builtin-Text.fromUtf8.impl.v3 bs) + (with-handlers + ([exn:fail:contract? + (lambda (e) + (ref-either-left + (ref-failure-failure + ref-iofailure:typelink + (string->chunked-string + (string-append + "Invalid UTF-8 stream: " + (describe-value bs))) + (unison-any-any (exception->string e)))))]) + (ref-either-right + (string->chunked-string + (bytes->string/utf-8 + (chunked-bytes->bytes bs)))))) + diff --git a/scheme-libs/racket/unison/primops/tls.rkt b/scheme-libs/racket/unison/primops/tls.rkt new file mode 100644 index 0000000000..73ad0c4ecd --- /dev/null +++ b/scheme-libs/racket/unison/primops/tls.rkt @@ -0,0 +1,249 @@ +; TLS primitives! Supplied by openssl (libssl) +#lang racket/base +(require racket/exn + racket/string + racket/file + (only-in racket empty?) + compatibility/mlist + unison/boot + unison/data + unison/data-info + unison/chunked-seq + unison/network-utils + unison/pem + x509 + openssl) + +(provide + builtin-Tls.ClientConfig.certificates.set + builtin-Tls.ClientConfig.certificates.set:termlink + builtin-Tls.ClientConfig.default + builtin-Tls.ClientConfig.default:termlink + builtin-Tls.ServerConfig.default + builtin-Tls.ServerConfig.default:termlink + builtin-Tls.decodeCert.impl.v3 + builtin-Tls.decodeCert.impl.v3:termlink + builtin-Tls.decodePrivateKey + builtin-Tls.decodePrivateKey:termlink + builtin-Tls.encodeCert + builtin-Tls.encodeCert:termlink + builtin-Tls.encodePrivateKey + builtin-Tls.encodePrivateKey:termlink + builtin-Tls.handshake.impl.v3 + builtin-Tls.handshake.impl.v3:termlink + builtin-Tls.newClient.impl.v3 + builtin-Tls.newClient.impl.v3:termlink + builtin-Tls.newServer.impl.v3 + builtin-Tls.newServer.impl.v3:termlink + builtin-Tls.receive.impl.v3 + builtin-Tls.receive.impl.v3:termlink + builtin-Tls.send.impl.v3 + builtin-Tls.send.impl.v3:termlink + builtin-Tls.terminate.impl.v3 + builtin-Tls.terminate.impl.v3:termlink) + +; Native Representations: +; +; tlsPrivateKey - the "pem" struct defined in pem.rkt +; tlsCertificate - currently the raw bytes + +(define (write-to-tmp-file bytes suffix) + (let* ([tmp (make-temporary-file* #"unison" suffix)] + [of (open-output-file tmp #:exists 'replace)]) + (write-bytes bytes of) + (flush-output of) + (close-output-port of) + tmp)) + +(define-unison-builtin (builtin-Tls.encodePrivateKey privateKey) + (bytes->chunked-bytes + (string->bytes/utf-8 (pem->pem-string privateKey)))) + +; bytes -> list tlsPrivateKey +(define-unison-builtin (builtin-Tls.decodePrivateKey bytes) + (vector->chunked-list + (list->vector ; TODO better conversion + (filter + (lambda (pem) (or + (equal? "PRIVATE KEY" (pem-label pem)) + (equal? "RSA PRIVATE KEY" (pem-label pem)))) + + (pem-string->pems + (bytes->string/utf-8 (chunked-bytes->bytes bytes))))))) + +; bytes -> either failure tlsSignedCert +(define-unison-builtin (builtin-Tls.decodeCert.impl.v3 bytes) + (define certs + (read-pem-certificates + (open-input-bytes (chunked-bytes->bytes bytes)))) + + (if (= 1 (length certs)) + (ref-either-right bytes) + (ref-either-left + (ref-failure-failure + ref-tlsfailure:typelink + (string->chunked-string "Could not decode certificate") + (unison-any-any bytes))))) + +; We don't actually "decode" certificates, we just validate them +(define-unison-builtin (builtin-Tls.encodeCert bytes) bytes) + +(struct server-config (certs key)) ; certs = list certificate; key = privateKey + +(define-unison-builtin + ; list tlsSignedCert tlsPrivateKey -> tlsServerConfig + (builtin-Tls.ServerConfig.default certs key) + (server-config certs key)) + +(struct client-config (host certs)) +(struct tls (config input output)) + +; tlsServerConfig socket -> {io} tls +(define-unison-builtin (builtin-Tls.newServer.impl.v3 config socket-pair) + (handle-errors + (let* ([input (socket-pair-input socket-pair)] + [output (socket-pair-output socket-pair)] + [certs (server-config-certs config)] + [key (server-config-key config)] + [key-bytes (string->bytes/utf-8 (pem->pem-string key))] + [tmp (write-to-tmp-file (chunked-bytes->bytes (chunked-list-ref certs 0)) #".pem")]) + (let*-values ([(ctx) (ssl-make-server-context + ; TODO: Once racket can handle the in-memory PEM bytes, + ; we can do away with writing them out to temporary files. + ; https://github.com/racket/racket/pull/4625 + ; #:private-key (list 'pem key-bytes) + #:private-key (list 'pem (write-to-tmp-file key-bytes #".pem")) + #:certificate-chain tmp)] + [(in out) (ports->ssl-ports + input output + #:mode 'accept + #:context ctx + #:close-original? #t + )]) + (ref-either-right (tls config in out)))))) + +(define-unison-builtin + ; string bytes + (builtin-Tls.ClientConfig.default host service-identification-suffix) + (if (= 0 (chunked-bytes-length service-identification-suffix)) + (client-config host empty-chunked-list) + ; todo: better error? + (error 'NotImplemented + "service-identification-suffix not supported"))) + +(define (ServerConfig.certificates.set certs config) + (server-config certs (server-config-key config))) + +(define-unison-builtin + ; list tlsSignedCert tlsClientConfig -> tlsClientConfig + (builtin-Tls.ClientConfig.certificates.set certs config) + (client-config (client-config-host config) certs)) + +(define (left-fail ty msg val) + (ref-either-left + (ref-failure-failure + ty + (string->chunked-string msg) + (unison-any-any val)))) + +(define ((left-fail-exn ty) e) + (left-fail ty (exn->string e) ref-unit-unit)) + +(define ((left-fail-k ty msg) e) + (left-fail ty msg ref-unit-unit)) + +(define (exn:name-mismatch? e) + (string-contains? (exn->string e) "not valid for hostname")) + +(define (exn:cert-verify? e) + (string-contains? (exn->string e) "certificate verify failed")) + +(define-syntax handle-errors + (syntax-rules () + [(handle-errors ex ...) + (with-handlers + [[exn:fail:network? (left-fail-exn ref-iofailure:typelink)] + [exn:fail:contract? (left-fail-exn ref-miscfailure:typelink)] + [exn:name-mismatch? + (left-fail-k ref-tlsfailure:typelink "NameMismatch")] + [exn:cert-verify? + (left-fail-k ref-tlsfailure:typelink + "certificate verify failed")] + [(lambda _ #t) + (lambda (e) + (left-fail + ref-miscfailure:typelink + (format "Unknown exception ~a" (exn->string e)) + ref-unit-unit))]] + ex ...)])) + +(define-unison-builtin (builtin-Tls.newClient.impl.v3 config socket) + (handle-errors + (let* ([input (socket-pair-input socket)] + [output (socket-pair-output socket)] + [hostname (client-config-host config)] + ; TODO: Make the client context up in ClientConfig.default + ; instead of right here. + [ctx (ssl-make-client-context)] + [certs (client-config-certs config)]) + (ssl-set-verify-hostname! ctx #t) + (ssl-set-ciphers! ctx "DEFAULT:!aNULL:!eNULL:!LOW:!EXPORT:!SSLv2") + (ssl-set-verify! ctx #t) + (if (chunked-list-empty? certs) + (ssl-load-default-verify-sources! ctx) + (let ([tmp (write-to-tmp-file (chunked-bytes->bytes (chunked-list-ref certs 0)) #".pem")]) + (ssl-load-verify-source! ctx tmp))) + (let-values ([(in out) (ports->ssl-ports + input output + #:mode 'connect + #:context ctx + #:hostname (chunked-string->string hostname) + #:close-original? #t + )]) + (ref-either-right (tls config in out)))))) + +(define-unison-builtin (builtin-Tls.handshake.impl.v3 tls) + (handle-errors + (ssl-set-verify! (tls-input tls) #t) + (ref-either-right ref-unit-unit))) + +; data = bytes +(define-unison-builtin (builtin-Tls.send.impl.v3 tls data) + (handle-errors + (let* ([output (tls-output tls)]) + (write-bytes (chunked-bytes->bytes data) output) + (flush-output output) + (ref-either-right ref-unit-unit)))) + +(define (read-more n port) + (let* ([buffer (make-bytes n)] + [read (read-bytes-avail! buffer port)]) + (if (< read n) + (subbytes buffer 0 read) + (bytes-append buffer (read-more (* 2 n) port))))) + +(define (read-all n port) + (let* ([buffer (make-bytes n)] + [read (read-bytes-avail! buffer port)]) + (if (= n read) + (bytes-append buffer (read-more (* 2 n) port)) + (subbytes buffer 0 read)))) + +; -> bytes +(define-unison-builtin (builtin-Tls.receive.impl.v3 tls) + (handle-errors + (ref-either-right + (bytes->chunked-bytes (read-all 4096 (tls-input tls)))))) + +(define-unison-builtin (builtin-Tls.terminate.impl.v3 tls) + ; NOTE: This actually does more than the unison impl, + ; which only sends the `close_notify` message, and doesn't + ; mark the port as no longer usable in the runtime. + ; Not sure if this is an important difference. + ; Racket's openssl lib doesn't expose a way to *just* call + ; SSL_Shutdown on a port without also closing it. + (handle-errors + (ssl-abandon-port (tls-input tls)) + (ssl-abandon-port (tls-output tls)) + (ref-either-right ref-unit-unit))) + diff --git a/scheme-libs/racket/unison/primops/udp.rkt b/scheme-libs/racket/unison/primops/udp.rkt new file mode 100644 index 0000000000..2f1170e01b --- /dev/null +++ b/scheme-libs/racket/unison/primops/udp.rkt @@ -0,0 +1,186 @@ +; UDP primitives! +#lang racket/base +(require racket/udp + racket/format + (only-in unison/boot define-unison-builtin) + unison/data + unison/data-info + unison/chunked-seq + (only-in unison/boot sum-case) + unison/network-utils + unison/core) + +(provide + builtin-IO.UDP.clientSocket.impl.v1 + builtin-IO.UDP.clientSocket.impl.v1:termlink + builtin-IO.UDP.UDPSocket.recv.impl.v1 + builtin-IO.UDP.UDPSocket.recv.impl.v1:termlink + builtin-IO.UDP.UDPSocket.send.impl.v1 + builtin-IO.UDP.UDPSocket.send.impl.v1:termlink + builtin-IO.UDP.UDPSocket.close.impl.v1 + builtin-IO.UDP.UDPSocket.close.impl.v1:termlink + builtin-IO.UDP.ListenSocket.close.impl.v1 + builtin-IO.UDP.ListenSocket.close.impl.v1:termlink + builtin-IO.UDP.UDPSocket.toText.impl.v1 + builtin-IO.UDP.UDPSocket.toText.impl.v1:termlink + builtin-IO.UDP.serverSocket.impl.v1 + builtin-IO.UDP.serverSocket.impl.v1:termlink + builtin-IO.UDP.ListenSocket.toText.impl.v1 + builtin-IO.UDP.ListenSocket.toText.impl.v1:termlink + builtin-IO.UDP.ListenSocket.recvFrom.impl.v1 + builtin-IO.UDP.ListenSocket.recvFrom.impl.v1:termlink + builtin-IO.UDP.ClientSockAddr.toText.v1 + builtin-IO.UDP.ClientSockAddr.toText.v1:termlink + builtin-IO.UDP.ListenSocket.sendTo.impl.v1 + builtin-IO.UDP.ListenSocket.sendTo.impl.v1:termlink) + + +(struct client-sock-addr (host port)) + +; Haskell's Network.UDP choice of buffer size is 2048, so mirror that here +(define buffer-size 2048) + +(define ; a -> Either Failure a + (wrap-in-either a) + (sum-case a + (0 (type msg meta) + (ref-either-left (ref-failure-failure type msg (unison-any-any meta)))) + (1 (data) + (ref-either-right data)))) + +(define + (format-socket socket) + (let*-values ([(local-hn local-port remote-hn remote-port) (udp-addresses socket #t)] + [(rv) (~a "")]) + (string->chunked-string rv))) + +(define (close-socket socket) + (let ([rv (handle-errors (lambda() (begin + (udp-close socket) + (right ref-unit-unit))))]) + (wrap-in-either rv))) + +;; define termlink builtins +(define clientSocket.impl.v1:termlink + (unison-termlink-builtin "IO.UDP.clientSocket.impl.v1")) +(define UDPSocket.recv.impl.v1:termlink + (unison-termlink-builtin "IO.UDP.UDPSocket.recv.impl.v1")) +(define UDPSocket.send.impl.v1:termlink + (unison-termlink-builtin "IO.UDP.UDPSocket.send.impl.v1")) +(define UDPSocket.close.impl.v1:termlink + (unison-termlink-builtin "IO.UDP.UDPSocket.close.impl.v1")) +(define ListenSocket.close.impl.v1:termlink + (unison-termlink-builtin "IO.UDP.ListenSocket.close.impl.v1")) +(define UDPSocket.toText.impl.v1:termlink + (unison-termlink-builtin "IO.UDP.UDPSocket.toText.impl.v1")) +(define serverSocket.impl.v1:termlink + (unison-termlink-builtin "IO.UDP.serverSocket.impl.v1")) +(define ListenSocket.toText.impl.v1:termlink + (unison-termlink-builtin "IO.UDP.ListenSocket.toText.impl.v1")) +(define ListenSocket.recvFrom.impl.v1:termlink + (unison-termlink-builtin "IO.UDP.ListenSocket.recvFrom.impl.v1")) +(define ClientSockAddr.toText.v1:termlink + (unison-termlink-builtin "IO.UDP.ClientSockAddr.toText.v1")) +(define ListenSocket.sendTo.impl.v1:termlink + (unison-termlink-builtin "IO.UDP.ListenSocket.sendTo.impl.v1")) + +;; define builtins + +(define-unison-builtin + (builtin-IO.UDP.UDPSocket.recv.impl.v1 socket) + ; socket -> Either Failure Bytes + (let + ([rv (handle-errors (lambda() + (let*-values + ([(buffer) (make-bytes buffer-size)] + [(len a b) (udp-receive! socket buffer)]) + (right (bytes->chunked-bytes (subbytes buffer 0 len))))))]) + (wrap-in-either rv))) + +(define-unison-builtin + (builtin-IO.UDP.ListenSocket.close.impl.v1 socket) + ; socket -> Either Failure () + (close-socket socket)) + +(define-unison-builtin + (builtin-IO.UDP.serverSocket.impl.v1 ip port) + ; string string -> Either Failure socket + (let + ([result (handle-errors (lambda() + (let* ([iip (chunked-string->string ip)] + [pport (string->number (chunked-string->string port))] + [sock (udp-open-socket iip pport)]) + (begin + (udp-bind! sock iip pport) + (right sock)))))]) + (wrap-in-either result))) + +(define-unison-builtin + (builtin-IO.UDP.ListenSocket.recvFrom.impl.v1 socket) + ; socket -> Either Failure (Bytes, ClientSockAddr) + (let ([result (handle-errors (lambda() + (if (not (udp? socket)) + (raise-argument-error 'socket "a UDP socket" socket) + (let*-values + ([(buffer) (make-bytes buffer-size)] + [(len host port) (udp-receive! socket buffer)] + [(csa) (client-sock-addr host port)] + [(bs) (subbytes buffer 0 len)] + [(chunked) (bytes->chunked-bytes bs)]) + (right (ref-tuple-pair chunked (ref-tuple-pair csa ref-unit-unit)))))))]) + (wrap-in-either result))) + +(define-unison-builtin + (builtin-IO.UDP.UDPSocket.send.impl.v1 socket data) + ; socket -> Bytes -> Either Failure () + (let + ([result (handle-errors (lambda () (begin + (udp-send socket (chunked-bytes->bytes data)) + (right ref-unit-unit))))]) + (wrap-in-either result))) + +(define-unison-builtin + (builtin-IO.UDP.ListenSocket.sendTo.impl.v1 sock bytes addr) + ; socket -> Bytes -> ClientSockAddr -> Either Failure () + (let + ([result (handle-errors (lambda() + (let* ([host (client-sock-addr-host addr)] + [port (client-sock-addr-port addr)] + [bytes (chunked-bytes->bytes bytes)]) + (begin + (udp-send-to sock host port bytes) + (right ref-unit-unit)))))]) + (wrap-in-either result))) + +(define-unison-builtin + (builtin-IO.UDP.UDPSocket.toText.impl.v1 socket) ; socket -> string + (format-socket socket)) + +(define-unison-builtin + (builtin-IO.UDP.ClientSockAddr.toText.v1 addr) + ; ClientSocketAddr -> string + (string->chunked-string (format "" (client-sock-addr-host addr) (client-sock-addr-port addr)))) + +(define-unison-builtin + (builtin-IO.UDP.ListenSocket.toText.impl.v1 socket) + ; socket -> string + (format-socket socket)) + +(define-unison-builtin + (builtin-IO.UDP.UDPSocket.close.impl.v1 socket) + ; socket -> Either Failure () + (let + ([rv (handle-errors (lambda() (begin + (udp-close socket) + (right ref-unit-unit))))]) + (wrap-in-either rv))) + +(define-unison-builtin + (builtin-IO.UDP.clientSocket.impl.v1 host port) + ; string string -> Either Failure socket + (let ([rv (handle-errors (lambda() (let* ([pport (string->number (chunked-string->string port))] + [hhost (chunked-string->string host)] + [sock (udp-open-socket hhost pport)] + [_ (udp-bind! sock #f 0)] + [res (udp-connect! sock hhost pport)]) (right sock))))]) + (wrap-in-either rv))) diff --git a/scheme-libs/racket/unison/primops/universal.rkt b/scheme-libs/racket/unison/primops/universal.rkt new file mode 100644 index 0000000000..cb66e203d1 --- /dev/null +++ b/scheme-libs/racket/unison/primops/universal.rkt @@ -0,0 +1,42 @@ +#lang racket/base + +(require unison/boot + (only-in unison/core + universal=? + universal-compare) + unison/data + unison/data-info) + +(provide + builtin-Universal.== + builtin-Universal.==:termlink + builtin-Universal.> + builtin-Universal.>:termlink + builtin-Universal.>= + builtin-Universal.>=:termlink + builtin-Universal.< + builtin-Universal.<:termlink + builtin-Universal.<= + builtin-Universal.<=:termlink + builtin-Universal.compare + builtin-Universal.compare:termlink) + + +(define-unison-builtin (builtin-Universal.== x y) (universal=? x y)) + +(define-unison-builtin (builtin-Universal.> x y) + (case (universal-compare x y) [(>) #t] [else #f])) + +(define-unison-builtin (builtin-Universal.< x y) + (case (universal-compare x y) [(<) #t] [else #f])) + +(define-unison-builtin (builtin-Universal.<= x y) + (case (universal-compare x y) [(>) #f] [else #t])) + +(define-unison-builtin (builtin-Universal.>= x y) + (case (universal-compare x y) [(<) #f] [else #t])) + +(define-unison-builtin (builtin-Universal.compare x y) + (case (universal-compare x y) + [(>) 1] [(<) -1] [else 0])) + diff --git a/scheme-libs/racket/unison/sandbox.rkt b/scheme-libs/racket/unison/sandbox.rkt index a24c70f2f9..248d0b06e8 100644 --- a/scheme-libs/racket/unison/sandbox.rkt +++ b/scheme-libs/racket/unison/sandbox.rkt @@ -4,7 +4,7 @@ (provide expand-sandbox check-sandbox set-sandbox) (require racket racket/hash) -(require (except-in unison/data true false unit)) +(require unison/data) ; sandboxing information (define sandbox-links (make-hash)) diff --git a/scheme-libs/racket/unison/tcp.rkt b/scheme-libs/racket/unison/tcp.rkt deleted file mode 100644 index 481e36f648..0000000000 --- a/scheme-libs/racket/unison/tcp.rkt +++ /dev/null @@ -1,127 +0,0 @@ -; TCP primitives! -#lang racket/base -(require racket/exn - racket/match - racket/tcp - unison/data - unison/data-info - unison/chunked-seq - unison/network-utils - unison/core) - -(provide - socket-pair-input - socket-pair-output - (prefix-out - unison-FOp-IO. - (combine-out - clientSocket.impl.v3 - closeSocket.impl.v3 - socketReceive.impl.v3 - socketPort.impl.v3 - serverSocket.impl.v3 - listen.impl.v3 - socketAccept.impl.v3 - socketSend.impl.v3))) - -(struct socket-pair (input output)) - -(define (closeSocket.impl.v3 socket) - (handle-errors - (lambda () - (if (socket-pair? socket) - (begin - (close-input-port (socket-pair-input socket)) - (close-output-port (socket-pair-output socket))) - (tcp-close socket)) - (right none)))) - -(define (clientSocket.impl.v3 host port) ; string string -> socket-pair - (handle-errors - (lambda () - (let-values ([(input output) (tcp-connect (chunked-string->string host) (string->number (chunked-string->string port)))]) - (right (socket-pair input output)))))) - -(define (socketSend.impl.v3 socket data) ; socket bytes -> () - (if (not (socket-pair? socket)) - (exception - ref-iofailure:typelink - (string->chunked-string "Cannot send on a server socket") - ref-unit-unit) - (begin - (write-bytes (chunked-bytes->bytes data) (socket-pair-output socket)) - (flush-output (socket-pair-output socket)) - (right none)))) - -(define (socketReceive.impl.v3 socket amt) ; socket int -> bytes - (if (not (socket-pair? socket)) - (exception - ref-iofailure:typelink - (string->chunked-string "Cannot receive on a server socket")) - (handle-errors - (lambda () - (begin - (let* ([buffer (make-bytes amt)] - [read (read-bytes-avail! buffer (socket-pair-input socket))]) - (right (bytes->chunked-bytes (subbytes buffer 0 read))))))))) - -(define (socketPort.impl.v3 socket) - (let-values ([(_ local-port __ ___) (tcp-addresses - (if (socket-pair? socket) - (socket-pair-input socket) - socket) #t)]) - (right local-port))) - -(define serverSocket.impl.v3 ; string -> socket (or) string string -> socket - (lambda args - (let-values ([(hostname port) - (match args - [(list _ port) (values #f (chunked-string->string port))] - [(list _ hostname port) (values - (chunked-string->string hostname) - (chunked-string->string port))])]) - - (with-handlers - [[exn:fail:network? - (lambda (e) - (exception - ref-iofailure:typelink - (exception->string e) - ref-unit-unit))] - [exn:fail:contract? - (lambda (e) - (exception - ref-iofailure:typelink - (exception->string e) - ref-unit-unit))] - [(lambda _ #t) - (lambda (e) - (exception - ref-miscfailure:typelink - (string->chunked-string "Unknown exception") - ref-unit-unit))] ] - (let ([listener (tcp-listen - (string->number port) - 4 - #t - (if (equal? 0 hostname) #f hostname))]) - (right listener)))))) - -; NOTE: This is a no-op because racket's public TCP stack doesn't have separate operations for -; "bind" vs "listen". We've decided to have `serverSocket` do the "bind & listen", and have -; this do nothing. -; If we want ~a little better parity with the haskell implementation, we might set a flag or -; something on the listener, and error if you try to `accept` on a server socket that you haven't -; called `listen` on yet. -(define (listen.impl.v3 _listener) - (right none)) - -(define (socketAccept.impl.v3 listener) - (if (socket-pair? listener) - (exception - ref-iofailure:typelink - (string->chunked-string "Cannot accept on a non-server socket") - ref-unit-unit) - (begin - (let-values ([(input output) (tcp-accept listener)]) - (right (socket-pair input output)))))) diff --git a/scheme-libs/racket/unison/tls.rkt b/scheme-libs/racket/unison/tls.rkt deleted file mode 100644 index 8f7f3b341f..0000000000 --- a/scheme-libs/racket/unison/tls.rkt +++ /dev/null @@ -1,223 +0,0 @@ -; TLS primitives! Supplied by openssl (libssl) -#lang racket/base -(require racket/exn - racket/string - racket/file - (only-in racket empty?) - compatibility/mlist - unison/data - unison/data-info - unison/chunked-seq - unison/core - unison/tcp - unison/pem - x509 - openssl) - -(provide - (prefix-out - unison-FOp-Tls. - (combine-out - ClientConfig.default - ClientConfig.certificates.set - ServerConfig.default - ServerConfig.certificates.set - decodeCert.impl.v3 - encodeCert - decodePrivateKey - encodePrivateKey - handshake.impl.v3 - newServer.impl.v3 - newClient.impl.v3 - receive.impl.v3 - send.impl.v3 - terminate.impl.v3))) - -; Native Representations: -; -; tlsPrivateKey - the "pem" struct defined in pem.rkt -; tlsCertificate - currently the raw bytes - -(define (write-to-tmp-file bytes suffix) - (let* ([tmp (make-temporary-file* #"unison" suffix)] - [of (open-output-file tmp #:exists 'replace)]) - (write-bytes bytes of) - (flush-output of) - (close-output-port of) - tmp)) - -(define (encodePrivateKey privateKey) - (bytes->chunked-bytes (string->bytes/utf-8 (pem->pem-string privateKey)))) - -(define (decodePrivateKey bytes) ; bytes -> list tlsPrivateKey - (vector->chunked-list - (list->vector ; TODO better conversion - (filter - (lambda (pem) (or - (equal? "PRIVATE KEY" (pem-label pem)) - (equal? "RSA PRIVATE KEY" (pem-label pem)))) - (pem-string->pems (bytes->string/utf-8 (chunked-bytes->bytes bytes))))))) - -(define (decodeCert.impl.v3 bytes) ; bytes -> either failure tlsSignedCert - (let ([certs (read-pem-certificates (open-input-bytes (chunked-bytes->bytes bytes)))]) - (if (= 1 (length certs)) - (right bytes) - (exception - ref-tlsfailure:typelink - (string->chunked-string "nope") - bytes)))) - -; We don't actually "decode" certificates, we just validate them -(define (encodeCert bytes) bytes) - -(struct server-config (certs key)) ; certs = list certificate; key = privateKey - -(define (ServerConfig.default certs key) ; list tlsSignedCert tlsPrivateKey -> tlsServerConfig - (server-config certs key)) - -(struct client-config (host certs)) -(struct tls (config input output)) - -(define (newServer.impl.v3 config socket-pair) ; tlsServerConfig socket -> {io} tls - (handle-errors - (lambda () - (let* ([input (socket-pair-input socket-pair)] - [output (socket-pair-output socket-pair)] - [certs (server-config-certs config)] - [key (server-config-key config)] - [key-bytes (string->bytes/utf-8 (pem->pem-string key))] - [tmp (write-to-tmp-file (chunked-bytes->bytes (chunked-list-ref certs 0)) #".pem")]) - (let*-values ([(ctx) (ssl-make-server-context - ; TODO: Once racket can handle the in-memory PEM bytes, - ; we can do away with writing them out to temporary files. - ; https://github.com/racket/racket/pull/4625 - ; #:private-key (list 'pem key-bytes) - #:private-key (list 'pem (write-to-tmp-file key-bytes #".pem")) - #:certificate-chain tmp)] - [(in out) (ports->ssl-ports - input output - #:mode 'accept - #:context ctx - #:close-original? #t - )]) - (right (tls config in out))))))) - -(define (ClientConfig.default host service-identification-suffix) ; string bytes - (if (= 0 (chunked-bytes-length service-identification-suffix)) - (client-config host empty-chunked-list) - (error 'NotImplemented "service-identification-suffix not supported"))) - -(define (ServerConfig.certificates.set certs config) - (server-config certs (server-config-key config))) - -(define (ClientConfig.certificates.set certs config) ; list tlsSignedCert tlsClientConfig -> tlsClientConfig - (client-config (client-config-host config) certs)) - -(define (handle-errors fn) - (with-handlers - [[exn:fail:network? - (lambda (e) - (exception - ref-iofailure:typelink - (exception->string e) - ref-unit-unit))] - [exn:fail:contract? - (lambda (e) - (exception - ref-miscfailure:typelink - (exception->string e) - ref-unit-unit))] - [(lambda err - (string-contains? (exn->string err) "not valid for hostname")) - (lambda (e) - (exception - ref-tlsfailure:typelink - (string->chunked-string "NameMismatch") - ref-unit-unit))] - [(lambda err - (string-contains? (exn->string err) "certificate verify failed")) - (lambda (e) - (exception - ref-tlsfailure:typelink - (string->chunked-string "certificate verify failed") - ref-unit-unit))] - [(lambda _ #t) - (lambda (e) - (exception - ref-miscfailure:typelink - (string->chunked-string - (format "Unknown exception ~a" (exn->string e))) - ref-unit-unit))]] - (fn))) - -(define (newClient.impl.v3 config socket) - (handle-errors - (lambda () - (let* ([input (socket-pair-input socket)] - [output (socket-pair-output socket)] - [hostname (client-config-host config)] - ; TODO: Make the client context up in ClientConfig.default - ; instead of right here. - [ctx (ssl-make-client-context)] - [certs (client-config-certs config)]) - (ssl-set-verify-hostname! ctx #t) - (ssl-set-ciphers! ctx "DEFAULT:!aNULL:!eNULL:!LOW:!EXPORT:!SSLv2") - (ssl-set-verify! ctx #t) - (if (chunked-list-empty? certs) - (ssl-load-default-verify-sources! ctx) - (let ([tmp (write-to-tmp-file (chunked-bytes->bytes (chunked-list-ref certs 0)) #".pem")]) - (ssl-load-verify-source! ctx tmp))) - (let-values ([(in out) (ports->ssl-ports - input output - #:mode 'connect - #:context ctx - #:hostname (chunked-string->string hostname) - #:close-original? #t - )]) - (right (tls config in out))))))) - -(define (handshake.impl.v3 tls) - (handle-errors - (lambda () - (ssl-set-verify! (tls-input tls) #t) - (right none)))) - -(define (send.impl.v3 tls data) ; data = bytes - (handle-errors - (lambda () - (let* ([output (tls-output tls)]) - (write-bytes (chunked-bytes->bytes data) output) - (flush-output output) - (right none))))) - -(define (read-more n port) - (let* ([buffer (make-bytes n)] - [read (read-bytes-avail! buffer port)]) - (if (< read n) - (subbytes buffer 0 read) - (bytes-append buffer (read-more (* 2 n) port))))) - -(define (read-all n port) - (let* ([buffer (make-bytes n)] - [read (read-bytes-avail! buffer port)]) - (if (= n read) - (bytes-append buffer (read-more (* 2 n) port)) - (subbytes buffer 0 read)))) - -(define (receive.impl.v3 tls) ; -> bytes - (handle-errors - (lambda () - (right (bytes->chunked-bytes (read-all 4096 (tls-input tls))))))) - -(define (terminate.impl.v3 tls) - ; NOTE: This actually does more than the unison impl, - ; which only sends the `close_notify` message, and doesn't - ; mark the port as no longer usable in the runtime. - ; Not sure if this is an important difference. - ; Racket's openssl lib doesn't expose a way to *just* call - ; SSL_Shutdown on a port without also closing it. - (handle-errors - (lambda () - (ssl-abandon-port (tls-input tls)) - (ssl-abandon-port (tls-output tls)) - (right none)))) diff --git a/scheme-libs/racket/unison/udp.rkt b/scheme-libs/racket/unison/udp.rkt deleted file mode 100644 index 3607673264..0000000000 --- a/scheme-libs/racket/unison/udp.rkt +++ /dev/null @@ -1,179 +0,0 @@ -; UDP primitives! -#lang racket/base -(require racket/udp - racket/format - (only-in unison/boot define-unison) - unison/data - unison/data-info - unison/chunked-seq - (only-in unison/boot sum-case) - unison/network-utils - unison/core) - -(provide - (prefix-out - builtin-IO.UDP. - (combine-out - clientSocket.impl.v1 - clientSocket.impl.v1:termlink - UDPSocket.recv.impl.v1 - UDPSocket.recv.impl.v1:termlink - UDPSocket.send.impl.v1 - UDPSocket.send.impl.v1:termlink - UDPSocket.close.impl.v1 - UDPSocket.close.impl.v1:termlink - ListenSocket.close.impl.v1 - ListenSocket.close.impl.v1:termlink - UDPSocket.toText.impl.v1 - UDPSocket.toText.impl.v1:termlink - serverSocket.impl.v1 - serverSocket.impl.v1:termlink - ListenSocket.toText.impl.v1 - ListenSocket.toText.impl.v1:termlink - ListenSocket.recvFrom.impl.v1 - ListenSocket.recvFrom.impl.v1:termlink - ClientSockAddr.toText.v1 - ClientSockAddr.toText.v1:termlink - ListenSocket.sendTo.impl.v1 - ListenSocket.sendTo.impl.v1:termlink))) - - -(struct client-sock-addr (host port)) - -; Haskell's Network.UDP choice of buffer size is 2048, so mirror that here -(define buffer-size 2048) - -(define ; a -> Either Failure a - (wrap-in-either a) - (sum-case a - (0 (type msg meta) - (ref-either-left (ref-failure-failure type msg (unison-any-any meta)))) - (1 (data) - (ref-either-right data)))) - -(define - (format-socket socket) - (let*-values ([(local-hn local-port remote-hn remote-port) (udp-addresses socket #t)] - [(rv) (~a "")]) - (string->chunked-string rv))) - -(define (close-socket socket) - (let ([rv (handle-errors (lambda() (begin - (udp-close socket) - (right ref-unit-unit))))]) - (wrap-in-either rv))) - -;; define termlink builtins -(define clientSocket.impl.v1:termlink - (unison-termlink-builtin "IO.UDP.clientSocket.impl.v1")) -(define UDPSocket.recv.impl.v1:termlink - (unison-termlink-builtin "IO.UDP.UDPSocket.recv.impl.v1")) -(define UDPSocket.send.impl.v1:termlink - (unison-termlink-builtin "IO.UDP.UDPSocket.send.impl.v1")) -(define UDPSocket.close.impl.v1:termlink - (unison-termlink-builtin "IO.UDP.UDPSocket.close.impl.v1")) -(define ListenSocket.close.impl.v1:termlink - (unison-termlink-builtin "IO.UDP.ListenSocket.close.impl.v1")) -(define UDPSocket.toText.impl.v1:termlink - (unison-termlink-builtin "IO.UDP.UDPSocket.toText.impl.v1")) -(define serverSocket.impl.v1:termlink - (unison-termlink-builtin "IO.UDP.serverSocket.impl.v1")) -(define ListenSocket.toText.impl.v1:termlink - (unison-termlink-builtin "IO.UDP.ListenSocket.toText.impl.v1")) -(define ListenSocket.recvFrom.impl.v1:termlink - (unison-termlink-builtin "IO.UDP.ListenSocket.recvFrom.impl.v1")) -(define ClientSockAddr.toText.v1:termlink - (unison-termlink-builtin "IO.UDP.ClientSockAddr.toText.v1")) -(define ListenSocket.sendTo.impl.v1:termlink - (unison-termlink-builtin "IO.UDP.ListenSocket.sendTo.impl.v1")) - -;; define builtins - -(define-unison - (UDPSocket.recv.impl.v1 socket) ; socket -> Either Failure Bytes - (let - ([rv (handle-errors (lambda() - (let*-values - ([(buffer) (make-bytes buffer-size)] - [(len a b) (udp-receive! socket buffer)]) - (right (bytes->chunked-bytes (subbytes buffer 0 len))))))]) - (wrap-in-either rv))) - -(define-unison - (ListenSocket.close.impl.v1 socket) ; socket -> Either Failure () - (close-socket socket)) - -(define-unison - (serverSocket.impl.v1 ip port) ; string string -> Either Failure socket - (let - ([result (handle-errors (lambda() - (let* ([iip (chunked-string->string ip)] - [pport (string->number (chunked-string->string port))] - [sock (udp-open-socket iip pport)]) - (begin - (udp-bind! sock iip pport) - (right sock)))))]) - (wrap-in-either result))) - -(define-unison - (ListenSocket.recvFrom.impl.v1 socket) ; socket -> Either Failure (Bytes, ClientSockAddr) - (let ([result (handle-errors (lambda() - (if (not (udp? socket)) - (raise-argument-error 'socket "a UDP socket" socket) - (let*-values - ([(buffer) (make-bytes buffer-size)] - [(len host port) (udp-receive! socket buffer)] - [(csa) (client-sock-addr host port)] - [(bs) (subbytes buffer 0 len)] - [(chunked) (bytes->chunked-bytes bs)]) - (right (ref-tuple-pair chunked (ref-tuple-pair csa ref-unit-unit)))))))]) - (wrap-in-either result))) - -(define-unison - (UDPSocket.send.impl.v1 socket data) ; socket -> Bytes -> Either Failure () - (let - ([result (handle-errors (lambda () (begin - (udp-send socket (chunked-bytes->bytes data)) - (right ref-unit-unit))))]) - (wrap-in-either result))) - -(define-unison - (ListenSocket.sendTo.impl.v1 sock bytes addr) ; socket -> Bytes -> ClientSockAddr -> Either Failure () - (let - ([result (handle-errors (lambda() - (let* ([host (client-sock-addr-host addr)] - [port (client-sock-addr-port addr)] - [bytes (chunked-bytes->bytes bytes)]) - (begin - (udp-send-to sock host port bytes) - (right ref-unit-unit)))))]) - (wrap-in-either result))) - -(define-unison - (UDPSocket.toText.impl.v1 socket) ; socket -> string - (format-socket socket)) - -(define-unison - (ClientSockAddr.toText.v1 addr) ; ClientSocketAddr -> string - (string->chunked-string (format "" (client-sock-addr-host addr) (client-sock-addr-port addr)))) - -(define-unison - (ListenSocket.toText.impl.v1 socket) ; socket -> string - (format-socket socket)) - -(define-unison - (UDPSocket.close.impl.v1 socket) ; socket -> Either Failure () - (let - ([rv (handle-errors (lambda() (begin - (udp-close socket) - (right ref-unit-unit))))]) - (wrap-in-either rv))) - -(define-unison - (clientSocket.impl.v1 host port) ; string string -> Either Failure socket - (let ([rv (handle-errors (lambda() (let* ([pport (string->number (chunked-string->string port))] - [hhost (chunked-string->string host)] - [sock (udp-open-socket hhost pport)] - [_ (udp-bind! sock #f 0)] - [res (udp-connect! sock hhost pport)]) (right sock))))]) - (wrap-in-either rv))) diff --git a/scheme-libs/racket/unison/zlib.rkt b/scheme-libs/racket/unison/zlib.rkt index a93c781b45..b191eea243 100644 --- a/scheme-libs/racket/unison/zlib.rkt +++ b/scheme-libs/racket/unison/zlib.rkt @@ -9,10 +9,9 @@ file/gunzip file/gzip) -(provide (prefix-out unison-FOp-Bytes. - (combine-out - zlib.compress - zlib.decompress))) +(provide + zlib-deflate-bytes + zlib-inflate-bytes) (define (read-byte-only what i) diff --git a/scripts/check.sh b/scripts/check.sh index 03bb6609f9..1784f69c6d 100755 --- a/scripts/check.sh +++ b/scripts/check.sh @@ -6,4 +6,5 @@ true \ && stack exec transcripts \ && stack exec unison transcript unison-src/transcripts-round-trip/main.md \ && stack exec unison transcript unison-src/transcripts-manual/rewrites.md \ + && stack exec unison transcript unison-src/transcripts-manual/docs.to-html.md \ && stack exec cli-integration-tests diff --git a/stack.yaml b/stack.yaml index ff76c60ea6..a628e395ea 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,8 @@ +## We intentionally disable Nix integration when running in a Nix shell. +notify-if-nix-on-path: false +## We pin a specific Stack version when possible. We shouldn’t then tell contributors to upgrade from there. +recommend-stack-upgrade: false + flags: haskeline: terminfo: false @@ -29,7 +34,7 @@ packages: - lib/unison-util-bytes - lib/unison-util-cache - lib/unison-util-file-embed - - lib/unison-util-nametree + - lib/unison-util-recursion - lib/unison-util-relation - lib/unison-util-rope - parser-typechecker @@ -39,17 +44,15 @@ packages: - unison-core - unison-hashing-v2 - unison-merge + - unison-runtime - unison-share-api - unison-share-projects-api - unison-syntax - yaks/easytest -resolver: lts-20.26 +resolver: lts-22.26 extra-deps: - # broken version in snapshot - - github: unisonweb/configurator - commit: e47e9e9fe1f576f8c835183b9def52d73c01327a # This custom Haskeline alters ANSI rendering on Windows. # If changing the haskeline dependency, please ensure color renders properly in a # Windows terminal. @@ -58,19 +61,20 @@ extra-deps: commit: 9275eea7982dabbf47be2ba078ced669ae7ef3d5 # not in stackage - - fuzzyfind-3.0.1 - - guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 + - fuzzyfind-3.0.2@sha256:0fcd64eb1016fe0d0232abc26b2b80b32d676707ff41d155a28df8a9572603d4,1921 - lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 - - monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 - - recover-rtti-0.4.2@sha256:c179a303921126d8d782264e14f386c96e54a270df74be002e4c4ec3c8c7aebd,4529 - - lsp-2.2.0.0@sha256:82fbf4b69d94d8d22543be71f89986b3e90050032d671fb3de3f8253ea1e5b6f,3550 - - lsp-types-2.0.2.0@sha256:a9a51c3cea0726d91fe63fa0670935ee720f7b31bc3f3b33b2483fc538152677,29421 - - row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 - - network-udp-0.0.0 + - monad-validate-1.3.0.0@sha256:eb6ddd5c9cf72ff0563cba604fa00291376e96138fdb4932d00ff3a99d66706e,2605 + - recover-rtti-0.4.3@sha256:01adcbab70a6542914df28ac120a23a923d8566236f2c0295998e9419f53dd62,4672 + - numerals-0.4.1@sha256:f138b4a0efbde3b3c6cbccb788eff683cb8a5d046f449729712fd174c5ee8a78,11430 + - network-udp-0.0.0@sha256:408d2d4fa1a25e49e95752ee124cca641993404bb133ae10fb81daef22d876ae,1075 + +allow-newer: true +allow-newer-deps: + - numerals ghc-options: # All packages - "$locals": -Wall -Werror -Wno-name-shadowing -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info #-freverse-errors + "$locals": -Wall -Werror -Wno-name-shadowing -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info -Wunused-packages -funbox-strict-fields #-freverse-errors # See https://github.com/haskell/haskell-language-server/issues/208 "$everything": -haddock diff --git a/stack.yaml.lock b/stack.yaml.lock index 4f98b610bf..a2ef8c07f1 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,17 +4,6 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: -- completed: - name: configurator - pantry-tree: - sha256: 90547cd983fd15ebdc803e057d3ef8735fe93a75e29a00f8a74eadc13ee0f6e9 - size: 955 - sha256: d4fd87fb7bfc5d8e9fbc3e4ee7302c6b1500cdc00fdb9b659d0f4849b6ebe2d5 - size: 15989 - url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz - version: 0.3.0.0 - original: - url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz - completed: name: haskeline pantry-tree: @@ -27,19 +16,12 @@ packages: original: url: https://github.com/unisonweb/haskeline/archive/9275eea7982dabbf47be2ba078ced669ae7ef3d5.tar.gz - completed: - hackage: fuzzyfind-3.0.1@sha256:78f89c1d79adf0a15fa2e57c693d42b4765ccfbbe380d0c9d7da6bff9f124f85,1823 + hackage: fuzzyfind-3.0.2@sha256:0fcd64eb1016fe0d0232abc26b2b80b32d676707ff41d155a28df8a9572603d4,1921 pantry-tree: - sha256: 46f001ec2725d3172161c993bc8fbcf0514e3ba736f868fe2c2655e1ff49dad1 + sha256: 5bb9d39dbc4a619cf9b65409dde0d58dd488c7abab030f71ac83ba849595ee05 size: 542 original: - hackage: fuzzyfind-3.0.1 -- completed: - hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 - pantry-tree: - sha256: a33838b7b1c54f6ac3e1b436b25674948713a4189658e4d82e639b9a689bc90d - size: 364 - original: - hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 + hackage: fuzzyfind-3.0.2@sha256:0fcd64eb1016fe0d0232abc26b2b80b32d676707ff41d155a28df8a9572603d4,1921 - completed: hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 pantry-tree: @@ -48,50 +30,36 @@ packages: original: hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 - completed: - hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 + hackage: monad-validate-1.3.0.0@sha256:eb6ddd5c9cf72ff0563cba604fa00291376e96138fdb4932d00ff3a99d66706e,2605 pantry-tree: - sha256: 8e049bd12ce2bd470909578f2ee8eb80b89d5ff88860afa30e29dd4eafecfa3e - size: 713 + sha256: 0b2a3a57be48fcc739708b214fca202f1e95b1cd773dd3bb9589d3007cf8cf5e + size: 611 original: - hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 + hackage: monad-validate-1.3.0.0@sha256:eb6ddd5c9cf72ff0563cba604fa00291376e96138fdb4932d00ff3a99d66706e,2605 - completed: - hackage: recover-rtti-0.4.2@sha256:c179a303921126d8d782264e14f386c96e54a270df74be002e4c4ec3c8c7aebd,4529 + hackage: recover-rtti-0.4.3@sha256:01adcbab70a6542914df28ac120a23a923d8566236f2c0295998e9419f53dd62,4672 pantry-tree: - sha256: ad6f24481ebd25a1456d5dfaf08d48d95394ce83eb82a267e01d87d34f13bb83 - size: 2488 + sha256: 59a5df9c88f83816a9826b1e9708153d06d64bd1aed6c1d71ef0a1f6db070599 + size: 2489 original: - hackage: recover-rtti-0.4.2@sha256:c179a303921126d8d782264e14f386c96e54a270df74be002e4c4ec3c8c7aebd,4529 + hackage: recover-rtti-0.4.3@sha256:01adcbab70a6542914df28ac120a23a923d8566236f2c0295998e9419f53dd62,4672 - completed: - hackage: lsp-2.2.0.0@sha256:82fbf4b69d94d8d22543be71f89986b3e90050032d671fb3de3f8253ea1e5b6f,3550 + hackage: numerals-0.4.1@sha256:f138b4a0efbde3b3c6cbccb788eff683cb8a5d046f449729712fd174c5ee8a78,11430 pantry-tree: - sha256: 88ea35fb71d377c035770d5f0d6a3aea51919223e3bc1e492deb6f7d9cda3a85 - size: 1043 + sha256: c616791b08f1792fd1d4ca03c6d2c773dedb25b24b66454c97864aefd85a5d0a + size: 13751 original: - hackage: lsp-2.2.0.0@sha256:82fbf4b69d94d8d22543be71f89986b3e90050032d671fb3de3f8253ea1e5b6f,3550 -- completed: - hackage: lsp-types-2.0.2.0@sha256:a9a51c3cea0726d91fe63fa0670935ee720f7b31bc3f3b33b2483fc538152677,29421 - pantry-tree: - sha256: 7a3f0b679066d5e4732dfa358d76e0969589d636f4012c9e87cbe3451aa3ee5e - size: 45527 - original: - hackage: lsp-types-2.0.2.0@sha256:a9a51c3cea0726d91fe63fa0670935ee720f7b31bc3f3b33b2483fc538152677,29421 -- completed: - hackage: row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 - pantry-tree: - sha256: 6a3617038d3970095100d14d026c396002a115700500cf3004ffb67ae5a75611 - size: 1060 - original: - hackage: row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 + hackage: numerals-0.4.1@sha256:f138b4a0efbde3b3c6cbccb788eff683cb8a5d046f449729712fd174c5ee8a78,11430 - completed: hackage: network-udp-0.0.0@sha256:408d2d4fa1a25e49e95752ee124cca641993404bb133ae10fb81daef22d876ae,1075 pantry-tree: sha256: ee19a66c9d420861c5cc1dfad3210e2a53cdc6088ff3dd90b44f7961f5caebee size: 284 original: - hackage: network-udp-0.0.0 + hackage: network-udp-0.0.0@sha256:408d2d4fa1a25e49e95752ee124cca641993404bb133ae10fb81daef22d876ae,1075 snapshots: - completed: - sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 - size: 650475 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml - original: lts-20.26 + sha256: 8e7996960d864443a66eb4105338bbdd6830377b9f6f99cd5527ef73c10c01e7 + size: 719128 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/26.yaml + original: lts-22.26 diff --git a/unison-cli-integration/integration-tests/IntegrationTests/ArgumentParsing.hs b/unison-cli-integration/integration-tests/IntegrationTests/ArgumentParsing.hs index 02ef8fce9e..0ecbcbb000 100644 --- a/unison-cli-integration/integration-tests/IntegrationTests/ArgumentParsing.hs +++ b/unison-cli-integration/integration-tests/IntegrationTests/ArgumentParsing.hs @@ -2,6 +2,7 @@ module IntegrationTests.ArgumentParsing where +import Control.Monad (when) import Data.List (intercalate) import Data.Time (diffUTCTime, getCurrentTime) import EasyTest @@ -71,10 +72,12 @@ test = do expectExitCode :: ExitCode -> FilePath -> [String] -> String -> Test () expectExitCode expected cmd args stdin = scope (intercalate " " (cmd : args)) do start <- io $ getCurrentTime - (code, _, _) <- io $ readProcessWithExitCode cmd args stdin + (code, _, stdErr) <- io $ readProcessWithExitCode cmd args stdin end <- io $ getCurrentTime let diff = diffUTCTime end start note $ printf "\n[Time: %s sec]" $ show diff + when (code /= expected) do + note ("stderr:\n" <> stdErr) expectEqual code expected defaultArgs :: [String] diff --git a/unison-cli-integration/integration-tests/IntegrationTests/transcript.md b/unison-cli-integration/integration-tests/IntegrationTests/transcript.md index c8b10ea268..0b26c2d432 100644 --- a/unison-cli-integration/integration-tests/IntegrationTests/transcript.md +++ b/unison-cli-integration/integration-tests/IntegrationTests/transcript.md @@ -1,18 +1,13 @@ # Integration test: transcript -```ucm:hide -.> builtins.mergeio -.> load ./unison-src/transcripts-using-base/base.u +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +scratch/main> load ./unison-src/transcripts-using-base/base.u +scratch/main> add ``` -```ucm:hide -.> builtins.mergeio -.> load ./unison-src/transcripts-using-base/base.u -.> add -``` - -```unison -use .builtin +``` unison +use lib.builtins unique type MyBool = MyTrue | MyFalse @@ -38,7 +33,7 @@ main = do _ -> () ``` -```ucm -.> add -.> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main +``` ucm +scratch/main> add +scratch/main> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main ``` diff --git a/unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md b/unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md index c74133f4ba..5ba2e787e8 100644 --- a/unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md +++ b/unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md @@ -1,7 +1,15 @@ # Integration test: transcript -```unison -use .builtin +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins + +scratch/main> load ./unison-src/transcripts-using-base/base.u + +scratch/main> add +``` + +``` unison +use lib.builtins unique type MyBool = MyTrue | MyFalse @@ -27,32 +35,30 @@ main = do _ -> () ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: structural ability Break type MyBool main : '{IO, Exception} () resume : Request {g, Break} x -> x - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + structural ability Break type MyBool main : '{IO, Exception} () resume : Request {g, Break} x -> x -.> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main - +scratch/main> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main ``` diff --git a/unison-cli-integration/package.yaml b/unison-cli-integration/package.yaml index 9ea425cb51..b4127e82e9 100644 --- a/unison-cli-integration/package.yaml +++ b/unison-cli-integration/package.yaml @@ -2,11 +2,6 @@ name: unison-cli-integration github: unisonweb/unison copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors -flags: - optimized: - manual: true - default: false - ghc-options: -Wall executables: @@ -24,15 +19,10 @@ executables: - directory - easytest - process - - shellmet - time build-tools: - unison-cli-main:unison -when: - - condition: flag(optimized) - ghc-options: -O2 -funbox-strict-fields - default-extensions: - ApplicativeDo - BangPatterns diff --git a/unison-cli-integration/unison-cli-integration.cabal b/unison-cli-integration/unison-cli-integration.cabal index 3b5a0fb543..6cda3a952d 100644 --- a/unison-cli-integration/unison-cli-integration.cabal +++ b/unison-cli-integration/unison-cli-integration.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -15,10 +15,6 @@ source-repository head type: git location: https://github.com/unisonweb/unison -flag optimized - manual: True - default: False - executable cli-integration-tests main-is: Suite.hs other-modules: @@ -68,8 +64,5 @@ executable cli-integration-tests , easytest , filepath , process - , shellmet , time default-language: Haskell2010 - if flag(optimized) - ghc-options: -O2 -funbox-strict-fields diff --git a/unison-cli-main/package.yaml b/unison-cli-main/package.yaml index b64fe52764..820829493e 100644 --- a/unison-cli-main/package.yaml +++ b/unison-cli-main/package.yaml @@ -2,11 +2,6 @@ name: unison-cli-main github: unisonweb/unison copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors -flags: - optimized: - manual: true - default: false - ghc-options: -Wall executables: @@ -24,10 +19,6 @@ executables: - text - unison-cli -when: - - condition: flag(optimized) - ghc-options: -O2 -funbox-strict-fields - default-extensions: - ApplicativeDo - BangPatterns diff --git a/unison-cli-main/unison-cli-main.cabal b/unison-cli-main/unison-cli-main.cabal index 4c54254978..e94c51e228 100644 --- a/unison-cli-main/unison-cli-main.cabal +++ b/unison-cli-main/unison-cli-main.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -17,10 +17,6 @@ source-repository head type: git location: https://github.com/unisonweb/unison -flag optimized - manual: True - default: False - executable unison main-is: Main.hs other-modules: @@ -68,5 +64,3 @@ executable unison , text , unison-cli default-language: Haskell2010 - if flag(optimized) - ghc-options: -O2 -funbox-strict-fields diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 3402e98c92..098c48f302 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -2,108 +2,15 @@ name: unison-cli github: unisonweb/unison copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors -flags: - optimized: - manual: true - default: false - ghc-options: -Wall dependencies: - - IntervalMap - - ListLike - - aeson >= 2.0.0.0 - - aeson-pretty - - ansi-terminal - - async - base - - bytes - - bytestring - - co-log-core - - code-page - - concurrent-output - - configurator - - containers >= 0.6.3 - - cryptonite - - directory - - either - - errors - - exceptions - - extra - - filepath - - free - - friendly-time - - fsnotify - - fuzzyfind - - generic-lens - - haskeline - - http-client >= 0.7.6 - - http-client-tls - - http-types - - jwt - - ki - - lens - - lock-file - - lsp >= 2.2.0.0 - - lsp-types >= 2.0.2.0 - - megaparsec - - memory - - mtl - - network - - network-simple - - network-udp - - network-uri - - nonempty-containers - - open-browser - - optparse-applicative >= 0.16.1.0 - - pretty-simple - - process - - random >= 1.2.0 - - random-shuffle - - recover-rtti - - regex-tdfa - - semialign - - semigroups - - servant - - servant-client - - shellmet - - stm - - template-haskell - - temporary - text - - text-ansi - - text-builder - - text-rope - - these - - these-lens - - time - - transformers - - unison-codebase - - unison-codebase-sqlite - - unison-codebase-sqlite-hashing-v2 - - unison-core - - unison-core1 - - unison-hash - - unison-merge - unison-parser-typechecker - unison-prelude - - unison-pretty-printer - - unison-share-api - - unison-share-projects-api - - unison-sqlite - - unison-syntax - - unison-util-base32hex - - unison-util-nametree - - unison-util-relation - - unliftio - - unordered-containers - - uri-encode - - uuid - - vector - - wai - - warp - - witch - - witherable + - megaparsec + - directory library: source-dirs: src @@ -113,11 +20,85 @@ library: - condition: "!os(windows)" dependencies: unix dependencies: + - Diff + - IntervalMap + - ListLike + - aeson >= 2.0.0.0 + - aeson-pretty + - ansi-terminal + - async + - bytestring + - cmark + - co-log-core - code-page + - concurrent-output + - containers >= 0.6.3 + - cryptonite + - either + - errors + - extra + - filepath + - free + - friendly-time + - fsnotify + - generic-lens + - haskeline + - http-client >= 0.7.6 + - http-client-tls + - http-types + - ki + - lens + - lock-file + - lsp >= 2.2.0.0 + - lsp-types >= 2.0.2.0 + - memory + - mtl + - network-simple + - network-uri + - nonempty-containers + - numerals + - open-browser - optparse-applicative >= 0.16.1.0 - - shellmet - - template-haskell + - pretty-simple + - process + - random-shuffle + - recover-rtti + - regex-tdfa + - semialign + - servant + - servant-client + - stm - temporary + - text-ansi + - text-builder + - text-rope + - these + - time + - transformers + - unison-codebase + - unison-codebase-sqlite + - unison-codebase-sqlite-hashing-v2 + - unison-core + - unison-core1 + - unison-hash + - unison-merge + - unison-parser-typechecker + - unison-pretty-printer + - unison-runtime + - unison-share-api + - unison-share-projects-api + - unison-sqlite + - unison-syntax + - unison-util-base32hex + - unison-util-recursion + - unison-util-relation + - unliftio + - uuid + - vector + - wai + - warp + - witch + - witherable tests: cli-tests: @@ -126,11 +107,22 @@ tests: other-modules: Paths_unison_cli dependencies: - code-page + - containers + - cryptonite - easytest + - extra - here - - shellmet + - lens + - lsp-types - temporary + - these - unison-cli + - unison-core + - unison-core1 + - unison-parser-typechecker + - unison-pretty-printer + - unison-syntax + - unison-util-recursion main: Main.hs source-dirs: tests @@ -145,14 +137,10 @@ executables: dependencies: - code-page - easytest - - process - - shellmet - - unison-cli + - filepath - silently - -when: - - condition: flag(optimized) - ghc-options: -O2 -funbox-strict-fields + - unison-cli + - unliftio default-extensions: - ApplicativeDo diff --git a/unison-cli/src/ArgParse.hs b/unison-cli/src/ArgParse.hs index 5e7032942a..90ec1f9ee7 100644 --- a/unison-cli/src/ArgParse.hs +++ b/unison-cli/src/ArgParse.hs @@ -52,14 +52,19 @@ import Options.Applicative.Help (bold, (<+>)) import Options.Applicative.Help.Pretty qualified as P import Stats import System.Environment (lookupEnv) +import Text.Megaparsec qualified as Megaparsec import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathNames) +import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.Types (ShouldWatchFiles (..)) +import Unison.Core.Project (ProjectAndBranch, ProjectBranchName, ProjectName) import Unison.HashQualified (HashQualified) import Unison.LSP (LspFormattingConfig (..)) import Unison.Name (Name) import Unison.Prelude import Unison.PrettyTerminal qualified as PT +import Unison.Project qualified as Project import Unison.Server.CodebaseServer (CodebaseServerOpts (..)) import Unison.Server.CodebaseServer qualified as Server import Unison.Syntax.HashQualified qualified as HQ @@ -68,7 +73,7 @@ import Unison.Util.Pretty (Width (..)) -- | Valid ways to provide source code to the run command data RunSource = RunFromPipe (HashQualified Name) - | RunFromSymbol (HashQualified Name) + | RunFromSymbol ProjectPathNames | RunFromFile FilePath (HashQualified Name) | RunCompiled FilePath deriving (Show, Eq) @@ -102,8 +107,8 @@ data Command = Launch IsHeadless CodebaseServerOpts - -- Starting path - (Maybe Path.Absolute) + -- Starting project + (Maybe (ProjectAndBranch ProjectName ProjectBranchName)) ShouldWatchFiles | PrintVersion | -- @deprecated in trunk after M2g. Remove the Init command completely after M2h has been released @@ -220,7 +225,7 @@ transcriptCommand = transcriptHelp = "Execute transcript markdown files" transcriptFooter = Just . fold . List.intersperse P.line $ - [ "For each .md file provided this executes the transcript and creates" <+> bold ".output.md" <+> "if successful.", + [ "For each .md file provided this executes the transcript and creates" <+> P.annotate bold ".output.md" <+> "if successful.", "Exits after completion, and deletes the temporary directory created, unless --save-codebase is provided", "Multiple transcript files may be provided; they are processed in sequence" <+> "starting from the same codebase." ] @@ -232,7 +237,7 @@ transcriptForkCommand = transcriptHelp = "Execute transcript markdown files in a sandboxed codebase" transcriptFooter = Just . fold . List.intersperse P.line $ - [ "For each .md file provided this executes the transcript in a sandbox codebase and creates" <+> bold ".output.md" <+> "if successful.", + [ "For each .md file provided this executes the transcript in a sandbox codebase and creates" <+> P.annotate bold ".output.md" <+> "if successful.", "Exits after completion, and deletes the temporary directory created, unless --save-codebase is provided", "Multiple transcript files may be provided; they are processed in sequence" <+> "starting from the same codebase." ] @@ -357,9 +362,9 @@ launchParser :: CodebaseServerOpts -> IsHeadless -> Parser Command launchParser envOpts isHeadless = do -- ApplicativeDo codebaseServerOpts <- codebaseServerOptsParser envOpts - startingPath <- startingPathOption + startingProject <- startingProjectOption shouldWatchFiles <- noFileWatchFlag - pure (Launch isHeadless codebaseServerOpts startingPath shouldWatchFiles) + pure (Launch isHeadless codebaseServerOpts startingProject shouldWatchFiles) initParser :: Parser Command initParser = pure Init @@ -374,9 +379,13 @@ runHQParser :: Parser (HashQualified Name) runHQParser = argument (maybeReader (HQ.parseText . Text.pack)) (metavar "SYMBOL") +runProjectPathParser :: Parser PP.ProjectPathNames +runProjectPathParser = + argument (maybeReader (eitherToMaybe . PP.parseProjectPath . Text.pack)) (metavar "@myproject/mybranch:.path.in.project") + runSymbolParser :: Parser Command runSymbolParser = - Run . RunFromSymbol <$> runHQParser <*> runArgumentParser + Run . RunFromSymbol <$> runProjectPathParser <*> runArgumentParser runFileParser :: Parser Command runFileParser = @@ -422,15 +431,15 @@ saveCodebaseToFlag = do _ -> DontSaveCodebase ) -startingPathOption :: Parser (Maybe Path.Absolute) -startingPathOption = +startingProjectOption :: Parser (Maybe (ProjectAndBranch ProjectName ProjectBranchName)) +startingProjectOption = let meta = - metavar ".path.in.codebase" - <> long "path" + metavar "project/branch" + <> long "project" <> short 'p' - <> help "Launch the UCM session at the provided path location." + <> help "Launch the UCM session at the provided project and branch." <> noGlobal - in optional $ option readAbsolutePath meta + in optional (option readProjectAndBranchNames meta) noFileWatchFlag :: Parser ShouldWatchFiles noFileWatchFlag = @@ -469,6 +478,13 @@ readPath' = do Left err -> OptParse.readerError (Text.unpack err) Right path' -> pure path' +readProjectAndBranchNames :: ReadM (ProjectAndBranch ProjectName ProjectBranchName) +readProjectAndBranchNames = do + str <- OptParse.str + case Megaparsec.parse Project.fullyQualifiedProjectAndBranchNamesParser "arg" str of + Left errBundle -> OptParse.readerError $ Megaparsec.errorBundlePretty errBundle + Right projectAndBranch -> pure projectAndBranch + fileArgument :: String -> Parser FilePath fileArgument varName = strArgument @@ -505,15 +521,15 @@ transcriptForkParser = do ) unisonHelp :: String -> String -> P.Doc -unisonHelp (P.text -> executable) (P.text -> version) = +unisonHelp (fromString -> executable) (fromString -> version) = fold . List.intersperse P.line $ - [ P.empty, + [ mempty, "🌻", - P.empty, - P.bold "Usage instructions for the Unison Codebase Manager", + mempty, + P.annotate P.bold "Usage instructions for the Unison Codebase Manager", "You are running version:" <+> version, - P.empty, - "To get started just run" <+> P.bold executable, - P.empty, - "Use" <+> P.bold (executable <+> "[command] --help") <+> "to show help for a command." + mempty, + "To get started just run" <+> P.annotate P.bold executable, + mempty, + "Use" <+> P.annotate P.bold (executable <+> "[command] --help") <+> "to show help for a command." ] diff --git a/unison-cli/src/Unison/Cli/DownloadUtils.hs b/unison-cli/src/Unison/Cli/DownloadUtils.hs index bb8ca79047..343ebfeeb5 100644 --- a/unison-cli/src/Unison/Cli/DownloadUtils.hs +++ b/unison-cli/src/Unison/Cli/DownloadUtils.hs @@ -34,7 +34,7 @@ import Unison.Sync.Types qualified as Share -- | Download a project/branch from Share. downloadProjectBranchFromShare :: - HasCallStack => + (HasCallStack) => Share.IncludeSquashedHead -> Share.RemoteProjectBranch -> Cli (Either Output.ShareError CausalHash) diff --git a/unison-cli/src/Unison/Cli/Monad.hs b/unison-cli/src/Unison/Cli/Monad.hs index 73783e1a0f..cede3035fb 100644 --- a/unison-cli/src/Unison/Cli/Monad.hs +++ b/unison-cli/src/Unison/Cli/Monad.hs @@ -14,6 +14,7 @@ module Unison.Cli.Monad -- * Immutable state LoopState (..), loopState0, + getProjectPathIds, -- * Lifting IO actions ioE, @@ -33,10 +34,12 @@ module Unison.Cli.Monad -- * Changing the current directory cd, popd, + switchProject, -- * Communicating output to the user respond, respondNumbered, + withRespondRegion, setNumberedArgs, -- * Debug-timing actions @@ -45,6 +48,10 @@ module Unison.Cli.Monad -- * Running transactions runTransaction, runTransactionWithRollback, + runTransactionWithRollback2, + + -- * Internal + setMostRecentProjectPath, -- * Misc types LoadSourceResult (..), @@ -52,35 +59,38 @@ module Unison.Cli.Monad where import Control.Exception (throwIO) -import Control.Lens (lens, (.=)) +import Control.Lens import Control.Monad.Reader (MonadReader (..)) import Control.Monad.State.Strict (MonadState) import Control.Monad.State.Strict qualified as State -import Data.Configurator.Types qualified as Configurator import Data.List.NonEmpty qualified as List (NonEmpty) import Data.List.NonEmpty qualified as List.NonEmpty +import Data.List.NonEmpty qualified as NonEmpty import Data.Time.Clock (DiffTime, diffTimeToPicoseconds) import Data.Time.Clock.System (getSystemTime, systemToTAITime) import Data.Time.Clock.TAI (diffAbsoluteTime) import Data.Unique (Unique, newUnique) -import GHC.OverloadedLabels (IsLabel (..)) import System.CPUTime (getCPUTime) +import System.Console.Regions qualified as Console.Regions import Text.Printf (printf) -import U.Codebase.HashTags (CausalHash) -import U.Codebase.Sqlite.Queries qualified as Queries +import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) +import U.Codebase.Sqlite.Queries qualified as Q import Unison.Auth.CredentialManager (CredentialManager) import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase -import Unison.Codebase.Branch (Branch) import Unison.Codebase.Editor.Input (Input) import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output) import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime (Runtime) +import Unison.CommandLine.OutputMessages qualified as OutputMessages +import Unison.Core.Project (ProjectAndBranch (..)) import Unison.Debug qualified as Debug import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.PrettyTerminal qualified as PrettyTerminal import Unison.Server.CodebaseServer qualified as Server import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) @@ -88,7 +98,7 @@ import Unison.Syntax.Parser qualified as Parser import Unison.Term (Term) import Unison.Type (Type) import Unison.UnisonFile qualified as UF -import UnliftIO.STM +import Unison.Util.Pretty qualified as Pretty import Unsafe.Coerce (unsafeCoerce) -- | The main command-line app monad. @@ -154,14 +164,13 @@ type SourceName = Text data Env = Env { authHTTPClient :: AuthenticatedHttpClient, codebase :: Codebase IO Symbol Ann, - config :: Configurator.Config, credentialManager :: CredentialManager, -- | Generate a unique name. generateUniqueName :: IO Parser.UniqueName, -- | How to load source code. loadSource :: SourceName -> IO LoadSourceResult, - -- | How to write source code. - writeSource :: SourceName -> Text -> IO (), + -- | How to write source code. Bool = make new fold? + writeSource :: SourceName -> Text -> Bool -> IO (), -- | What to do with output for the user. notify :: Output -> IO (), -- | What to do with numbered output for the user. @@ -170,7 +179,10 @@ data Env = Env sandboxedRuntime :: Runtime Symbol, nativeRuntime :: Runtime Symbol, serverBaseUrl :: Maybe Server.BaseUrl, - ucmVersion :: UCMVersion + ucmVersion :: UCMVersion, + -- | Whether we're running in a transcript test or not. + -- Avoid using this except when absolutely necessary. + isTranscriptTest :: Bool } deriving stock (Generic) @@ -178,10 +190,8 @@ data Env = Env -- -- There's an additional pseudo @"currentPath"@ field lens, for convenience. data LoopState = LoopState - { root :: TMVar (Branch IO), - lastSavedRootHash :: CausalHash, - -- the current position in the namespace - currentPathStack :: List.NonEmpty Path.Absolute, + { -- the current position in the codebase, with the head being the most recent lcoation. + projectPathStack :: List.NonEmpty PP.ProjectPathIds, -- TBD -- , _activeEdits :: Set Branch.EditGuid @@ -206,26 +216,11 @@ data LoopState = LoopState } deriving stock (Generic) -instance - {-# OVERLAPS #-} - (Functor f) => - IsLabel "currentPath" ((Path.Absolute -> f Path.Absolute) -> (LoopState -> f LoopState)) - where - fromLabel :: (Path.Absolute -> f Path.Absolute) -> (LoopState -> f LoopState) - fromLabel = - lens - (\LoopState {currentPathStack} -> List.NonEmpty.head currentPathStack) - ( \loopState@LoopState {currentPathStack = _ List.NonEmpty.:| paths} path -> - loopState {currentPathStack = path List.NonEmpty.:| paths} - ) - -- | Create an initial loop state given a root branch and the current path. -loopState0 :: CausalHash -> TMVar (Branch IO) -> Path.Absolute -> LoopState -loopState0 lastSavedRootHash b p = do +loopState0 :: PP.ProjectPathIds -> LoopState +loopState0 p = do LoopState - { root = b, - lastSavedRootHash = lastSavedRootHash, - currentPathStack = pure p, + { projectPathStack = pure p, latestFile = Nothing, latestTypecheckedFile = Nothing, lastInput = Nothing, @@ -387,11 +382,25 @@ time label action = ms = ns / 1_000_000 s = ns / 1_000_000_000 +getProjectPathIds :: Cli PP.ProjectPathIds +getProjectPathIds = do + NonEmpty.head <$> use #projectPathStack + cd :: Path.Absolute -> Cli () cd path = do - setMostRecentNamespace path - State.modify' \state -> - state {currentPathStack = List.NonEmpty.cons path (currentPathStack state)} + pp <- getProjectPathIds + let newPP = pp & PP.absPath_ .~ path + setMostRecentProjectPath newPP + #projectPathStack %= NonEmpty.cons newPP + +switchProject :: ProjectAndBranch ProjectId ProjectBranchId -> Cli () +switchProject pab@(ProjectAndBranch projectId branchId) = do + Env {codebase} <- ask + let newPP = PP.ProjectPath projectId branchId Path.absoluteEmpty + #projectPathStack %= NonEmpty.cons newPP + runTransaction $ do Q.setMostRecentBranch projectId branchId + setMostRecentProjectPath newPP + liftIO $ Codebase.preloadProjectBranch codebase pab -- | Pop the latest path off the stack, if it's not the only path in the stack. -- @@ -399,16 +408,16 @@ cd path = do popd :: Cli Bool popd = do state <- State.get - case List.NonEmpty.uncons (currentPathStack state) of + case List.NonEmpty.uncons (projectPathStack state) of (_, Nothing) -> pure False (_, Just paths) -> do - setMostRecentNamespace (List.NonEmpty.head paths) - State.put state {currentPathStack = paths} + setMostRecentProjectPath (List.NonEmpty.head paths) + State.put state {projectPathStack = paths} pure True -setMostRecentNamespace :: Path.Absolute -> Cli () -setMostRecentNamespace = - runTransaction . Queries.setMostRecentNamespace . Path.toList . Path.unabsolute +setMostRecentProjectPath :: PP.ProjectPathIds -> Cli () +setMostRecentProjectPath loc = + runTransaction $ Codebase.setCurrentProjectPath loc respond :: Output -> Cli () respond output = do @@ -421,6 +430,23 @@ respondNumbered output = do args <- liftIO (notifyNumbered output) setNumberedArgs args +-- | Perform a Cli action with access to a console region, which is closed upon completion. +-- +-- (In transcripts, this just outputs messages as normal). +withRespondRegion :: ((Output -> Cli ()) -> Cli a) -> Cli a +withRespondRegion action = do + env <- ask + case env.isTranscriptTest of + False -> + with_ Console.Regions.displayConsoleRegions do + with (Console.Regions.withConsoleRegion Console.Regions.Linear) \region -> + action \output -> + liftIO do + string <- (OutputMessages.notifyUser "." output) + width <- PrettyTerminal.getAvailableWidth + Console.Regions.setConsoleRegion region (Pretty.toANSI width (Pretty.border 2 string)) + True -> action respond + -- | Updates the numbered args, but only if the new args are non-empty. setNumberedArgs :: NumberedArgs -> Cli () setNumberedArgs args = do @@ -439,3 +465,10 @@ runTransactionWithRollback action = do Env {codebase} <- ask liftIO (Codebase.runTransactionWithRollback codebase \rollback -> Right <$> action (\output -> rollback (Left output))) & onLeftM returnEarly + +-- | Run a transaction that can abort early. +-- todo: rename to runTransactionWithRollback +runTransactionWithRollback2 :: ((forall void. a -> Sqlite.Transaction void) -> Sqlite.Transaction a) -> Cli a +runTransactionWithRollback2 action = do + env <- ask + liftIO (Codebase.runTransactionWithRollback env.codebase action) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 5aa583ee4c..242ee77635 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -1,15 +1,20 @@ -- | This module contains miscellaneous helper utils for rote actions in the Cli monad, like resolving a relative path -- to an absolute path, per the current path. module Unison.Cli.MonadUtils - ( -- * @.unisonConfig@ things - getConfig, - - -- * Paths + ( -- * Paths getCurrentPath, + getCurrentProjectName, + getCurrentProjectBranchName, + getCurrentProjectPath, resolvePath, resolvePath', + resolvePath'ToAbsolute, resolveSplit', + -- * Project and branch resolution + getCurrentProjectAndBranch, + getCurrentProjectBranch, + -- * Branches -- ** Resolving branch identifiers @@ -20,18 +25,15 @@ module Unison.Cli.MonadUtils resolveShortCausalHash, -- ** Getting/setting branches - getRootBranch, - setRootBranch, - modifyRootBranch, - getRootBranch0, + getCurrentProjectRoot, + getCurrentProjectRoot0, getCurrentBranch, getCurrentBranch0, - getBranchAt, - getBranch0At, - getLastSavedRootHash, - setLastSavedRootHash, - getMaybeBranchAt, - getMaybeBranch0At, + getProjectBranchRoot, + getBranchFromProjectPath, + getBranch0FromProjectPath, + getMaybeBranchFromProjectPath, + getMaybeBranch0FromProjectPath, expectBranchAtPath, expectBranchAtPath', expectBranch0AtPath, @@ -43,13 +45,10 @@ module Unison.Cli.MonadUtils stepAt', stepAt, stepAtM, - stepAtNoSync', - stepAtNoSync, stepManyAt, - stepManyAtMNoSync, - stepManyAtNoSync, - syncRoot, - updateRoot, + stepManyAtM, + updateProjectBranchRoot, + updateProjectBranchRoot_, updateAtM, updateAt, updateAndStepAt, @@ -77,22 +76,27 @@ module Unison.Cli.MonadUtils expectLatestParsedFile, getLatestTypecheckedFile, expectLatestTypecheckedFile, + + -- * Parsing env + makeParsingEnv, ) where import Control.Lens import Control.Monad.Reader (ask) import Control.Monad.State -import Data.Configurator qualified as Configurator -import Data.Configurator.Types qualified as Configurator import Data.Foldable import Data.Set qualified as Set import U.Codebase.Branch qualified as V2 (Branch) import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash (..)) +import U.Codebase.Sqlite.Project (Project) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.Queries qualified as Q import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli +import Unison.Cli.UniqueTypeGuidLookup (loadUniqueTypeGuid) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch (..), Branch0) import Unison.Codebase.Branch qualified as Branch @@ -103,59 +107,79 @@ import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path (Path, Path' (..)) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath) +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name qualified as Name import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Parser.Ann (Ann (..)) import Unison.Prelude +import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Reference (TypeReference) import Unison.Referent (Referent) +import Unison.Sqlite (Transaction) import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Syntax.Name qualified as Name (toText) +import Unison.Syntax.Parser (ParsingEnv (..)) import Unison.Term qualified as Term import Unison.UnisonFile (TypecheckedUnisonFile, UnisonFile) import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UFN import Unison.Util.Set qualified as Set import Unison.Var qualified as Var -import UnliftIO.STM ------------------------------------------------------------------------------------------------------------------------ --- .unisonConfig things +-- Getting paths, path resolution, etc. --- | Lookup a config value by key. -getConfig :: (Configurator.Configured a) => Text -> Cli (Maybe a) -getConfig key = do - Cli.Env {config} <- ask - liftIO (Configurator.lookup config key) +getCurrentProjectPath :: Cli PP.ProjectPath +getCurrentProjectPath = do + ppIds <- Cli.getProjectPathIds + Cli.runTransaction $ Codebase.resolveProjectPathIds ppIds ------------------------------------------------------------------------------------------------------------------------- --- Getting paths, path resolution, etc. +getCurrentProjectAndBranch :: Cli (ProjectAndBranch Project ProjectBranch) +getCurrentProjectAndBranch = do + PP.toProjectAndBranch <$> getCurrentProjectPath + +getCurrentProjectBranch :: Cli ProjectBranch +getCurrentProjectBranch = do + view #branch <$> getCurrentProjectPath --- | Get the current path. +-- | Get the current path relative to the current project. getCurrentPath :: Cli Path.Absolute getCurrentPath = do - use #currentPath + view PP.absPath_ <$> getCurrentProjectPath + +getCurrentProjectName :: Cli ProjectName +getCurrentProjectName = do + view (#project . #name) <$> getCurrentProjectPath + +getCurrentProjectBranchName :: Cli ProjectBranchName +getCurrentProjectBranchName = do + view (#branch . #name) <$> getCurrentProjectPath -- | Resolve a @Path@ (interpreted as relative) to a @Path.Absolute@, per the current path. -resolvePath :: Path -> Cli Path.Absolute +resolvePath :: Path -> Cli PP.ProjectPath resolvePath path = do - currentPath <- getCurrentPath - pure (Path.resolve currentPath (Path.Relative path)) + pp <- getCurrentProjectPath + pure $ pp & PP.absPath_ %~ \p -> Path.resolve p path -- | Resolve a @Path'@ to a @Path.Absolute@, per the current path. -resolvePath' :: Path' -> Cli Path.Absolute -resolvePath' path = do - currentPath <- getCurrentPath - pure (Path.resolve currentPath path) +resolvePath' :: Path' -> Cli PP.ProjectPath +resolvePath' path' = do + pp <- getCurrentProjectPath + pure $ pp & PP.absPath_ %~ \p -> Path.resolve p path' + +resolvePath'ToAbsolute :: Path' -> Cli Path.Absolute +resolvePath'ToAbsolute path' = do + view PP.absPath_ <$> resolvePath' path' -- | Resolve a path split, per the current path. -resolveSplit' :: (Path', a) -> Cli (Path.Absolute, a) +resolveSplit' :: (Path', a) -> Cli (PP.ProjectPath, a) resolveSplit' = traverseOf _1 resolvePath' @@ -166,23 +190,27 @@ resolveSplit' = -- branches by path are OK - the empty branch will be returned). resolveAbsBranchId :: Input.AbsBranchId -> Cli (Branch IO) resolveAbsBranchId = \case - Left hash -> resolveShortCausalHash hash - Right path -> getBranchAt path + Input.BranchAtSCH hash -> resolveShortCausalHash hash + Input.BranchAtPath absPath -> do + pp <- resolvePath' (Path' (Left absPath)) + getBranchFromProjectPath pp + Input.BranchAtProjectPath pp -> getBranchFromProjectPath pp -- | V2 version of 'resolveAbsBranchId2'. resolveAbsBranchIdV2 :: (forall void. Output.Output -> Sqlite.Transaction void) -> + ProjectAndBranch Project ProjectBranch -> Input.AbsBranchId -> Sqlite.Transaction (V2.Branch Sqlite.Transaction) -resolveAbsBranchIdV2 rollback = \case - Left shortHash -> do +resolveAbsBranchIdV2 rollback (ProjectAndBranch proj branch) = \case + Input.BranchAtSCH shortHash -> do hash <- resolveShortCausalHashToCausalHash rollback shortHash - succeed (Codebase.expectCausalBranchByCausalHash hash) - Right path -> succeed (Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path)) - where - succeed getCausal = do - causal <- getCausal - V2Causal.value causal + causal <- (Codebase.expectCausalBranchByCausalHash hash) + V2Causal.value causal + Input.BranchAtPath absPath -> do + let pp = PP.ProjectPath proj branch absPath + Codebase.getShallowBranchAtProjectPath pp + Input.BranchAtProjectPath pp -> Codebase.getShallowBranchAtProjectPath pp -- | Resolve a @BranchId@ to the corresponding @Branch IO@, or fail if no such branch hash is found. (Non-existent -- branches by path are OK - the empty branch will be returned). @@ -194,7 +222,7 @@ resolveBranchId branchId = do -- | Resolve a @BranchId@ to an @AbsBranchId@. resolveBranchIdToAbsBranchId :: Input.BranchId -> Cli Input.AbsBranchId resolveBranchIdToAbsBranchId = - traverseOf _Right resolvePath' + traverse (fmap (view PP.absPath_) . resolvePath') -- | Resolve a @ShortCausalHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found. resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO) @@ -222,77 +250,54 @@ resolveShortCausalHashToCausalHash rollback shortHash = do -- Getting/Setting branches -- | Get the root branch. -getRootBranch :: Cli (Branch IO) -getRootBranch = do - use #root >>= atomically . readTMVar +getCurrentProjectRoot :: Cli (Branch IO) +getCurrentProjectRoot = do + Cli.Env {codebase} <- ask + ProjectAndBranch proj branch <- getCurrentProjectAndBranch + liftIO $ Codebase.expectProjectBranchRoot codebase proj.projectId branch.branchId -- | Get the root branch0. -getRootBranch0 :: Cli (Branch0 IO) -getRootBranch0 = - Branch.head <$> getRootBranch - --- | Set a new root branch. --- --- Note: This does _not_ update the codebase, the caller is responsible for that. -setRootBranch :: Branch IO -> Cli () -setRootBranch b = do - void $ modifyRootBranch (const b) - --- | Modify the root branch. --- --- Note: This does _not_ update the codebase, the caller is responsible for that. -modifyRootBranch :: (Branch IO -> Branch IO) -> Cli (Branch IO) -modifyRootBranch f = do - rootVar <- use #root - atomically do - root <- takeTMVar rootVar - let !newRoot = f root - putTMVar rootVar newRoot - pure newRoot +getCurrentProjectRoot0 :: Cli (Branch0 IO) +getCurrentProjectRoot0 = + Branch.head <$> getCurrentProjectRoot -- | Get the current branch. getCurrentBranch :: Cli (Branch IO) getCurrentBranch = do - path <- getCurrentPath Cli.Env {codebase} <- ask - liftIO $ Codebase.getBranchAtPath codebase path + pp <- getCurrentProjectPath + fromMaybe Branch.empty <$> liftIO (Codebase.getBranchAtProjectPath codebase pp) -- | Get the current branch0. getCurrentBranch0 :: Cli (Branch0 IO) getCurrentBranch0 = do Branch.head <$> getCurrentBranch --- | Get the last saved root hash. -getLastSavedRootHash :: Cli CausalHash -getLastSavedRootHash = do - use #lastSavedRootHash - --- | Set a new root branch. --- Note: This does _not_ update the codebase, the caller is responsible for that. -setLastSavedRootHash :: CausalHash -> Cli () -setLastSavedRootHash ch = do - #lastSavedRootHash .= ch - --- | Get the branch at an absolute path. -getBranchAt :: Path.Absolute -> Cli (Branch IO) -getBranchAt path = - getMaybeBranchAt path <&> fromMaybe Branch.empty +-- | Get the branch at an absolute path from the project root. +getBranchFromProjectPath :: PP.ProjectPath -> Cli (Branch IO) +getBranchFromProjectPath pp = + getMaybeBranchFromProjectPath pp <&> fromMaybe Branch.empty -- | Get the branch0 at an absolute path. -getBranch0At :: Path.Absolute -> Cli (Branch0 IO) -getBranch0At path = - Branch.head <$> getBranchAt path +getBranch0FromProjectPath :: PP.ProjectPath -> Cli (Branch0 IO) +getBranch0FromProjectPath pp = + Branch.head <$> getBranchFromProjectPath pp + +getProjectBranchRoot :: ProjectBranch -> Cli (Branch IO) +getProjectBranchRoot projectBranch = do + Cli.Env {codebase} <- ask + liftIO $ Codebase.expectProjectBranchRoot codebase projectBranch.projectId projectBranch.branchId -- | Get the maybe-branch at an absolute path. -getMaybeBranchAt :: Path.Absolute -> Cli (Maybe (Branch IO)) -getMaybeBranchAt path = do - rootBranch <- getRootBranch - pure (Branch.getAt (Path.unabsolute path) rootBranch) +getMaybeBranchFromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch IO)) +getMaybeBranchFromProjectPath pp = do + Cli.Env {codebase} <- ask + liftIO $ Codebase.getBranchAtProjectPath codebase pp -- | Get the maybe-branch0 at an absolute path. -getMaybeBranch0At :: Path.Absolute -> Cli (Maybe (Branch0 IO)) -getMaybeBranch0At path = - fmap Branch.head <$> getMaybeBranchAt path +getMaybeBranch0FromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch0 IO)) +getMaybeBranch0FromProjectPath pp = + fmap Branch.head <$> getMaybeBranchFromProjectPath pp -- | Get the branch at a relative path, or return early if there's no such branch. expectBranchAtPath :: Path -> Cli (Branch IO) @@ -303,7 +308,7 @@ expectBranchAtPath = expectBranchAtPath' :: Path' -> Cli (Branch IO) expectBranchAtPath' path0 = do path <- resolvePath' path0 - getMaybeBranchAt path & onNothingM (Cli.returnEarly (Output.BranchNotFound path0)) + getMaybeBranchFromProjectPath path & onNothingM (Cli.returnEarly (Output.BranchNotFound path0)) -- | Get the branch0 at an absolute or relative path, or return early if there's no such branch. expectBranch0AtPath' :: Path' -> Cli (Branch0 IO) @@ -329,167 +334,138 @@ assertNoBranchAtPath' path' = do -- current terms/types etc). branchExistsAtPath' :: Path' -> Cli Bool branchExistsAtPath' path' = do - absPath <- resolvePath' path' + pp <- resolvePath' path' Cli.runTransaction do - causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute absPath) - branch <- V2Causal.value causal + branch <- Codebase.getShallowBranchAtProjectPath pp isEmpty <- V2Branch.isEmpty branch pure (not isEmpty) ------------------------------------------------------------------------------------------------------------------------ -- Updating branches +makeActionsUnabsolute :: (Functor f) => f (Path.Absolute, x) -> f (Path, x) +makeActionsUnabsolute = fmap (first Path.unabsolute) + stepAt :: Text -> - (Path, Branch0 IO -> Branch0 IO) -> + (ProjectPath, Branch0 IO -> Branch0 IO) -> Cli () -stepAt cause = stepManyAt @[] cause . pure +stepAt cause (pp, action) = stepManyAt pp.branch cause [(pp.absPath, action)] stepAt' :: Text -> - (Path, Branch0 IO -> Cli (Branch0 IO)) -> + (ProjectPath, Branch0 IO -> Cli (Branch0 IO)) -> Cli Bool -stepAt' cause = stepManyAt' @[] cause . pure - -stepAtNoSync' :: - (Path, Branch0 IO -> Cli (Branch0 IO)) -> - Cli Bool -stepAtNoSync' = stepManyAtNoSync' @[] . pure - -stepAtNoSync :: - (Path, Branch0 IO -> Branch0 IO) -> - Cli () -stepAtNoSync = stepManyAtNoSync @[] . pure +stepAt' cause (pp, action) = stepManyAt' pp.branch cause [(pp.absPath, action)] stepAtM :: Text -> - (Path, Branch0 IO -> IO (Branch0 IO)) -> + (ProjectPath, Branch0 IO -> IO (Branch0 IO)) -> Cli () -stepAtM cause = stepManyAtM @[] cause . pure +stepAtM cause (pp, action) = stepManyAtM pp.branch cause [(pp.absPath, action)] stepManyAt :: - (Foldable f) => + ProjectBranch -> Text -> - f (Path, Branch0 IO -> Branch0 IO) -> + [(Path.Absolute, Branch0 IO -> Branch0 IO)] -> Cli () -stepManyAt reason actions = do - stepManyAtNoSync actions - syncRoot reason +stepManyAt pb reason actions = do + updateProjectBranchRoot_ pb reason $ Branch.stepManyAt (makeActionsUnabsolute actions) stepManyAt' :: - (Foldable f) => + ProjectBranch -> Text -> - f (Path, Branch0 IO -> Cli (Branch0 IO)) -> - Cli Bool -stepManyAt' reason actions = do - res <- stepManyAtNoSync' actions - syncRoot reason - pure res - -stepManyAtNoSync' :: - (Foldable f) => - f (Path, Branch0 IO -> Cli (Branch0 IO)) -> + [(Path.Absolute, Branch0 IO -> Cli (Branch0 IO))] -> Cli Bool -stepManyAtNoSync' actions = do - origRoot <- getRootBranch - newRoot <- Branch.stepManyAtM actions origRoot - setRootBranch newRoot - pure (origRoot /= newRoot) +stepManyAt' pb reason actions = do + origRoot <- getProjectBranchRoot pb + newRoot <- Branch.stepManyAtM (makeActionsUnabsolute actions) origRoot + didChange <- updateProjectBranchRoot pb reason (\oldRoot -> pure (newRoot, oldRoot /= newRoot)) + pure didChange -- Like stepManyAt, but doesn't update the last saved root -stepManyAtNoSync :: - (Foldable f) => - f (Path, Branch0 IO -> Branch0 IO) -> - Cli () -stepManyAtNoSync actions = - void . modifyRootBranch $ Branch.stepManyAt actions - stepManyAtM :: - (Foldable f) => + ProjectBranch -> Text -> - f (Path, Branch0 IO -> IO (Branch0 IO)) -> - Cli () -stepManyAtM reason actions = do - stepManyAtMNoSync actions - syncRoot reason - -stepManyAtMNoSync :: - (Foldable f) => - f (Path, Branch0 IO -> IO (Branch0 IO)) -> + [(Path.Absolute, Branch0 IO -> IO (Branch0 IO))] -> Cli () -stepManyAtMNoSync actions = do - oldRoot <- getRootBranch - newRoot <- liftIO (Branch.stepManyAtM actions oldRoot) - setRootBranch newRoot - --- | Sync the in-memory root branch. -syncRoot :: Text -> Cli () -syncRoot description = do - rootBranch <- getRootBranch - updateRoot rootBranch description +stepManyAtM pb reason actions = do + updateProjectBranchRoot pb reason \oldRoot -> do + newRoot <- liftIO (Branch.stepManyAtM (makeActionsUnabsolute actions) oldRoot) + pure (newRoot, ()) -- | Update a branch at the given path, returning `True` if -- an update occurred and false otherwise updateAtM :: Text -> - Path.Absolute -> + ProjectPath -> (Branch IO -> Cli (Branch IO)) -> Cli Bool -updateAtM reason (Path.Absolute p) f = do - b <- getRootBranch - b' <- Branch.modifyAtM p f b - updateRoot b' reason - pure $ b /= b' +updateAtM reason pp f = do + oldRootBranch <- getProjectBranchRoot (pp ^. #branch) + newRootBranch <- Branch.modifyAtM (pp ^. PP.path_) f oldRootBranch + updateProjectBranchRoot_ (pp ^. #branch) reason (const newRootBranch) + pure $ oldRootBranch /= newRootBranch -- | Update a branch at the given path, returning `True` if -- an update occurred and false otherwise updateAt :: Text -> - Path.Absolute -> + ProjectPath -> (Branch IO -> Branch IO) -> Cli Bool -updateAt reason p f = do - updateAtM reason p (pure . f) +updateAt reason pp f = do + updateAtM reason pp (pure . f) updateAndStepAt :: - (Foldable f, Foldable g) => + (Foldable f, Foldable g, Functor g) => Text -> + ProjectBranch -> f (Path.Absolute, Branch IO -> Branch IO) -> - g (Path, Branch0 IO -> Branch0 IO) -> + g (Path.Absolute, Branch0 IO -> Branch0 IO) -> Cli () -updateAndStepAt reason updates steps = do - root <- - (Branch.stepManyAt steps) - . (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates) - <$> getRootBranch - updateRoot root reason - -updateRoot :: Branch IO -> Text -> Cli () -updateRoot new reason = - Cli.time "updateRoot" do - Cli.Env {codebase} <- ask - let newHash = Branch.headHash new - oldHash <- getLastSavedRootHash - when (oldHash /= newHash) do - liftIO (Codebase.putRootBranch codebase reason new) - setRootBranch new - setLastSavedRootHash newHash +updateAndStepAt reason projectBranch updates steps = do + let f b = + b + & (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates) + & (Branch.stepManyAt (first Path.unabsolute <$> steps)) + updateProjectBranchRoot_ projectBranch reason f + +updateProjectBranchRoot :: ProjectBranch -> Text -> (Branch IO -> Cli (Branch IO, r)) -> Cli r +updateProjectBranchRoot projectBranch reason f = do + Cli.Env {codebase} <- ask + Cli.time "updateProjectBranchRoot" do + old <- getProjectBranchRoot projectBranch + (new, result) <- f old + when (old /= new) do + liftIO $ Codebase.putBranch codebase new + Cli.runTransaction $ do + -- TODO: If we transactionally check that the project branch hasn't changed while we were computing the new + -- branch, and if it has, abort the transaction and return an error, then we can + -- remove the single UCM per codebase restriction. + causalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash new) + Q.setProjectBranchHead reason (projectBranch ^. #projectId) (projectBranch ^. #branchId) causalHashId + pure result + +updateProjectBranchRoot_ :: ProjectBranch -> Text -> (Branch IO -> Branch IO) -> Cli () +updateProjectBranchRoot_ projectBranch reason f = do + updateProjectBranchRoot projectBranch reason (\b -> pure (f b, ())) ------------------------------------------------------------------------------------------------------------------------ -- Getting terms -getTermsAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set Referent) -getTermsAt path = do - rootBranch0 <- getRootBranch0 - pure (BranchUtil.getTerm (Path.convert path) rootBranch0) +getTermsAt :: (PP.ProjectPath, HQ'.HQSegment) -> Cli (Set Referent) +getTermsAt (pp, hqSeg) = do + rootBranch0 <- getBranch0FromProjectPath pp + pure (BranchUtil.getTerm (mempty, hqSeg) rootBranch0) ------------------------------------------------------------------------------------------------------------------------ -- Getting types -getTypesAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set TypeReference) -getTypesAt path = do - rootBranch0 <- getRootBranch0 - pure (BranchUtil.getType (Path.convert path) rootBranch0) +getTypesAt :: (PP.ProjectPath, HQ'.HQSegment) -> Cli (Set TypeReference) +getTypesAt (pp, hqSeg) = do + rootBranch0 <- getBranch0FromProjectPath pp + pure (BranchUtil.getType (mempty, hqSeg) rootBranch0) ------------------------------------------------------------------------------------------------------------------------ -- Getting patches @@ -507,8 +483,8 @@ getPatchAt path = -- | Get the patch at a path. getMaybePatchAt :: Path.Split' -> Cli (Maybe Patch) getMaybePatchAt path0 = do - (path, name) <- resolveSplit' path0 - branch <- getBranch0At path + (pp, name) <- resolveSplit' path0 + branch <- getBranch0FromProjectPath pp liftIO (Branch.getMaybePatch name branch) ------------------------------------------------------------------------------------------------------------------------ @@ -570,3 +546,17 @@ getNamesFromLatestFile = do expectLatestTypecheckedFile :: Cli (TypecheckedUnisonFile Symbol Ann) expectLatestTypecheckedFile = getLatestTypecheckedFile & onNothingM (Cli.returnEarly Output.NoUnisonFile) + +-- @makeParsingEnv path names@ makes a parsing environment with @names@ in scope, which are all relative to @path@. +makeParsingEnv :: ProjectPath -> Names -> Cli (ParsingEnv Transaction) +makeParsingEnv path names = do + Cli.Env {generateUniqueName} <- ask + uniqueName <- liftIO generateUniqueName + pure do + ParsingEnv + { uniqueNames = uniqueName, + uniqueTypeGuid = loadUniqueTypeGuid path, + names, + maybeNamespace = Nothing, + localNamespacePrefixedTypesAndConstructors = mempty + } diff --git a/unison-cli/src/Unison/Cli/NameResolutionUtils.hs b/unison-cli/src/Unison/Cli/NameResolutionUtils.hs new file mode 100644 index 0000000000..92b06f1e95 --- /dev/null +++ b/unison-cli/src/Unison/Cli/NameResolutionUtils.hs @@ -0,0 +1,51 @@ +-- | Utilities related to resolving names to things. +module Unison.Cli.NameResolutionUtils + ( resolveHQName, + resolveHQToLabeledDependencies, + ) +where + +import Control.Monad.Reader (ask) +import Data.Bifoldable (bifoldMap) +import Data.Set qualified as Set +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.NamesUtils qualified as Cli +import Unison.HashQualified qualified as HQ +import Unison.LabeledDependency (LabeledDependency) +import Unison.LabeledDependency qualified as LD +import Unison.Name (Name) +import Unison.Name qualified as Name +import Unison.Names qualified as Names +import Unison.Prelude +import Unison.Reference (TypeReference) +import Unison.Referent (Referent) +import Unison.Server.NameSearch.Sqlite qualified as Sqlite +import Unison.ShortHash (ShortHash) +import Unison.Util.Defns (Defns (..), DefnsF) + +resolveHQName :: HQ.HashQualified Name -> Cli (DefnsF Set Referent TypeReference) +resolveHQName = \case + HQ.NameOnly name -> do + names <- Cli.currentNames + pure + Defns + { terms = Name.searchByRankedSuffix name names.terms, + types = Name.searchByRankedSuffix name names.types + } + -- rationale: the hash should be unique enough that the name never helps + -- mitchell says: that seems wrong + HQ.HashQualified _n hash -> resolveHashOnly hash + HQ.HashOnly hash -> resolveHashOnly hash + where + resolveHashOnly :: ShortHash -> Cli (DefnsF Set Referent TypeReference) + resolveHashOnly hash = do + env <- ask + Cli.runTransaction do + terms <- Sqlite.termReferentsByShortHash env.codebase hash + types <- Sqlite.typeReferencesByShortHash hash + pure Defns {terms, types} + +resolveHQToLabeledDependencies :: HQ.HashQualified Name -> Cli (Set LabeledDependency) +resolveHQToLabeledDependencies = + fmap (bifoldMap (Set.map LD.referent) (Set.map LD.typeRef)) . resolveHQName diff --git a/unison-cli/src/Unison/Cli/NamesUtils.hs b/unison-cli/src/Unison/Cli/NamesUtils.hs index 8e36020459..889e055bdf 100644 --- a/unison-cli/src/Unison/Cli/NamesUtils.hs +++ b/unison-cli/src/Unison/Cli/NamesUtils.hs @@ -1,15 +1,27 @@ -- | Utilities that have to do with constructing names objects. module Unison.Cli.NamesUtils ( currentNames, + currentProjectRootNames, + projectBranchNames, ) where +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch) import Unison.Cli.Monad (Cli) -import Unison.Cli.MonadUtils (getCurrentBranch0) +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Names qualified as Branch import Unison.Names (Names) -- | Produce a 'Names' object which contains names for the current branch. currentNames :: Cli Names currentNames = do - Branch.toNames <$> getCurrentBranch0 + Branch.toNames <$> Cli.getCurrentBranch0 + +currentProjectRootNames :: Cli Names +currentProjectRootNames = do + Branch.toNames <$> Cli.getCurrentProjectRoot0 + +projectBranchNames :: ProjectBranch -> Cli Names +projectBranchNames pb = do + Branch.toNames . Branch.head <$> Cli.getProjectBranchRoot pb diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index a336d860d2..9b72ee98d8 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -5,7 +5,8 @@ module Unison.Cli.Pretty ( displayBranchHash, prettyAbsolute, - prettyAbsoluteStripProject, + prettyProjectPath, + prettyBranchRelativePath, prettyBase32Hex#, prettyBase32Hex, prettyBranchId, @@ -33,11 +34,12 @@ module Unison.Cli.Pretty prettyRepoInfo, prettySCH, prettySemver, - prettyShareLink, prettySharePath, prettyShareURI, prettySlashProjectBranchName, + prettyTerm, prettyTermName, + prettyType, prettyTypeName, prettyTypeResultHeader', prettyTypeResultHeaderFull', @@ -47,22 +49,17 @@ module Unison.Cli.Pretty prettyWriteRemoteNamespace, shareOrigin, unsafePrettyTermResultSigFull', - prettyTermDisplayObjects, - prettyTypeDisplayObjects, ) where import Control.Lens hiding (at) import Control.Monad.Writer (Writer, runWriter) -import Data.List qualified as List import Data.Map qualified as Map import Data.Set qualified as Set -import Data.Text qualified as Text import Data.Time (UTCTime) import Data.Time.Format.Human (HumanTimeLocale (..), defaultHumanTimeLocale, humanReadableTimeI18N') import Network.URI (URI) import Network.URI qualified as URI -import Network.URI.Encode qualified as URI import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Reference qualified as Reference import U.Codebase.Sqlite.Project qualified as Sqlite @@ -70,23 +67,20 @@ import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Util.Base32Hex (Base32Hex) import U.Util.Base32Hex qualified as Base32Hex import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..)) -import Unison.Cli.ProjectUtils (projectBranchPathPrism) import Unison.Cli.Share.Projects.Types qualified as Share import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject)) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.RemoteRepo ( ReadRemoteNamespace (..), - ShareUserHandle (..), - WriteRemoteNamespace (..), - WriteShareRemoteNamespace (..), - shareUserHandleToText, ) import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo -import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath) +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH +import Unison.CommandLine.BranchRelativePath (BranchRelativePath) import Unison.Core.Project (ProjectBranchName) import Unison.DataDeclaration qualified as DD import Unison.Debug qualified as Debug @@ -94,10 +88,9 @@ import Unison.Hash qualified as Hash import Unison.Hash32 (Hash32) import Unison.Hash32 qualified as Hash32 import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.LabeledDependency as LD import Unison.Name (Name) -import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.NameSegment.Internal qualified as NameSegment import Unison.Parser.Ann (Ann) @@ -107,11 +100,10 @@ import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnv.Util qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Project (ProjectAndBranch (..), ProjectName, Semver (..)) -import Unison.Reference (Reference, TermReferenceId) +import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) -import Unison.Referent qualified as Referent -import Unison.Server.SearchResult' qualified as SR' +import Unison.Server.SearchResultPrime qualified as SR' import Unison.ShortHash (ShortHash) import Unison.Symbol (Symbol) import Unison.Sync.Types qualified as Share @@ -126,6 +118,7 @@ import Unison.Term (Term) import Unison.Type (Type) import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UF +import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty qualified as P import Unison.Var (Var) import Unison.Var qualified as Var @@ -150,7 +143,7 @@ prettyReadRemoteNamespaceWith :: (a -> Text) -> ReadRemoteNamespace a -> Pretty prettyReadRemoteNamespaceWith printProject = P.group . P.blue . P.text . RemoteRepo.printReadRemoteNamespace printProject -prettyWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty +prettyWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty prettyWriteRemoteNamespace = P.group . P.blue . P.text . RemoteRepo.printWriteRemoteNamespace @@ -161,14 +154,6 @@ prettyRepoInfo :: Share.RepoInfo -> Pretty prettyRepoInfo (Share.RepoInfo repoInfo) = P.blue (P.text repoInfo) -prettyShareLink :: WriteShareRemoteNamespace -> Pretty -prettyShareLink WriteShareRemoteNamespace {repo, path} = - let encodedPath = - Path.toList path - & fmap (URI.encodeText . NameSegment.toUnescapedText) - & Text.intercalate "/" - in P.green . P.text $ shareOrigin <> "/@" <> shareUserHandleToText repo <> "/p/code/latest/namespaces/" <> encodedPath - prettySharePath :: Share.Path -> Pretty prettySharePath = prettyRelative @@ -194,16 +179,17 @@ prettyPath' p' = then "the current namespace" else P.blue (P.shown p') -prettyNamespaceKey :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Pretty +prettyNamespaceKey :: Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Pretty prettyNamespaceKey = \case - Left path -> prettyPath' path + Left path -> prettyProjectPath path Right (ProjectAndBranch project branch) -> prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name)) prettyBranchId :: Input.AbsBranchId -> Pretty prettyBranchId = \case - Left sch -> prettySCH sch - Right absPath -> prettyAbsolute $ absPath + Input.BranchAtSCH sch -> prettySCH sch + Input.BranchAtPath absPath -> prettyAbsolute $ absPath + Input.BranchAtProjectPath pp -> prettyProjectPath pp prettyRelative :: Path.Relative -> Pretty prettyRelative = P.blue . P.shown @@ -211,6 +197,13 @@ prettyRelative = P.blue . P.shown prettyAbsolute :: Path.Absolute -> Pretty prettyAbsolute = P.blue . P.shown +prettyProjectPath :: PP.ProjectPath -> Pretty +prettyProjectPath (PP.ProjectPath project branch path) = + prettyProjectAndBranchName (ProjectAndBranch project.name branch.name) + <> + -- Only show the path if it's not the root + Monoid.whenM (path /= Path.absoluteEmpty) (P.cyan (":" <> P.shown path)) + prettySCH :: (IsString s) => ShortCausalHash -> P.Pretty s prettySCH hash = P.group $ "#" <> P.text (SCH.toText hash) @@ -271,6 +264,9 @@ prettyProjectAndBranchName :: ProjectAndBranch ProjectName ProjectBranchName -> prettyProjectAndBranchName (ProjectAndBranch project branch) = P.group (prettyProjectName project <> P.hiBlack "/" <> prettyProjectBranchName branch) +prettyBranchRelativePath :: BranchRelativePath -> Pretty +prettyBranchRelativePath = P.blue . P.text . into @Text + -- produces: -- -- #5v5UtREE1fTiyTsTK2zJ1YNqfiF25SkfUnnji86Lms#0 -- Optional.None, Maybe.Nothing : Maybe a @@ -343,7 +339,7 @@ prettyTypeName ppe r = prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty prettyWhichBranchEmpty = \case WhichBranchEmptyHash hash -> P.shown hash - WhichBranchEmptyPath path -> prettyPath' path + WhichBranchEmptyPath pp -> prettyProjectPath pp -- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef displayBranchHash :: CausalHash -> Text @@ -389,15 +385,6 @@ prettyRemoteBranchInfo (host, remoteProject, remoteBranch) = <> " on " <> P.shown host -stripProjectBranchInfo :: Path.Absolute -> Maybe Path.Path -stripProjectBranchInfo = fmap snd . preview projectBranchPathPrism - -prettyAbsoluteStripProject :: Path.Absolute -> Pretty -prettyAbsoluteStripProject path = - P.blue case stripProjectBranchInfo path of - Just p -> P.shown p - Nothing -> P.shown path - prettyLabeledDependencies :: PPE.PrettyPrintEnv -> Set LabeledDependency -> Pretty prettyLabeledDependencies ppe lds = P.syntaxToColor (P.sep ", " (ld <$> toList lds)) @@ -449,34 +436,6 @@ prettyUnisonFile ppe uf@(UF.UnisonFileId datas effects terms watches) = rd = Reference.DerivedId hqv v = HQ.unsafeFromVar v -prettyTypeDisplayObjects :: - PPED.PrettyPrintEnvDecl -> - (Map Reference (DisplayObject () (DD.Decl Symbol Ann))) -> - [P.Pretty SyntaxText] -prettyTypeDisplayObjects pped types = - types - & Map.toList - & map (\(ref, dt) -> (PPE.typeName unsuffixifiedPPE ref, ref, dt)) - & List.sortBy (\(n0, _, _) (n1, _, _) -> Name.compareAlphabetical n0 n1) - & map (prettyType pped) - where - unsuffixifiedPPE = PPED.unsuffixifiedPPE pped - -prettyTermDisplayObjects :: - PPED.PrettyPrintEnvDecl -> - Bool -> - (TermReferenceId -> Bool) -> - (Map Reference.TermReference (DisplayObject (Type Symbol Ann) (Term Symbol Ann))) -> - [P.Pretty SyntaxText] -prettyTermDisplayObjects pped isSourceFile isTest terms = - terms - & Map.toList - & map (\(ref, dt) -> (PPE.termName unsuffixifiedPPE (Referent.Ref ref), ref, dt)) - & List.sortBy (\(n0, _, _) (n1, _, _) -> Name.compareAlphabetical n0 n1) - & map (\t -> prettyTerm pped isSourceFile (fromMaybe False . fmap isTest . Reference.toId $ (t ^. _2)) t) - where - unsuffixifiedPPE = PPED.unsuffixifiedPPE pped - prettyTerm :: PPED.PrettyPrintEnvDecl -> Bool {- whether we're printing to a source-file or not. -} -> diff --git a/unison-cli/src/Unison/Cli/PrettyPrintUtils.hs b/unison-cli/src/Unison/Cli/PrettyPrintUtils.hs deleted file mode 100644 index 17abdd49c5..0000000000 --- a/unison-cli/src/Unison/Cli/PrettyPrintUtils.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | Utilities that have to do with constructing pretty-print environments, given stateful information in the Cli monad --- state/environment, such as the current path. -module Unison.Cli.PrettyPrintUtils - ( prettyPrintEnvDeclFromNames, - currentPrettyPrintEnvDecl, - ) -where - -import Unison.Cli.Monad (Cli) -import Unison.Cli.Monad qualified as Cli -import Unison.Cli.NamesUtils qualified as Cli -import Unison.Codebase qualified as Codebase -import Unison.Names (Names) -import Unison.Prelude -import Unison.PrettyPrintEnv.Names qualified as PPE -import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo) -import Unison.PrettyPrintEnvDecl.Names qualified as PPED - --- | Builds a pretty print env decl from a names object. -prettyPrintEnvDeclFromNames :: Names -> Cli PPE.PrettyPrintEnvDecl -prettyPrintEnvDeclFromNames ns = - Cli.runTransaction Codebase.hashLength <&> \hashLen -> - PPED.makePPED (PPE.hqNamer hashLen ns) (PPE.suffixifyByHash ns) - --- | Get a pretty print env decl for the current names at the current path. --- --- Prefer using 'prettyPrintEnvDeclFromNames' when you've already got --- a 'Names' value around, since using 'currentPrettyPrintEnvDecl' rebuilds the underlying --- names object. -currentPrettyPrintEnvDecl :: Cli PPE.PrettyPrintEnvDecl -currentPrettyPrintEnvDecl = do - Cli.currentNames >>= prettyPrintEnvDeclFromNames diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index d62e63ca5a..4f196c1b61 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -1,21 +1,10 @@ -- | Project-related utilities. module Unison.Cli.ProjectUtils ( -- * Project/path helpers - getCurrentProject, - expectCurrentProject, - expectCurrentProjectIds, - getCurrentProjectIds, - getCurrentProjectBranch, - getProjectBranchForPath, - expectCurrentProjectBranch, expectProjectBranchByName, - projectPath, - projectBranchesPath, - projectBranchPath, - projectBranchSegment, - projectBranchPathPrism, resolveBranchRelativePath, - branchRelativePathToAbsolute, + resolveProjectBranch, + resolveProjectBranchInProject, -- * Name hydration hydrateNames, @@ -23,9 +12,8 @@ module Unison.Cli.ProjectUtils -- * Loading local project info expectProjectAndBranchByIds, getProjectAndBranchByTheseNames, - expectProjectAndBranchByTheseNames, getProjectAndBranchByNames, - expectLooseCodeOrProjectBranch, + expectProjectAndBranchByTheseNames, getProjectBranchCausalHash, -- * Loading remote project info @@ -59,73 +47,51 @@ import Data.Maybe (fromJust) import Data.Set qualified as Set import Data.Text qualified as Text import Data.These (These (..)) -import U.Codebase.Causal qualified import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.DbId +import U.Codebase.Sqlite.Project (Project) import U.Codebase.Sqlite.Project qualified as Sqlite +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite +import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.Share.Projects (IncludeSquashedHead) import Unison.Cli.Share.Projects qualified as Share -import Unison.Codebase qualified as Codebase -import Unison.Codebase.Editor.Input (LooseCodeOrProject) import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist)) import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path -import Unison.CommandLine.BranchRelativePath (BranchRelativePath, ResolvedBranchRelativePath) -import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath +import Unison.Codebase.ProjectPath qualified as PP +import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..)) import Unison.Core.Project (ProjectBranchName (..)) import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectName) -import Unison.Project.Util import Unison.Sqlite (Transaction) import Unison.Sqlite qualified as Sqlite import Witch (unsafeFrom) -branchRelativePathToAbsolute :: BranchRelativePath -> Cli Path.Absolute -branchRelativePathToAbsolute brp = - resolveBranchRelativePath brp <&> \case - BranchRelativePath.ResolvedLoosePath p -> p - BranchRelativePath.ResolvedBranchRelative projectBranch mRel -> - let projectBranchIds = getIds projectBranch - handleRel = case mRel of - Nothing -> id - Just rel -> flip Path.resolve rel - in handleRel (projectBranchPath projectBranchIds) - where - getIds = \case - ProjectAndBranch project branch -> ProjectAndBranch (view #projectId project) (view #branchId branch) - -resolveBranchRelativePath :: BranchRelativePath -> Cli ResolvedBranchRelativePath -resolveBranchRelativePath = \case - BranchRelativePath.BranchRelative brp -> case brp of - This projectBranch -> do - projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch) - pure (BranchRelativePath.ResolvedBranchRelative projectBranch Nothing) - That path -> do - (projectBranch, _) <- expectCurrentProjectBranch - pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path)) - These projectBranch path -> do - projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch) - pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path)) - BranchRelativePath.LoosePath path -> - BranchRelativePath.ResolvedLoosePath <$> Cli.resolvePath' path - where - toThese = \case - Left branchName -> That branchName - Right (projectName, branchName) -> These projectName branchName +resolveBranchRelativePath :: BranchRelativePath -> Cli PP.ProjectPath +resolveBranchRelativePath brp = do + case brp of + BranchPathInCurrentProject projBranchName path -> do + projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName) + pure $ PP.fromProjectAndBranch projectAndBranch path + QualifiedBranchPath projName projBranchName path -> do + projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName) + pure $ PP.fromProjectAndBranch projectAndBranch path + UnqualifiedPath newPath' -> do + pp <- Cli.getCurrentProjectPath + pure $ pp & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath' justTheIds :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId justTheIds x = ProjectAndBranch x.project.projectId x.branch.branchId justTheIds' :: Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId -justTheIds' x = - ProjectAndBranch x.projectId x.branchId +justTheIds' branch = + ProjectAndBranch branch.projectId branch.branchId justTheNames :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectName ProjectBranchName justTheNames x = @@ -152,58 +118,11 @@ findTemporaryBranchName projectId preferred = do pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates)) --- | Get the current project that a user is on. -getCurrentProject :: Cli (Maybe Sqlite.Project) -getCurrentProject = do - path <- Cli.getCurrentPath - case preview projectBranchPathPrism path of - Nothing -> pure Nothing - Just (ProjectAndBranch projectId _branchId, _restPath) -> - Cli.runTransaction do - project <- Queries.expectProject projectId - pure (Just project) - --- | Like 'getCurrentProject', but fails with a message if the user is not on a project branch. -expectCurrentProject :: Cli Sqlite.Project -expectCurrentProject = do - getCurrentProject & onNothingM (Cli.returnEarly Output.NotOnProjectBranch) - --- | Get the current project ids that a user is on. -getCurrentProjectIds :: Cli (Maybe (ProjectAndBranch ProjectId ProjectBranchId)) -getCurrentProjectIds = - fmap fst . preview projectBranchPathPrism <$> Cli.getCurrentPath - --- | Like 'getCurrentProjectIds', but fails with a message if the user is not on a project branch. -expectCurrentProjectIds :: Cli (ProjectAndBranch ProjectId ProjectBranchId) -expectCurrentProjectIds = - getCurrentProjectIds & onNothingM (Cli.returnEarly Output.NotOnProjectBranch) - --- | Get the current project+branch+branch path that a user is on. -getCurrentProjectBranch :: Cli (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path)) -getCurrentProjectBranch = do - path <- Cli.getCurrentPath - getProjectBranchForPath path - expectProjectBranchByName :: Sqlite.Project -> ProjectBranchName -> Cli Sqlite.ProjectBranch expectProjectBranchByName project branchName = Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName)) -getProjectBranchForPath :: Path.Absolute -> Cli (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path)) -getProjectBranchForPath path = do - case preview projectBranchPathPrism path of - Nothing -> pure Nothing - Just (ProjectAndBranch projectId branchId, restPath) -> - Cli.runTransaction do - project <- Queries.expectProject projectId - branch <- Queries.expectProjectBranch projectId branchId - pure (Just (ProjectAndBranch project branch, restPath)) - --- | Like 'getCurrentProjectBranch', but fails with a message if the user is not on a project branch. -expectCurrentProjectBranch :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path) -expectCurrentProjectBranch = - getCurrentProjectBranch & onNothingM (Cli.returnEarly Output.NotOnProjectBranch) - -- We often accept a `These ProjectName ProjectBranchName` from the user, so they can leave off either a project or -- branch name, which we infer. This helper "hydrates" such a type to a `(ProjectName, BranchName)`, using the following -- defaults if a name is missing: @@ -214,8 +133,8 @@ hydrateNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch Pro hydrateNames = \case This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main")) That branchName -> do - (ProjectAndBranch project _branch, _restPath) <- expectCurrentProjectBranch - pure (ProjectAndBranch (project ^. #name) branchName) + pp <- Cli.getCurrentProjectPath + pure (ProjectAndBranch (pp ^. #project . #name) branchName) These projectName branchName -> pure (ProjectAndBranch projectName branchName) getProjectAndBranchByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) @@ -244,11 +163,15 @@ getProjectAndBranchByTheseNames :: getProjectAndBranchByTheseNames = \case This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main")) That branchName -> runMaybeT do - (ProjectAndBranch project _branch, _restPath) <- MaybeT getCurrentProjectBranch - branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName)) - pure (ProjectAndBranch project branch) - These projectName branchName -> - Cli.runTransaction (getProjectAndBranchByNames (ProjectAndBranch projectName branchName)) + (PP.ProjectPath proj _branch _path) <- lift Cli.getCurrentProjectPath + branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (proj ^. #projectId) branchName)) + pure (ProjectAndBranch proj branch) + These projectName branchName -> do + Cli.runTransaction do + runMaybeT do + project <- MaybeT (Queries.loadProjectByName projectName) + branch <- MaybeT (Queries.loadProjectBranchByName (project ^. #projectId) branchName) + pure (ProjectAndBranch project branch) -- Expect a local project branch by a "these names", using the following defaults if a name is missing: -- @@ -260,7 +183,7 @@ expectProjectAndBranchByTheseNames :: expectProjectAndBranchByTheseNames = \case This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main")) That branchName -> do - (ProjectAndBranch project _branch, _restPath) <- expectCurrentProjectBranch + PP.ProjectPath project _branch _restPath <- Cli.getCurrentProjectPath branch <- Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName)) @@ -275,31 +198,33 @@ expectProjectAndBranchByTheseNames = \case maybeProjectAndBranch & onNothing do Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) --- | Expect/resolve a possibly-ambiguous "loose code or project", with the following rules: +-- | Expect/resolve branch reference with the following rules: -- --- 1. If we have an unambiguous `/branch` or `project/branch`, look up in the database. --- 2. If we have an unambiguous `loose.code.path`, just return it. --- 3. If we have an ambiguous `foo`, *because we do not currently have an unambiguous syntax for relative paths*, --- we elect to treat it as a loose code path (because `/branch` can be selected with a leading forward slash). -expectLooseCodeOrProjectBranch :: - These Path' (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) -> - Cli (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -expectLooseCodeOrProjectBranch = - _Right expectProjectAndBranchByTheseNames . f - where - f :: LooseCodeOrProject -> Either Path' (These ProjectName ProjectBranchName) -- (Maybe ProjectName, ProjectBranchName) - f = \case - This path -> Left path - That (ProjectAndBranch Nothing branch) -> Right (That branch) - That (ProjectAndBranch (Just project) branch) -> Right (These project branch) - These path _ -> Left path -- (3) above +-- 1. If the project is missing, use the provided project. +-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the provided +-- project, defaulting to 'main' if branch is unspecified. +resolveProjectBranchInProject :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) +resolveProjectBranchInProject defaultProj (ProjectAndBranch mayProjectName mayBranchName) = do + let branchName = fromMaybe (unsafeFrom @Text "main") mayBranchName + let projectName = fromMaybe (defaultProj ^. #name) mayProjectName + projectAndBranch <- expectProjectAndBranchByTheseNames (These projectName branchName) + pure projectAndBranch + +-- | Expect/resolve branch reference with the following rules: +-- +-- 1. If the project is missing, use the current project. +-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current +-- project, defaulting to 'main' if branch is unspecified. +resolveProjectBranch :: ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) +resolveProjectBranch pab = do + pp <- Cli.getCurrentProjectPath + resolveProjectBranchInProject (pp ^. #project) pab -- | Get the causal hash of a project branch. -getProjectBranchCausalHash :: ProjectAndBranch ProjectId ProjectBranchId -> Transaction CausalHash -getProjectBranchCausalHash branch = do - let path = projectBranchPath branch - causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path) - pure causal.causalHash +getProjectBranchCausalHash :: ProjectBranch -> Transaction CausalHash +getProjectBranchCausalHash ProjectBranch {projectId, branchId} = do + causalHashId <- Q.expectProjectBranchHead projectId branchId + Q.expectCausalHash causalHashId ------------------------------------------------------------------------------------------------------------------------ -- Remote project utils @@ -384,7 +309,7 @@ expectRemoteProjectBranchByTheseNames includeSquashed = \case let remoteBranchName = unsafeFrom @Text "main" expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) That branchName -> do - (ProjectAndBranch localProject localBranch, _restPath) <- expectCurrentProjectBranch + PP.ProjectPath localProject localBranch _restPath <- Cli.getCurrentProjectPath let localProjectId = localProject ^. #projectId let localBranchId = localBranch ^. #branchId Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case diff --git a/unison-cli/src/Unison/Cli/ServantClientUtils.hs b/unison-cli/src/Unison/Cli/ServantClientUtils.hs index af6723fec1..8b22b26f3d 100644 --- a/unison-cli/src/Unison/Cli/ServantClientUtils.hs +++ b/unison-cli/src/Unison/Cli/ServantClientUtils.hs @@ -25,11 +25,11 @@ classifyConnectionError exception0 = HttpClient.ConnectionFailure exception1 -> do ioException <- fromException @IOException exception1 if - | -- This may not be 100% accurate... but if the initial `getAddrInfo` request fails it will indeed throw - -- a "does not exist" error. It seems in order to *know* that `getAddrInfo` was the cause of this - -- exception, we'd have to parse the `show` output, which is preposterous. - isDoesNotExistError ioException -> - Just ConnectionError'Offline - | otherwise -> Nothing + | -- This may not be 100% accurate... but if the initial `getAddrInfo` request fails it will indeed throw + -- a "does not exist" error. It seems in order to *know* that `getAddrInfo` was the cause of this + -- exception, we'd have to parse the `show` output, which is preposterous. + isDoesNotExistError ioException -> + Just ConnectionError'Offline + | otherwise -> Nothing _ -> Nothing _ -> ConnectionError'SomethingEntirelyUnexpected exception0 diff --git a/unison-cli/src/Unison/Cli/Share/Projects.hs b/unison-cli/src/Unison/Cli/Share/Projects.hs index 961ed69858..52fbc56e8e 100644 --- a/unison-cli/src/Unison/Cli/Share/Projects.hs +++ b/unison-cli/src/Unison/Cli/Share/Projects.hs @@ -258,8 +258,10 @@ servantClientToCli action = do (mkClientEnv httpManager hardCodedBaseUrl) { Servant.makeClientRequest = \url request -> (Servant.defaultMakeClientRequest url request) - { Http.Client.responseTimeout = Http.Client.responseTimeoutMicro (60 * 1000 * 1000 {- 60s -}) - } + <&> \req -> + req + { Http.Client.responseTimeout = Http.Client.responseTimeoutMicro (60 * 1000 * 1000 {- 60s -}) + } } liftIO (runClientM action clientEnv) diff --git a/unison-cli/src/Unison/Cli/TypeCheck.hs b/unison-cli/src/Unison/Cli/TypeCheck.hs index e9a8caf547..b7e74a231f 100644 --- a/unison-cli/src/Unison/Cli/TypeCheck.hs +++ b/unison-cli/src/Unison/Cli/TypeCheck.hs @@ -49,7 +49,8 @@ typecheckTerm codebase tm = do Typechecker.Env { ambientAbilities = [], typeLookup, - termsByShortname = Map.empty + termsByShortname = Map.empty, + topLevelComponents = Map.empty } pure $ fmap extract $ FileParsers.synthesizeFile typecheckingEnv file where diff --git a/unison-cli/src/Unison/Cli/UniqueTypeGuidLookup.hs b/unison-cli/src/Unison/Cli/UniqueTypeGuidLookup.hs index 21aa566256..8ed07da067 100644 --- a/unison-cli/src/Unison/Cli/UniqueTypeGuidLookup.hs +++ b/unison-cli/src/Unison/Cli/UniqueTypeGuidLookup.hs @@ -5,37 +5,26 @@ module Unison.Cli.UniqueTypeGuidLookup ) where -import Control.Lens (unsnoc) -import Data.Foldable qualified as Foldable -import Data.Maybe (fromJust) import U.Codebase.Branch qualified as Codebase.Branch -import U.Codebase.Sqlite.Operations qualified as Operations +import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath) +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.UniqueTypeGuidLookup qualified as Codebase import Unison.Name (Name) -import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Sqlite qualified as Sqlite -loadUniqueTypeGuid :: Path.Absolute -> Name -> Sqlite.Transaction (Maybe Text) -loadUniqueTypeGuid currentPath name0 = do - -- First, resolve the current path and the (probably/hopefully relative) name of the unique type to the full path - -- to the unique type, plus its final distinguished name segment. - let (branchPath, name) = - name0 - & Path.fromName' - & Path.resolve currentPath - & Path.unabsolute - & Path.toSeq - & unsnoc - -- This is safe because we were handed a Name, which can't be empty - & fromJust +loadUniqueTypeGuid :: ProjectPath -> Name -> Sqlite.Transaction (Maybe Text) +loadUniqueTypeGuid pp name0 = do + let (namePath, finalSegment) = Path.splitFromName name0 + let fullPP = pp & over PP.path_ (<> namePath) -- Define an operation to load a branch by its full path from the root namespace. -- -- This ought to probably lean somewhat on a cache (so long as the caller is aware of the cache, and discrads it at -- an appropriate time, such as after the current unison file finishes parsing). - let loadBranchAtPath :: [NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction)) - loadBranchAtPath = Operations.loadBranchAtPath Nothing + let loadBranchAtPath :: ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction)) + loadBranchAtPath = Codebase.getMaybeShallowBranchAtProjectPath - Codebase.loadUniqueTypeGuid loadBranchAtPath (Foldable.toList @Seq branchPath) name + Codebase.loadUniqueTypeGuid loadBranchAtPath fullPP finalSegment diff --git a/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs b/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs deleted file mode 100644 index c062c7b476..0000000000 --- a/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs +++ /dev/null @@ -1,90 +0,0 @@ --- | @.unisonConfig@ file utilities -module Unison.Cli.UnisonConfigUtils - ( remoteMappingKey, - resolveConfiguredUrl, - ) -where - -import Control.Lens -import Data.Foldable.Extra qualified as Foldable -import Data.Sequence (Seq (..)) -import Data.Sequence qualified as Seq -import Data.Text qualified as Text -import Text.Megaparsec qualified as P -import Unison.Cli.Monad (Cli) -import Unison.Cli.Monad qualified as Cli -import Unison.Cli.MonadUtils qualified as Cli -import Unison.Codebase.Editor.Output -import Unison.Codebase.Editor.Output.PushPull (PushPull) -import Unison.Codebase.Editor.RemoteRepo (WriteRemoteNamespace (..)) -import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo -import Unison.Codebase.Editor.UriParser qualified as UriParser -import Unison.Codebase.Path (Path' (..)) -import Unison.Codebase.Path qualified as Path -import Unison.Prelude -import Unison.Syntax.NameSegment qualified as NameSegment - -configKey :: Text -> Path.Absolute -> Text -configKey k p = - Text.intercalate "." . toList $ - k - :<| fmap - NameSegment.toEscapedText - (Path.toSeq $ Path.unabsolute p) - -remoteMappingKey :: Path.Absolute -> Text -remoteMappingKey = configKey "RemoteMapping" - --- Takes a maybe (namespace address triple); returns it as-is if `Just`; --- otherwise, tries to load a value from .unisonConfig, and complains --- if needed. -resolveConfiguredUrl :: PushPull -> Path' -> Cli (WriteRemoteNamespace Void) -resolveConfiguredUrl pushPull destPath' = do - destPath <- Cli.resolvePath' destPath' - whenNothingM (remoteMappingForPath pushPull destPath) do - Cli.returnEarly (NoConfiguredRemoteMapping pushPull destPath) - --- | Tries to look up a remote mapping for a given path. --- Will also resolve paths relative to any mapping which is configured for a parent of that --- path. --- --- E.g. --- --- A config which maps: --- --- .myshare.foo -> .me.public.foo --- --- Will resolve the following local paths into share paths like so: --- --- .myshare.foo -> .me.public.foo --- .myshare.foo.bar -> .me.public.foo.bar --- .myshare.foo.bar.baz -> .me.public.foo.bar.baz --- .myshare -> -remoteMappingForPath :: PushPull -> Path.Absolute -> Cli (Maybe (WriteRemoteNamespace Void)) -remoteMappingForPath pushPull dest = do - pathPrefixes dest & Foldable.firstJustM \(prefix, suffix) -> do - let remoteMappingConfigKey = remoteMappingKey prefix - Cli.getConfig remoteMappingConfigKey >>= \case - Just url -> do - let parseResult = P.parse (UriParser.writeRemoteNamespaceWith empty) (Text.unpack remoteMappingConfigKey) url - in case parseResult of - Left err -> Cli.returnEarly (ConfiguredRemoteMappingParseError pushPull dest url (show err)) - Right wrp -> do - let remote = wrp & RemoteRepo.remotePath_ %~ \p -> Path.resolve p suffix - in pure $ Just remote - Nothing -> pure Nothing - where - -- Produces a list of path prefixes and suffixes, from longest prefix to shortest - -- - -- E.g. - -- - -- >>> pathPrefixes ("a" :< "b" :< Path.absoluteEmpty) - -- fromList [(.a.b,),(.a,b),(.,a.b)] - pathPrefixes :: Path.Absolute -> Seq (Path.Absolute, Path.Path) - pathPrefixes p = - Path.unabsolute p - & Path.toSeq - & \seq -> - Seq.zip (Seq.inits seq) (Seq.tails seq) - & Seq.reverse - <&> bimap (Path.Absolute . Path.Path) (Path.Path) diff --git a/unison-cli/src/Unison/Cli/UpdateUtils.hs b/unison-cli/src/Unison/Cli/UpdateUtils.hs new file mode 100644 index 0000000000..45a478d6eb --- /dev/null +++ b/unison-cli/src/Unison/Cli/UpdateUtils.hs @@ -0,0 +1,290 @@ +-- | This module contains functionality that is common to the general idea of "updating" a term in Unison, which is when +-- we reassign a name from one hash to another and then see if all dependents still typecheck. +-- +-- This occurs in the `pull`, `merge`, `update`, and `upgrade` commands. +module Unison.Cli.UpdateUtils + ( -- * Loading definitions + loadNamespaceDefinitions, + + -- * Getting dependents in a namespace + getNamespaceDependentsOf, + getNamespaceDependentsOf2, + getNamespaceDependentsOf3, + + -- * Narrowing definitions + narrowDefns, + + -- * Hydrating definitions + hydrateDefns, + + -- * Parsing and typechecking + parseAndTypecheck, + ) +where + +import Control.Monad.Reader (ask) +import Data.Bifoldable (bifold, bifoldMap) +import Data.Bitraversable (bitraverse) +import Data.Foldable qualified as Foldable +import Data.List qualified as List +import Data.List.NonEmpty qualified as List.NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Set.NonEmpty (NESet) +import Data.Set.NonEmpty qualified as Set.NonEmpty +import U.Codebase.Branch qualified as V2 +import U.Codebase.Causal qualified +import U.Codebase.Reference (TermReferenceId, TypeReferenceId) +import U.Codebase.Referent qualified as V2 +import U.Codebase.Sqlite.Operations qualified as Operations +import Unison.Cli.Monad (Cli, Env (..)) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.TypeCheck (computeTypecheckingEnvironment) +import Unison.Debug qualified as Debug +import Unison.FileParsers qualified as FileParsers +import Unison.Hash (Hash) +import Unison.Name (Name) +import Unison.Name qualified as Name +import Unison.NameSegment (NameSegment) +import Unison.NameSegment qualified as NameSegment +import Unison.Names (Names) +import Unison.Names qualified as Names +import Unison.Parser.Ann (Ann) +import Unison.Parsers qualified as Parsers +import Unison.Prelude +import Unison.Reference (Reference, TermReference, TypeReference) +import Unison.Reference qualified as Reference +import Unison.Referent (Referent) +import Unison.Referent qualified as Referent +import Unison.Result qualified as Result +import Unison.Sqlite (Transaction) +import Unison.Symbol (Symbol) +import Unison.Syntax.Parser qualified as Parser +import Unison.UnisonFile (TypecheckedUnisonFile) +import Unison.Util.BiMultimap (BiMultimap) +import Unison.Util.BiMultimap qualified as BiMultimap +import Unison.Util.Conflicted (Conflicted (..)) +import Unison.Util.Defn (Defn (..)) +import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2) +import Unison.Util.Nametree (Nametree (..), traverseNametreeWithName, unflattenNametrees) +import Unison.Util.Pretty (Pretty) +import Unison.Util.Pretty qualified as Pretty +import Unison.Util.Relation (Relation) +import Unison.Util.Relation qualified as Relation +import Unison.Util.Set qualified as Set +import Prelude hiding (unzip, zip, zipWith) + +------------------------------------------------------------------------------------------------------------------------ +-- Loading definitions + +-- Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined +-- in the "lib" namespace. +-- +-- Fails if there is a conflicted name. +loadNamespaceDefinitions :: + forall m. + (Monad m) => + (V2.Referent -> m Referent) -> + V2.Branch m -> + m + ( Either + (Defn (Conflicted Name Referent) (Conflicted Name TypeReference)) + (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) + ) +loadNamespaceDefinitions referent2to1 = + fmap assertNamespaceHasNoConflictedNames . go (Map.delete NameSegment.libSegment) + where + go :: + (forall x. Map NameSegment x -> Map NameSegment x) -> + V2.Branch m -> + m (Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference)) + go f branch = do + terms <- for branch.terms (fmap (Set.NonEmpty.fromList . List.NonEmpty.fromList) . traverse referent2to1 . Map.keys) + let types = Map.map (Set.NonEmpty.unsafeFromSet . Map.keysSet) branch.types + children <- + for (f branch.children) \childCausal -> do + child <- childCausal.value + go id child + pure Nametree {value = Defns {terms, types}, children} + +-- | Assert that there are no unconflicted names in a namespace. +assertNamespaceHasNoConflictedNames :: + Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference) -> + Either + (Defn (Conflicted Name Referent) (Conflicted Name TypeReference)) + (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) +assertNamespaceHasNoConflictedNames = + traverseNametreeWithName \segments defns -> do + let toName segment = + Name.fromReverseSegments (segment List.NonEmpty.:| segments) + terms <- + defns.terms & Map.traverseWithKey \segment -> + assertUnconflicted (TermDefn . Conflicted (toName segment)) + types <- + defns.types & Map.traverseWithKey \segment -> + assertUnconflicted (TypeDefn . Conflicted (toName segment)) + pure Defns {terms, types} + where + assertUnconflicted :: (NESet ref -> x) -> NESet ref -> Either x ref + assertUnconflicted conflicted refs + | Set.NonEmpty.size refs == 1 = Right (Set.NonEmpty.findMin refs) + | otherwise = Left (conflicted refs) + +------------------------------------------------------------------------------------------------------------------------ +-- Getting dependents in a namespace + +-- | Given a namespace and a set of dependencies, return the subset of the namespace that consists of only the +-- (transitive) dependents of the dependencies. +getNamespaceDependentsOf :: + Names -> + Set Reference -> + Transaction (DefnsF (Relation Name) TermReferenceId TypeReferenceId) +getNamespaceDependentsOf names dependencies = do + dependents <- Operations.transitiveDependentsWithinScope (Names.referenceIds names) dependencies + pure (bimap (foldMap nameTerm) (foldMap nameType) dependents) + where + nameTerm :: TermReferenceId -> Relation Name TermReferenceId + nameTerm ref = + Relation.fromManyDom (Relation.lookupRan (Referent.fromTermReferenceId ref) (Names.terms names)) ref + + nameType :: TypeReferenceId -> Relation Name TypeReferenceId + nameType ref = + Relation.fromManyDom (Relation.lookupRan (Reference.fromId ref) (Names.types names)) ref + +-- | Given a namespace and a set of dependencies, return the subset of the namespace that consists of only the +-- (transitive) dependents of the dependencies. +getNamespaceDependentsOf2 :: + Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> + Set Reference -> + Transaction (DefnsF (Map Name) TermReferenceId TypeReferenceId) +getNamespaceDependentsOf2 defns dependencies = do + let toTermScope = Set.mapMaybe Referent.toReferenceId . BiMultimap.dom + let toTypeScope = Set.mapMaybe Reference.toId . BiMultimap.dom + let scope = bifoldMap toTermScope toTypeScope defns + Operations.transitiveDependentsWithinScope scope dependencies + <&> bimap (Set.foldl' addTerms Map.empty) (Set.foldl' addTypes Map.empty) + where + addTerms :: Map Name TermReferenceId -> TermReferenceId -> Map Name TermReferenceId + addTerms acc0 ref = + let names = BiMultimap.lookupDom (Referent.fromTermReferenceId ref) defns.terms + in Set.foldl' (\acc name -> Map.insert name ref acc) acc0 names + + addTypes :: Map Name TypeReferenceId -> TypeReferenceId -> Map Name TypeReferenceId + addTypes acc0 ref = + let names = BiMultimap.lookupDom (Reference.fromId ref) defns.types + in Set.foldl' (\acc name -> Map.insert name ref acc) acc0 names + +-- | Given a namespace and a set of dependencies, return the subset of the namespace that consists of only the +-- (transitive) dependents of the dependencies. +getNamespaceDependentsOf3 :: + Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> + DefnsF Set TermReference TypeReference -> + Transaction (DefnsF Set TermReferenceId TypeReferenceId) +getNamespaceDependentsOf3 defns dependencies = do + let toTermScope = Set.mapMaybe Referent.toReferenceId . BiMultimap.dom + let toTypeScope = Set.mapMaybe Reference.toId . BiMultimap.dom + let scope = bifoldMap toTermScope toTypeScope defns + Operations.transitiveDependentsWithinScope scope (bifold dependencies) + +------------------------------------------------------------------------------------------------------------------------ +-- Narrowing definitions + +-- | "Narrow" a namespace that may contain conflicted names, resulting in either a failure (if we find a conflicted +-- name), or the narrowed nametree without conflicted names. +narrowDefns :: + forall term typ. + (Ord term, Ord typ) => + DefnsF (Relation Name) term typ -> + Either + ( Defn + (Conflicted Name term) + (Conflicted Name typ) + ) + (Nametree (DefnsF (Map NameSegment) term typ)) +narrowDefns = + fmap unflattenNametrees + . bitraverse + (go (\name -> TermDefn . Conflicted name)) + (go (\name -> TypeDefn . Conflicted name)) + where + go :: forall ref x. (Ord ref) => (Name -> NESet ref -> x) -> Relation Name ref -> Either x (Map Name ref) + go conflicted = + Map.traverseWithKey unconflicted . Relation.domain + where + unconflicted :: Name -> Set ref -> Either x ref + unconflicted name refs0 + | Set.NonEmpty.size refs == 1 = Right (Set.NonEmpty.findMin refs) + | otherwise = Left (conflicted name refs) + where + refs = Set.NonEmpty.unsafeFromSet refs0 + +------------------------------------------------------------------------------------------------------------------------ +-- Hydrating definitions + +-- | Hydrate term/type references to actual terms/types. +hydrateDefns :: + forall m name term typ. + (Monad m, Ord name) => + (Hash -> m [term]) -> + (Hash -> m [typ]) -> + DefnsF (Map name) TermReferenceId TypeReferenceId -> + m (DefnsF (Map name) (TermReferenceId, term) (TypeReferenceId, typ)) +hydrateDefns getTermComponent getTypeComponent = do + bitraverse hydrateTerms hydrateTypes + where + hydrateTerms :: Map name TermReferenceId -> m (Map name (TermReferenceId, term)) + hydrateTerms terms = + hydrateDefns_ getTermComponent terms \_ -> (,) + + hydrateTypes :: Map name TypeReferenceId -> m (Map name (TypeReferenceId, typ)) + hydrateTypes types = + hydrateDefns_ getTypeComponent types \_ -> (,) + +hydrateDefns_ :: + forall a b name m. + (Monad m, Ord name) => + (Hash -> m [a]) -> + Map name Reference.Id -> + (name -> Reference.Id -> a -> b) -> + m (Map name b) +hydrateDefns_ getComponent defns modify = + Foldable.foldlM f Map.empty (foldMap (Set.singleton . Reference.idToHash) defns) + where + f :: Map name b -> Hash -> m (Map name b) + f acc hash = + List.foldl' g acc . Reference.componentFor hash <$> getComponent hash + + g :: Map name b -> (Reference.Id, a) -> Map name b + g acc (ref, thing) = + Set.foldl' (h ref thing) acc (BiMultimap.lookupDom ref defns2) + + h :: Reference.Id -> a -> Map name b -> name -> Map name b + h ref thing acc name = + Map.insert name (modify name ref thing) acc + + defns2 :: BiMultimap Reference.Id name + defns2 = + BiMultimap.fromRange defns + +------------------------------------------------------------------------------------------------------------------------ +-- Parsing and typechecking + +-- TODO: find a better module for this function, as it's used in a couple places +parseAndTypecheck :: + Pretty Pretty.ColorText -> + Parser.ParsingEnv Transaction -> + Cli (Maybe (TypecheckedUnisonFile Symbol Ann)) +parseAndTypecheck prettyUf parsingEnv = do + env <- ask + let stringUf = Pretty.toPlain 80 prettyUf + Debug.whenDebug Debug.Update do + liftIO do + putStrLn "--- Scratch ---" + putStrLn stringUf + Cli.runTransaction do + Parsers.parseFile "" stringUf parsingEnv >>= \case + Left _ -> pure Nothing + Right uf -> do + typecheckingEnv <- + computeTypecheckingEnvironment (FileParsers.ShouldUseTndr'Yes parsingEnv) env.codebase [] uf + pure (Result.result (FileParsers.synthesizeFile typecheckingEnv uf)) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 491cdccea5..4967878424 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -14,14 +14,11 @@ import Control.Monad.State qualified as State import Data.Foldable qualified as Foldable import Data.List qualified as List import Data.List.Extra (nubOrd) -import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as Nel import Data.Map qualified as Map import Data.Set qualified as Set -import Data.Set.NonEmpty (NESet) import Data.Set.NonEmpty qualified as NESet import Data.Text qualified as Text -import Data.These (These (..)) import Data.Time (UTCTime) import Data.Tuple.Extra (uncurry3) import Text.Megaparsec qualified as Megaparsec @@ -29,19 +26,16 @@ import U.Codebase.Branch.Diff qualified as V2Branch.Diff import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Reflog qualified as Reflog -import U.Codebase.Sqlite.Project qualified as Sqlite -import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite -import U.Codebase.Sqlite.Queries qualified as Queries import Unison.ABT qualified as ABT import Unison.Builtin qualified as Builtin import Unison.Builtin.Terms qualified as Builtin import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils (getCurrentProjectBranch) import Unison.Cli.MonadUtils qualified as Cli +import Unison.Cli.NameResolutionUtils (resolveHQToLabeledDependencies) import Unison.Cli.NamesUtils qualified as Cli -import Unison.Cli.PrettyPrintUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils -import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch (..), Branch0) import Unison.Codebase.Branch qualified as Branch @@ -51,7 +45,6 @@ import Unison.Codebase.BranchUtil qualified as BranchUtil import Unison.Codebase.Causal qualified as Causal import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..)) import Unison.Codebase.Editor.AuthorInfo qualified as AuthorInfo -import Unison.Codebase.Editor.DisplayObject import Unison.Codebase.Editor.HandleInput.AddRun (handleAddRun) import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin) import Unison.Codebase.Editor.HandleInput.Branch (handleBranch) @@ -61,13 +54,20 @@ import Unison.Codebase.Editor.HandleInput.CommitMerge (handleCommitMerge) import Unison.Codebase.Editor.HandleInput.CommitUpgrade (handleCommitUpgrade) import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition import Unison.Codebase.Editor.HandleInput.DebugFoldRanges qualified as DebugFoldRanges +import Unison.Codebase.Editor.HandleInput.DebugSynhashTerm (handleDebugSynhashTerm) import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch) +import Unison.Codebase.Editor.HandleInput.DeleteNamespace (getEndangeredDependents, handleDeleteNamespace) import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject) +import Unison.Codebase.Editor.HandleInput.Dependents (handleDependents) import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace) -import Unison.Codebase.Editor.HandleInput.FindAndReplace (handleStructuredFindI, handleStructuredFindReplaceI) +import Unison.Codebase.Editor.HandleInput.EditDependents (handleEditDependents) +import Unison.Codebase.Editor.HandleInput.FindAndReplace (handleStructuredFindI, handleStructuredFindReplaceI, handleTextFindI) import Unison.Codebase.Editor.HandleInput.FormatFile qualified as Format +import Unison.Codebase.Editor.HandleInput.Global qualified as Global import Unison.Codebase.Editor.HandleInput.InstallLib (handleInstallLib) +import Unison.Codebase.Editor.HandleInput.LSPDebug qualified as LSPDebug import Unison.Codebase.Editor.HandleInput.Load (EvalMode (Sandboxed), evalUnisonFile, handleLoad, loadUnisonFile) +import Unison.Codebase.Editor.HandleInput.Ls (handleLs) import Unison.Codebase.Editor.HandleInput.Merge2 (handleMerge) import Unison.Codebase.Editor.HandleInput.MoveAll (handleMoveAll) import Unison.Codebase.Editor.HandleInput.MoveBranch (doMoveBranch) @@ -82,18 +82,19 @@ import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch) import Unison.Codebase.Editor.HandleInput.Projects (handleProjects) import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch) import Unison.Codebase.Editor.HandleInput.Push (handlePushRemoteBranch) +import Unison.Codebase.Editor.HandleInput.Reflogs qualified as Reflogs import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft) import Unison.Codebase.Editor.HandleInput.Run (handleRun) import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils -import Unison.Codebase.Editor.HandleInput.ShowDefinition (showDefinitions) +import Unison.Codebase.Editor.HandleInput.ShowDefinition (handleShowDefinition) import Unison.Codebase.Editor.HandleInput.TermResolution (resolveMainRef) import Unison.Codebase.Editor.HandleInput.Tests qualified as Tests +import Unison.Codebase.Editor.HandleInput.Todo (handleTodo) import Unison.Codebase.Editor.HandleInput.UI (openUI) import Unison.Codebase.Editor.HandleInput.Update (doSlurpAdds, handleUpdate) import Unison.Codebase.Editor.HandleInput.Update2 (handleUpdate2) import Unison.Codebase.Editor.HandleInput.Upgrade (handleUpgrade) import Unison.Codebase.Editor.Input -import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.Output.DumpNamespace qualified as Output.DN @@ -101,17 +102,15 @@ import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.Slurp qualified as Slurp import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult import Unison.Codebase.Editor.StructuredArgument qualified as SA -import Unison.Codebase.Editor.TodoOutput qualified as TO +import Unison.Codebase.Execute qualified as Codebase import Unison.Codebase.IntegrityCheck qualified as IntegrityCheck (integrityCheckFullCodebase) import Unison.Codebase.Metadata qualified as Metadata -import Unison.Codebase.Patch (Patch (..)) -import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path (Path, Path' (..)) -import Unison.Codebase.Path qualified as HQSplit' import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash qualified as SCH -import Unison.CommandLine.BranchRelativePath (BranchRelativePath) +import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..)) import Unison.CommandLine.Completion qualified as Completion import Unison.CommandLine.DisplayValues qualified as DisplayValues import Unison.CommandLine.InputPattern qualified as IP @@ -119,10 +118,8 @@ import Unison.CommandLine.InputPatterns qualified as IP import Unison.CommandLine.InputPatterns qualified as InputPatterns import Unison.ConstructorReference (GConstructorReference (..)) import Unison.DataDeclaration qualified as DD -import Unison.Hash qualified as Hash import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' -import Unison.HashQualified' qualified as HashQualified +import Unison.HashQualifiedPrime qualified as HQ' import Unison.LabeledDependency (LabeledDependency) import Unison.LabeledDependency qualified as LD import Unison.LabeledDependency qualified as LabeledDependency @@ -141,8 +138,6 @@ import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo, empty) import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED -import Unison.Project (ProjectAndBranch (..)) -import Unison.Project.Util (projectContextFromPath) import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) @@ -157,11 +152,9 @@ import Unison.Server.SearchResult (SearchResult) import Unison.Server.SearchResult qualified as SR import Unison.Share.Codeserver qualified as Codeserver import Unison.ShortHash qualified as SH -import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Syntax.HashQualified qualified as HQ (parseTextWith, toText) -import Unison.Syntax.Lexer qualified as L -import Unison.Syntax.Lexer qualified as Lexer +import Unison.Syntax.Lexer.Unison qualified as L import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar) import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Syntax.Parser qualified as Parser @@ -182,7 +175,6 @@ import Unison.Util.Relation qualified as R import Unison.Util.Relation qualified as Relation import Unison.Util.Set qualified as Set import Unison.Util.Star2 qualified as Star2 -import Unison.Util.TransitiveClosure (transitiveClosure) import Unison.Var (Var) import Unison.Var qualified as Var import Unison.WatchKind qualified as WK @@ -203,11 +195,12 @@ loop e = do let previewResponse sourceName sr uf = do names <- Cli.currentNames let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile uf names - filePPED <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile + let filePPED = PPED.makePPED (PPE.hqNamer 10 namesWithDefinitionsFromFile) (PPE.suffixifyByHash namesWithDefinitionsFromFile) let suffixifiedPPE = PPE.suffixifiedPPE filePPED Cli.respond $ Typechecked (Text.pack sourceName) suffixifiedPPE sr uf in Cli.time "InputPattern" case input of ApiI -> do + pp <- Cli.getCurrentProjectPath Cli.Env {serverBaseUrl} <- ask whenJust serverBaseUrl \baseUrl -> Cli.respond $ @@ -215,17 +208,17 @@ loop e = do P.lines [ "The API information is as follows:", P.newline, - P.indentN 2 (P.hiBlue ("UI: " <> Pretty.text (Server.urlFor (Server.LooseCodeUI Path.absoluteEmpty Nothing) baseUrl))), + P.indentN 2 (P.hiBlue ("UI: " <> Pretty.text (Server.urlFor (Server.ProjectBranchUI (PP.toProjectAndBranch . PP.toNames $ pp) Path.absoluteEmpty Nothing) baseUrl))), P.newline, P.indentN 2 (P.hiBlue ("API: " <> Pretty.text (Server.urlFor Server.Api baseUrl))) ] CreateMessage pretty -> Cli.respond $ PrintMessage pretty - ShowReflogI -> do + ShowRootReflogI -> do let numEntriesToShow = 500 (schLength, entries) <- Cli.runTransaction $ - (,) <$> Codebase.branchHashLength <*> Codebase.getReflog numEntriesToShow + (,) <$> Codebase.branchHashLength <*> Codebase.getDeprecatedRootReflog numEntriesToShow let moreEntriesToLoad = length entries == numEntriesToShow let expandedEntries = List.unfoldr expandEntries (entries, Nothing, moreEntriesToLoad) let (shortEntries, numberedEntries) = @@ -254,109 +247,33 @@ loop e = do -- No expectation, either because this is the most recent entry or -- because we're recovering from a discontinuity Nothing -> ((Just time, toRootCausalHash, reason), (rest, Just fromRootCausalHash, moreEntriesToLoad)) + ShowProjectBranchReflogI mayProjBranch -> do + Reflogs.showProjectBranchReflog mayProjBranch + ShowGlobalReflogI -> do + Reflogs.showGlobalReflog + ShowProjectReflogI mayProj -> do + Reflogs.showProjectReflog mayProj ResetI newRoot mtarget -> do - newRoot <- - case newRoot of - This newRoot -> case newRoot of - Left hash -> Cli.resolveShortCausalHash hash - Right path' -> Cli.expectBranchAtPath' path' - That (ProjectAndBranch mProjectName branchName) -> do - let arg = case mProjectName of - Nothing -> That branchName - Just projectName -> These projectName branchName - ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames arg - Cli.expectBranchAtPath' - ( Path.absoluteToPath' - ( ProjectUtils.projectBranchPath - (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)) - ) - ) - These branchId (ProjectAndBranch mProjectName branchName) -> Cli.label \jump -> do - absPath <- case branchId of - Left hash -> jump =<< Cli.resolveShortCausalHash hash - Right path' -> Cli.resolvePath' path' - mrelativePath <- - Cli.getMaybeBranchAt absPath <&> \case - Nothing -> Nothing - Just _ -> preview ProjectUtils.projectBranchPathPrism absPath - projectAndBranch <- do - let arg = case mProjectName of - Nothing -> That branchName - Just projectName -> These projectName branchName - ProjectUtils.getProjectAndBranchByTheseNames arg - thePath <- case (mrelativePath, projectAndBranch) of - (Nothing, Nothing) -> - ProjectUtils.getCurrentProject >>= \case - Nothing -> pure absPath - Just project -> - Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName)) - (Just (projectAndBranch0, relPath), Just (ProjectAndBranch project branch)) -> do - projectAndBranch0 <- Cli.runTransaction (ProjectUtils.expectProjectAndBranchByIds projectAndBranch0) - Cli.respondNumbered (AmbiguousReset AmbiguousReset'Hash (projectAndBranch0, relPath) (ProjectAndBranch (project ^. #name) (branch ^. #name))) - Cli.returnEarlyWithoutOutput - (Just _relativePath, Nothing) -> pure absPath - (Nothing, Just (ProjectAndBranch project branch)) -> - pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))) - Cli.expectBranchAtPath' (Path.absoluteToPath' thePath) - + newRoot <- resolveBranchId2 newRoot target <- case mtarget of - Nothing -> Cli.getCurrentPath - Just looseCodeOrProject -> case looseCodeOrProject of - This path' -> Cli.resolvePath' path' - That (ProjectAndBranch mProjectName branchName) -> do - let arg = case mProjectName of - Nothing -> That branchName - Just projectName -> These projectName branchName - ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames arg - pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))) - These path' (ProjectAndBranch mProjectName branchName) -> do - absPath <- Cli.resolvePath' path' - mrelativePath <- - Cli.getMaybeBranchAt absPath <&> \case - Nothing -> Nothing - Just _ -> preview ProjectUtils.projectBranchPathPrism absPath - projectAndBranch <- do - let arg = case mProjectName of - Nothing -> That branchName - Just projectName -> These projectName branchName - ProjectUtils.getProjectAndBranchByTheseNames arg - case (mrelativePath, projectAndBranch) of - (Nothing, Nothing) -> - ProjectUtils.getCurrentProject >>= \case - Nothing -> pure absPath - Just project -> - Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName)) - (Just (projectAndBranch0, relPath), Just (ProjectAndBranch project branch)) -> do - projectAndBranch0 <- Cli.runTransaction (ProjectUtils.expectProjectAndBranchByIds projectAndBranch0) - Cli.respondNumbered (AmbiguousReset AmbiguousReset'Target (projectAndBranch0, relPath) (ProjectAndBranch (project ^. #name) (branch ^. #name))) - Cli.returnEarlyWithoutOutput - (Just _relativePath, Nothing) -> pure absPath - (Nothing, Just (ProjectAndBranch project branch)) -> - pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))) + Nothing -> Cli.getCurrentProjectPath + Just unresolvedProjectAndBranch -> do + targetProjectAndBranch <- ProjectUtils.resolveProjectBranch (second Just unresolvedProjectAndBranch) + pure $ PP.projectBranchRoot targetProjectAndBranch description <- inputDescription input _ <- Cli.updateAt description target (const newRoot) Cli.respond Success - ResetRootI src0 -> - Cli.time "reset-root" do - newRoot <- - case src0 of - Left hash -> Cli.resolveShortCausalHash hash - Right path' -> Cli.expectBranchAtPath' path' - description <- inputDescription input - Cli.updateRoot newRoot description - Cli.respond Success ForkLocalBranchI src0 dest0 -> do (srcb, branchEmpty) <- case src0 of Left hash -> (,WhichBranchEmptyHash hash) <$> Cli.resolveShortCausalHash hash Right path' -> do - absPath <- ProjectUtils.branchRelativePathToAbsolute path' - let srcp = Path.convert absPath - srcb <- Cli.expectBranchAtPath' srcp - pure (srcb, WhichBranchEmptyPath srcp) + srcPP <- ProjectUtils.resolveBranchRelativePath path' + srcb <- Cli.getBranchFromProjectPath srcPP + pure (srcb, WhichBranchEmptyPath srcPP) description <- inputDescription input - dest <- ProjectUtils.branchRelativePathToAbsolute dest0 + dest <- ProjectUtils.resolveBranchRelativePath dest0 ok <- Cli.updateAtM description dest (const $ pure srcb) Cli.respond if ok @@ -364,45 +281,43 @@ loop e = do else BranchEmpty branchEmpty MergeI branch -> handleMerge branch MergeCommitI -> handleCommitMerge - MergeLocalBranchI src0 dest0 mergeMode -> do + MergeLocalBranchI unresolvedSrc mayUnresolvedDest mergeMode -> do description <- inputDescription input - src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0 - dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0 - let srcp = looseCodeOrProjectToPath src0 - let destp = looseCodeOrProjectToPath dest0 - srcb <- Cli.expectBranchAtPath' srcp - dest <- Cli.resolvePath' destp - let err = - Just $ - MergeAlreadyUpToDate - ((\x -> ProjectAndBranch x.project.name x.branch.name) <$> src0) - ((\x -> ProjectAndBranch x.project.name x.branch.name) <$> dest0) - mergeBranchAndPropagateDefaultPatch mergeMode description err srcb (Just dest0) dest - PreviewMergeLocalBranchI src0 dest0 -> do + srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc + (destPP, destBRP) <- case mayUnresolvedDest of + Nothing -> Cli.getCurrentProjectPath <&> \pp -> (pp, QualifiedBranchPath (pp ^. #project . #name) (pp ^. #branch . #name) (pp ^. PP.absPath_)) + Just unresolvedDest -> do + ProjectUtils.resolveBranchRelativePath unresolvedDest <&> \pp -> (pp, unresolvedDest) + srcBranch <- Cli.getProjectBranchRoot srcPP.branch + let err = Just $ MergeAlreadyUpToDate unresolvedSrc destBRP + mergeBranchAndPropagateDefaultPatch mergeMode description err srcBranch (Just $ Left destPP) destPP + PreviewMergeLocalBranchI unresolvedSrc mayUnresolvedDest -> do Cli.Env {codebase} <- ask - src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0 - dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0 - srcb <- Cli.expectBranchAtPath' $ looseCodeOrProjectToPath src0 - dest <- Cli.resolvePath' $ looseCodeOrProjectToPath dest0 - destb <- Cli.getBranchAt dest - merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) - if merged == destb - then Cli.respond (PreviewMergeAlreadyUpToDate src0 dest0) + srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc + destPP <- case mayUnresolvedDest of + Nothing -> Cli.getCurrentProjectPath + Just unresolvedDest -> do + ProjectUtils.resolveBranchRelativePath unresolvedDest + srcBranch <- Cli.getProjectBranchRoot srcPP.branch + destBranch <- Cli.getProjectBranchRoot destPP.branch + merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcBranch destBranch) + if merged == destBranch + then Cli.respond (PreviewMergeAlreadyUpToDate srcPP destPP) else do - (ppe, diff) <- diffHelper (Branch.head destb) (Branch.head merged) - Cli.respondNumbered (ShowDiffAfterMergePreview dest0 dest ppe diff) + (ppe, diff) <- diffHelper (Branch.head destBranch) (Branch.head merged) + Cli.respondNumbered (ShowDiffAfterMergePreview (Left destPP) destPP ppe diff) DiffNamespaceI before after -> do - absBefore <- traverseOf _Right Cli.resolvePath' before - absAfter <- traverseOf _Right Cli.resolvePath' after - beforeBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absBefore - afterBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absAfter + beforeLoc <- traverse ProjectUtils.resolveBranchRelativePath before + beforeBranch0 <- Branch.head <$> resolveBranchId2 before + afterLoc <- traverse ProjectUtils.resolveBranchRelativePath after + afterBranch0 <- Branch.head <$> resolveBranchId2 after case (Branch.isEmpty0 beforeBranch0, Branch.isEmpty0 afterBranch0) of - (True, True) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| [absAfter]) - (True, False) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| []) - (False, True) -> Cli.returnEarly . NamespaceEmpty $ (absAfter Nel.:| []) + (True, True) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| [afterLoc]) + (True, False) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| []) + (False, True) -> Cli.returnEarly . NamespaceEmpty $ (afterLoc Nel.:| []) (False, False) -> pure () (ppe, diff) <- diffHelper beforeBranch0 afterBranch0 - Cli.respondNumbered (ShowDiffNamespace absBefore absAfter ppe diff) + Cli.respondNumbered (ShowDiffNamespace beforeLoc afterLoc ppe diff) MoveBranchI src' dest' -> do hasConfirmed <- confirmedCommand input description <- inputDescription input @@ -410,8 +325,8 @@ loop e = do SwitchBranchI path' -> do path <- Cli.resolvePath' path' branchExists <- Cli.branchExistsAtPath' path' - when (not branchExists) (Cli.respond $ CreatedNewBranch path) - Cli.cd path + when (not branchExists) (Cli.respond $ CreatedNewBranch (path ^. PP.absPath_)) + Cli.cd (path ^. PP.absPath_) UpI -> do path0 <- Cli.getCurrentPath whenJust (unsnoc path0) \(path, _) -> @@ -422,10 +337,11 @@ loop e = do HistoryI resultsCap diffCap from -> do branch <- case from of - Left hash -> Cli.resolveShortCausalHash hash - Right path' -> do - path <- Cli.resolvePath' path' - Cli.getMaybeBranchAt path & onNothingM (Cli.returnEarly (CreatedNewBranch path)) + BranchAtSCH hash -> Cli.resolveShortCausalHash hash + BranchAtPath path' -> do + pp <- Cli.resolvePath' path' + Cli.getBranchFromProjectPath pp + BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp schLength <- Cli.runTransaction Codebase.branchHashLength history <- liftIO (doHistory schLength 0 branch []) Cli.respondNumbered history @@ -443,7 +359,7 @@ loop e = do let elem = (Branch.headHash b, Branch.namesDiff b' b) doHistory schLength (n + 1) b' (elem : acc) UndoI -> do - rootBranch <- Cli.getRootBranch + rootBranch <- Cli.getCurrentProjectRoot (_, prev) <- liftIO (Branch.uncons rootBranch) & onNothingM do Cli.returnEarly . CantUndo $ @@ -451,13 +367,14 @@ loop e = do then CantUndoPastStart else CantUndoPastMerge description <- inputDescription input - Cli.updateRoot prev description + pb <- getCurrentProjectBranch + Cli.updateProjectBranchRoot_ pb description (const prev) (ppe, diff) <- diffHelper (Branch.head prev) (Branch.head rootBranch) Cli.respondNumbered (Output.ShowDiffAfterUndo ppe diff) UiI path' -> openUI path' DocToMarkdownI docName -> do names <- Cli.currentNames - pped <- Cli.prettyPrintEnvDeclFromNames names + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) Cli.Env {codebase, runtime} <- ask docRefs <- Cli.runTransaction do hqLength <- Codebase.hashLength @@ -470,11 +387,11 @@ loop e = do Cli.respond $ Output.MarkdownOut (Text.intercalate "\n---\n" mdText) DocsToHtmlI namespacePath' sourceDirectory -> do Cli.Env {codebase, sandboxedRuntime} <- ask - absPath <- Cli.resolvePath' namespacePath' - branch <- liftIO $ Codebase.getBranchAtPath codebase absPath + projPath <- ProjectUtils.resolveBranchRelativePath namespacePath' + branch <- Cli.getBranchFromProjectPath projPath _evalErrs <- liftIO $ (Backend.docsInBranchToHtmlFiles sandboxedRuntime codebase branch sourceDirectory) pure () - AliasTermI src' dest' -> do + AliasTermI force src' dest' -> do Cli.Env {codebase} <- ask src <- traverseOf _Right Cli.resolveSplit' src' srcTerms <- @@ -492,13 +409,13 @@ loop e = do hqLength <- Cli.runTransaction Codebase.hashLength pure (DeleteNameAmbiguous hqLength name srcTerms Set.empty) dest <- Cli.resolveSplit' dest' - destTerms <- Cli.getTermsAt (Path.convert dest) - when (not (Set.null destTerms)) do + destTerms <- Cli.getTermsAt (HQ'.NameOnly <$> dest) + when (not force && not (Set.null destTerms)) do Cli.returnEarly (TermAlreadyExists dest' destTerms) description <- inputDescription input - Cli.stepAt description (BranchUtil.makeAddTermName (Path.convert dest) srcTerm) + Cli.stepAt description (BranchUtil.makeAddTermName dest srcTerm) Cli.respond Success - AliasTypeI src' dest' -> do + AliasTypeI force src' dest' -> do src <- traverseOf _Right Cli.resolveSplit' src' srcTypes <- either @@ -515,26 +432,26 @@ loop e = do hqLength <- Cli.runTransaction Codebase.hashLength pure (DeleteNameAmbiguous hqLength name Set.empty srcTypes) dest <- Cli.resolveSplit' dest' - destTypes <- Cli.getTypesAt (Path.convert dest) - when (not (Set.null destTypes)) do + destTypes <- Cli.getTypesAt (HQ'.NameOnly <$> dest) + when (not force && not (Set.null destTypes)) do Cli.returnEarly (TypeAlreadyExists dest' destTypes) description <- inputDescription input - Cli.stepAt description (BranchUtil.makeAddTypeName (Path.convert dest) srcType) + Cli.stepAt description (BranchUtil.makeAddTypeName dest srcType) Cli.respond Success -- this implementation will happily produce name conflicts, -- but will surface them in a normal diff at the end of the operation. AliasManyI srcs dest' -> do - root0 <- Cli.getRootBranch0 + root0 <- Cli.getCurrentProjectRoot0 currentBranch0 <- Cli.getCurrentBranch0 - destAbs <- Cli.resolvePath' dest' - old <- Cli.getBranch0At destAbs + destPP <- Cli.resolvePath' dest' + old <- Cli.getBranch0FromProjectPath destPP description <- inputDescription input - let (unknown, actions) = foldl' (go root0 currentBranch0 destAbs) mempty srcs - Cli.stepManyAt description actions - new <- Cli.getBranch0At destAbs + let (unknown, actions) = foldl' (go root0 currentBranch0 (PP.absPath destPP)) mempty srcs + Cli.stepManyAt destPP.branch description actions + new <- Cli.getBranch0FromProjectPath destPP (ppe, diff) <- diffHelper old new - Cli.respondNumbered (ShowDiffAfterModifyBranch dest' destAbs ppe diff) + Cli.respondNumbered (ShowDiffAfterModifyBranch dest' (destPP.absPath) ppe diff) when (not (null unknown)) do Cli.respond . SearchTermsNotFound . fmap fixupOutput $ unknown where @@ -543,28 +460,29 @@ loop e = do Branch0 IO -> Branch0 IO -> Path.Absolute -> - ([Path.HQSplit], [(Path, Branch0 m -> Branch0 m)]) -> + ([Path.HQSplit], [(Path.Absolute, Branch0 m -> Branch0 m)]) -> Path.HQSplit -> - ([Path.HQSplit], [(Path, Branch0 m -> Branch0 m)]) + ([Path.HQSplit], [(Path.Absolute, Branch0 m -> Branch0 m)]) go root0 currentBranch0 dest (missingSrcs, actions) hqsrc = - let proposedDest :: Path.Split + let proposedDest :: Path.AbsSplit proposedDest = second HQ'.toName hqProposedDest - hqProposedDest :: Path.HQSplit - hqProposedDest = first Path.unabsolute $ Path.resolve dest hqsrc + hqProposedDest :: Path.HQSplitAbsolute + hqProposedDest = Path.resolve dest hqsrc -- `Nothing` if src doesn't exist - doType :: Maybe [(Path, Branch0 m -> Branch0 m)] + doType :: Maybe [(Path.Absolute, Branch0 m -> Branch0 m)] doType = case ( BranchUtil.getType hqsrc currentBranch0, - BranchUtil.getType hqProposedDest root0 + BranchUtil.getType (first Path.unabsolute hqProposedDest) root0 ) of (null -> True, _) -> Nothing -- missing src (rsrcs, existing) -> -- happy path Just . map addAlias . toList $ Set.difference rsrcs existing where + addAlias :: Reference -> (Path.Absolute, Branch0 m -> Branch0 m) addAlias r = BranchUtil.makeAddTypeName proposedDest r - doTerm :: Maybe [(Path, Branch0 m -> Branch0 m)] + doTerm :: Maybe [(Path.Absolute, Branch0 m -> Branch0 m)] doTerm = case ( BranchUtil.getTerm hqsrc currentBranch0, - BranchUtil.getTerm hqProposedDest root0 + BranchUtil.getTerm (first Path.unabsolute hqProposedDest) root0 ) of (null -> True, _) -> Nothing -- missing src (rsrcs, existing) -> @@ -578,31 +496,30 @@ loop e = do (Just as1, Just as2) -> (missingSrcs, actions ++ as1 ++ as2) fixupOutput :: Path.HQSplit -> HQ.HashQualified Name - fixupOutput = fmap Path.unsafeToName . HQ'.toHQ . Path.unsplitHQ + fixupOutput = HQ'.toHQ . Path.nameFromHQSplit NamesI global query -> do hqLength <- Cli.runTransaction Codebase.hashLength - root <- Cli.getRootBranch - (names, pped) <- - if global || any Name.isAbsolute query - then do - let root0 = Branch.head root - -- Use an absolutely qualified ppe for view.global - let names = Names.makeAbsolute $ Branch.toNames root0 - let pped = PPED.makePPED (PPE.hqNamer hqLength names) (PPE.suffixifyByHash names) - pure (names, pped) - else do - names <- Cli.currentNames - pped <- Cli.prettyPrintEnvDeclFromNames names - pure (names, pped) - - let unsuffixifiedPPE = PPED.unsuffixifiedPPE pped - terms = Names.lookupHQTerm Names.IncludeSuffixes query names - types = Names.lookupHQType Names.IncludeSuffixes query names - terms' :: [(Referent, [HQ'.HashQualified Name])] - terms' = map (\r -> (r, PPE.allTermNames unsuffixifiedPPE r)) (Set.toList terms) - types' :: [(Reference, [HQ'.HashQualified Name])] - types' = map (\r -> (r, PPE.allTypeNames unsuffixifiedPPE r)) (Set.toList types) - Cli.respond $ ListNames global hqLength types' terms' + let searchNames names = do + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) + unsuffixifiedPPE = PPED.unsuffixifiedPPE pped + terms = Names.lookupHQTerm Names.IncludeSuffixes query names + types = Names.lookupHQType Names.IncludeSuffixes query names + terms' :: [(Referent, [HQ'.HashQualified Name])] + terms' = map (\r -> (r, PPE.allTermNames unsuffixifiedPPE r)) (Set.toList terms) + types' :: [(Reference, [HQ'.HashQualified Name])] + types' = map (\r -> (r, PPE.allTypeNames unsuffixifiedPPE r)) (Set.toList types) + pure (terms', types') + if global + then do + Global.forAllProjectBranches \(projBranchNames, _ids) branch -> do + let names = Branch.toNames . Branch.head $ branch + (terms, types) <- searchNames names + when (not (null terms) || not (null types)) do + Cli.respond $ GlobalListNames projBranchNames hqLength types terms + else do + names <- Cli.currentNames + (terms, types) <- searchNames names + Cli.respond $ ListNames hqLength types terms DocsI srcs -> do for_ srcs docsI CreateAuthorI authorNameSegment authorFullName -> do @@ -619,11 +536,13 @@ loop e = do authorPath <- Cli.resolveSplit' authorPath' copyrightHolderPath <- Cli.resolveSplit' (base |> NameSegment.copyrightHoldersSegment |> authorNameSegment) guidPath <- Cli.resolveSplit' (authorPath' |> NameSegment.guidSegment) + pb <- Cli.getCurrentProjectBranch Cli.stepManyAt + pb description - [ BranchUtil.makeAddTermName (Path.convert authorPath) (d authorRef), - BranchUtil.makeAddTermName (Path.convert copyrightHolderPath) (d copyrightHolderRef), - BranchUtil.makeAddTermName (Path.convert guidPath) (d guidRef) + [ BranchUtil.makeAddTermName (first PP.absPath authorPath) (d authorRef), + BranchUtil.makeAddTermName (first PP.absPath copyrightHolderPath) (d copyrightHolderRef), + BranchUtil.makeAddTermName (first PP.absPath guidPath) (d guidRef) ] currentPath <- Cli.getCurrentPath finalBranch <- Cli.getCurrentBranch0 @@ -646,70 +565,27 @@ loop e = do hasConfirmed <- confirmedCommand input desc <- inputDescription input handleMoveAll hasConfirmed src' dest' desc - DeleteI dtarget -> case dtarget of - DeleteTarget'TermOrType doutput hqs -> delete input doutput Cli.getTermsAt Cli.getTypesAt hqs - DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) Cli.getTypesAt hqs - DeleteTarget'Term doutput hqs -> delete input doutput Cli.getTermsAt (const (pure Set.empty)) hqs - DeleteTarget'Namespace insistence Nothing -> do - hasConfirmed <- confirmedCommand input - if hasConfirmed || insistence == Force - then do - description <- inputDescription input - Cli.updateRoot Branch.empty description - Cli.respond DeletedEverything - else Cli.respond DeleteEverythingConfirmation - DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do - branch <- Cli.expectBranchAtPath (Path.unsplit p) - description <- inputDescription input - let toDelete = - Names.prefix0 - (Path.unsafeToName (Path.unsplit (p))) - (Branch.toNames (Branch.head branch)) - afterDelete <- do - names <- Cli.currentNames - endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names) - case (null endangerments, insistence) of - (True, _) -> pure (Cli.respond Success) - (False, Force) -> do - ppeDecl <- Cli.currentPrettyPrintEnvDecl - pure do - Cli.respond Success - Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments - (False, Try) -> do - ppeDecl <- Cli.currentPrettyPrintEnvDecl - Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments - Cli.returnEarlyWithoutOutput - parentPathAbs <- Cli.resolvePath parentPath - -- We have to modify the parent in order to also wipe out the history at the - -- child. - Cli.updateAt description parentPathAbs \parentBranch -> - parentBranch - & Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty - afterDelete - DeleteTarget'ProjectBranch name -> handleDeleteBranch name - DeleteTarget'Project name -> handleDeleteProject name + DeleteI dtarget -> do + pp <- Cli.getCurrentProjectPath + let getTerms (absPath, seg) = Cli.getTermsAt (set PP.absPath_ absPath pp, seg) + let getTypes (absPath, seg) = Cli.getTypesAt (set PP.absPath_ absPath pp, seg) + case dtarget of + DeleteTarget'TermOrType doutput hqs -> do + delete input doutput getTerms getTypes hqs + DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) getTypes hqs + DeleteTarget'Term doutput hqs -> delete input doutput getTerms (const (pure Set.empty)) hqs + DeleteTarget'Namespace insistence path -> handleDeleteNamespace input insistence path + DeleteTarget'ProjectBranch name -> handleDeleteBranch name + DeleteTarget'Project name -> handleDeleteProject name DisplayI outputLoc namesToDisplay -> do traverse_ (displayI outputLoc) namesToDisplay ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query - EditNamespaceI paths -> handleEditNamespace LatestFileLocation paths - FindShallowI pathArg -> do - Cli.Env {codebase} <- ask - - pathArgAbs <- Cli.resolvePath' pathArg - entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs) - Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries - pped <- Cli.currentPrettyPrintEnvDecl - let suffixifiedPPE = PPED.suffixifiedPPE pped - -- This used to be a delayed action which only forced the loading of the root - -- branch when it was necessary for printing the results, but that got wiped out - -- when we ported to the new Cli monad. - -- It would be nice to restore it, but it's pretty rare that it actually results - -- in an improvement, so perhaps it's not worth the effort. - let buildPPE = pure suffixifiedPPE - Cli.respond $ ListShallow buildPPE entries + EditNamespaceI paths -> handleEditNamespace (LatestFileLocation AboveFold) paths + FindShallowI pathArg -> handleLs pathArg FindI isVerbose fscope ws -> handleFindI isVerbose fscope ws input StructuredFindI _fscope ws -> handleStructuredFindI ws StructuredFindReplaceI ws -> handleStructuredFindReplaceI ws + TextFindI allowLib ws -> handleTextFindI allowLib ws LoadI maybePath -> handleLoad maybePath ClearI -> Cli.respond ClearScreen AddI requestedNames -> do @@ -717,16 +593,17 @@ loop e = do let vars = Set.map Name.toVar requestedNames uf <- Cli.expectLatestTypecheckedFile Cli.Env {codebase} <- ask - currentPath <- Cli.getCurrentPath currentNames <- Branch.toNames <$> Cli.getCurrentBranch0 let sr = Slurp.slurpFile uf vars Slurp.AddOp currentNames let adds = SlurpResult.adds sr - Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf) Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf - pped <- Cli.prettyPrintEnvDeclFromNames $ UF.addNamesFromTypeCheckedUnisonFile uf currentNames + pp <- Cli.getCurrentProjectPath + Cli.stepAt description (pp, doSlurpAdds adds uf) + let pped = + let names = UF.addNamesFromTypeCheckedUnisonFile uf currentNames + in PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) let suffixifiedPPE = PPED.suffixifiedPPE pped Cli.respond $ SlurpOutput input suffixifiedPPE sr - Cli.syncRoot description SaveExecuteResultI resultName -> handleAddRun input resultName PreviewAddI requestedNames -> do (sourceName, _) <- Cli.expectLatestFile @@ -744,18 +621,16 @@ loop e = do currentNames <- Branch.toNames <$> Cli.getCurrentBranch0 let sr = Slurp.slurpFile uf vars Slurp.UpdateOp currentNames previewResponse sourceName sr uf - TodoI patchPath branchPath' -> do - patch <- Cli.getPatchAt (fromMaybe Cli.defaultPatchPath patchPath) - branchPath <- Cli.resolvePath' branchPath' - doShowTodoOutput patch branchPath - TestI testInput -> Tests.handleTest testInput + TodoI -> handleTodo + TestI native testInput -> Tests.handleTest native testInput ExecuteI main args -> handleRun False main args - MakeStandaloneI output main -> doCompile False output main - CompileSchemeI output main -> - doCompile True (Text.unpack output) main + MakeStandaloneI output main -> + doCompile False False output main + CompileSchemeI prof output main -> + doCompile prof True (Text.unpack output) main ExecuteSchemeI main args -> handleRun True main args - IOTestI main -> Tests.handleIOTest main - IOTestAllI -> Tests.handleAllIOTests + IOTestI native main -> Tests.handleIOTest native main + IOTestAllI native -> Tests.handleAllIOTests native -- UpdateBuiltinsI -> do -- stepAt updateBuiltins -- checkTodo @@ -779,7 +654,8 @@ loop e = do let destPath = case opath of Just path -> Path.resolve currentPath (Path.Relative path) Nothing -> currentPath `snoc` NameSegment.builtinSegment - _ <- Cli.updateAtM description destPath \destb -> + pp <- set PP.absPath_ destPath <$> Cli.getCurrentProjectPath + _ <- Cli.updateAtM description pp \destb -> liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) Cli.respond Success MergeIOBuiltinsI opath -> do @@ -806,7 +682,8 @@ loop e = do let destPath = case opath of Just path -> Path.resolve currentPath (Path.Relative path) Nothing -> currentPath `snoc` NameSegment.builtinSegment - _ <- Cli.updateAtM description destPath \destb -> + pp <- set PP.absPath_ destPath <$> Cli.getCurrentProjectPath + _ <- Cli.updateAtM description pp \destb -> liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) Cli.respond Success PullI sourceTarget pullMode -> handlePull sourceTarget pullMode @@ -828,20 +705,21 @@ loop e = do Cli.respond $ DumpUnisonFileHashes hqLength datas effects terms DebugTabCompletionI inputs -> do Cli.Env {authHTTPClient, codebase} <- ask - currentPath <- Cli.getCurrentPath - let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient currentPath + pp <- Cli.getCurrentProjectPath + let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient pp (_, completions) <- liftIO $ completionFunc (reverse (unwords inputs), "") Cli.respond (DisplayDebugCompletions completions) + DebugLSPNameCompletionI prefix -> do + LSPDebug.debugLspNameCompletion prefix DebugFuzzyOptionsI command args -> do Cli.Env {codebase} <- ask - currentPath <- Cli.getCurrentPath currentBranch <- Branch.withoutTransitiveLibs <$> Cli.getCurrentBranch0 - let projCtx = projectContextFromPath currentPath case Map.lookup command InputPatterns.patternMap of Just (IP.InputPattern {args = argTypes}) -> do zip argTypes args & Monoid.foldMapM \case ((argName, _, IP.ArgumentType {fzfResolver = Just IP.FZFResolver {getOptions}}), "_") -> do - results <- liftIO $ getOptions codebase projCtx currentBranch + pp <- Cli.getCurrentProjectPath + results <- liftIO $ getOptions codebase pp currentBranch Cli.respond (DebugDisplayFuzzyOptions argName (Text.unpack <$> results)) ((_, _, IP.ArgumentType {fzfResolver = Nothing}), "_") -> do Cli.respond DebugFuzzyOptionsNoResolver @@ -849,24 +727,25 @@ loop e = do Nothing -> do Cli.respond DebugFuzzyOptionsNoResolver DebugFormatI -> do - Cli.Env {writeSource, loadSource} <- ask + env <- ask void $ runMaybeT do (filePath, _) <- MaybeT Cli.getLatestFile pf <- lift Cli.getLatestParsedFile tf <- lift Cli.getLatestTypecheckedFile names <- lift Cli.currentNames let buildPPED uf tf = - Cli.prettyPrintEnvDeclFromNames $ (fromMaybe mempty $ (UF.typecheckedToNames <$> tf) <|> (UF.toNames <$> uf)) `Names.shadowing` names + let names' = (fromMaybe mempty $ (UF.typecheckedToNames <$> tf) <|> (UF.toNames <$> uf)) `Names.shadowing` names + in pure (PPED.makePPED (PPE.hqNamer 10 names') (PPE.suffixifyByHashName names')) let formatWidth = 80 currentPath <- lift $ Cli.getCurrentPath updates <- MaybeT $ Format.formatFile buildPPED formatWidth currentPath pf tf Nothing source <- - liftIO (loadSource (Text.pack filePath)) >>= \case + liftIO (env.loadSource (Text.pack filePath)) >>= \case Cli.InvalidSourceNameError -> lift $ Cli.returnEarly $ Output.InvalidSourceName filePath Cli.LoadError -> lift $ Cli.returnEarly $ Output.SourceLoadFailed filePath Cli.LoadSuccess contents -> pure contents let updatedSource = Format.applyTextReplacements updates source - liftIO $ writeSource (Text.pack filePath) updatedSource + liftIO $ env.writeSource (Text.pack filePath) updatedSource True DebugDumpNamespacesI -> do let seen h = State.gets (Set.member h) set h = State.modify (Set.insert h) @@ -911,13 +790,13 @@ loop e = do prettyRef renderR r = P.indentN 2 $ P.text (renderR r) prettyDefn renderR (r, Foldable.toList -> names) = P.lines (P.text <$> if null names then [""] else NameSegment.toEscapedText <$> names) <> P.newline <> prettyRef renderR r - rootBranch <- Cli.getRootBranch - void . liftIO . flip State.execStateT mempty $ goCausal [getCausal rootBranch] + projectRoot <- Cli.getCurrentProjectRoot + void . liftIO . flip State.execStateT mempty $ goCausal [getCausal projectRoot] DebugDumpNamespaceSimpleI -> do - rootBranch0 <- Cli.getRootBranch0 - for_ (Relation.toList . Branch.deepTypes $ rootBranch0) \(r, name) -> + projectRootBranch0 <- Cli.getCurrentProjectRoot0 + for_ (Relation.toList . Branch.deepTypes $ projectRootBranch0) \(r, name) -> traceM $ show name ++ ",Type," ++ Text.unpack (Reference.toText r) - for_ (Relation.toList . Branch.deepTerms $ rootBranch0) \(r, name) -> + for_ (Relation.toList . Branch.deepTerms $ projectRootBranch0) \(r, name) -> traceM $ show name ++ ",Term," ++ Text.unpack (Referent.toText r) DebugTermI isVerbose hqName -> DebugDefinition.debugTerm isVerbose hqName DebugLSPFoldRangesI -> do @@ -957,7 +836,7 @@ loop e = do Cli.respond $ PrintVersion ucmVersion ProjectRenameI name -> handleProjectRename name ProjectSwitchI name -> projectSwitch name - ProjectCreateI tryDownloadingBase name -> projectCreate tryDownloadingBase name + ProjectCreateI tryDownloadingBase name -> void $ projectCreate tryDownloadingBase name ProjectsI -> handleProjects BranchI source name -> handleBranch source name BranchRenameI name -> handleBranchRename name @@ -967,6 +846,8 @@ loop e = do UpgradeI old new -> handleUpgrade old new UpgradeCommitI -> handleCommitUpgrade LibInstallI remind libdep -> handleInstallLib remind libdep + DebugSynhashTermI name -> handleDebugSynhashTerm name + EditDependentsI name -> handleEditDependents name inputDescription :: Input -> Cli Text inputDescription input = @@ -977,35 +858,29 @@ inputDescription input = dest <- brp dest0 pure ("fork " <> src <> " " <> dest) MergeLocalBranchI src0 dest0 mode -> do - src <- looseCodeOrProjectToText src0 - dest <- looseCodeOrProjectToText dest0 + let src = into @Text src0 + let dest = maybe "" (into @Text) dest0 let command = case mode of Branch.RegularMerge -> "merge" Branch.SquashMerge -> "merge.squash" pure (command <> " " <> src <> " " <> dest) - ResetI hash tgt -> do - hashTxt <- case hash of - This hash -> hp' hash - That pr -> pure (into @Text pr) - These hash _pr -> hp' hash + ResetI newRoot tgt -> do + hashTxt <- bid2 newRoot tgt <- case tgt of Nothing -> pure "" Just tgt -> do - tgt <- looseCodeOrProjectToText tgt - pure (" " <> tgt) + let tgtText = into @Text tgt + pure (" " <> tgtText) pure ("reset " <> hashTxt <> tgt) - ResetRootI src0 -> do - src <- hp' src0 - pure ("reset-root " <> src) - AliasTermI src0 dest0 -> do + AliasTermI force src0 dest0 -> do src <- hhqs' src0 dest <- ps' dest0 - pure ("alias.term " <> src <> " " <> dest) - AliasTypeI src0 dest0 -> do + pure ((if force then "debug.alias.term.force " else "alias.term ") <> src <> " " <> dest) + AliasTypeI force src0 dest0 -> do src <- hhqs' src0 dest <- ps' dest0 - pure ("alias.type " <> src <> " " <> dest) + pure ((if force then "debug.alias.type.force " else "alias.term ") <> src <> " " <> dest) AliasManyI srcs0 dest0 -> do srcs <- traverse hqs srcs0 dest <- p' dest0 @@ -1065,8 +940,11 @@ inputDescription input = Update2I -> pure ("update") UndoI {} -> pure "undo" ExecuteI s args -> pure ("execute " <> Text.unwords (HQ.toText s : fmap Text.pack args)) - IOTestI hq -> pure ("io.test " <> HQ.toText hq) - IOTestAllI -> pure "io.test.all" + IOTestI native hq -> pure (cmd <> HQ.toText hq) + where + cmd | native = "io.test.native " | otherwise = "io.test " + IOTestAllI native -> + pure (if native then "io.test.native.all" else "io.test.all") UpdateBuiltinsI -> pure "builtins.update" MergeBuiltinsI Nothing -> pure "builtins.merge" MergeBuiltinsI (Just path) -> ("builtins.merge " <>) <$> p path @@ -1075,11 +953,22 @@ inputDescription input = MakeStandaloneI out nm -> pure ("compile " <> Text.pack out <> " " <> HQ.toText nm) ExecuteSchemeI nm args -> pure $ "run.native " <> Text.unwords (HQ.toText nm : fmap Text.pack args) - CompileSchemeI fi nm -> pure ("compile.native " <> HQ.toText nm <> " " <> fi) + CompileSchemeI pr fi nm -> + pure ("compile.native " <> HQ.toText nm <> " " <> fi <> if pr then " profile" else "") CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name) ClearI {} -> pure "clear" DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name) - -- + DebugTermI verbose hqName -> + if verbose + then pure ("debug.term.verbose " <> HQ.toText hqName) + else pure ("debug.term " <> HQ.toText hqName) + DebugTypeI hqName -> pure ("debug.type " <> HQ.toText hqName) + DebugLSPFoldRangesI -> pure "debug.lsp.fold-ranges" + DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input) + DebugFormatI -> pure "debug.format" + EditNamespaceI paths -> + pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths)) + -- wat land ApiI -> wat AuthLoginI {} -> wat BranchI {} -> wat @@ -1091,33 +980,26 @@ inputDescription input = DebugDoctorI {} -> wat DebugDumpNamespaceSimpleI {} -> wat DebugDumpNamespacesI {} -> wat - DebugTermI verbose hqName -> - if verbose - then pure ("debug.term.verbose " <> HQ.toText hqName) - else pure ("debug.term " <> HQ.toText hqName) - DebugTypeI hqName -> pure ("debug.type " <> HQ.toText hqName) - DebugLSPFoldRangesI -> pure "debug.lsp.fold-ranges" + DebugLSPNameCompletionI {} -> wat DebugNameDiffI {} -> wat DebugNumberedArgsI {} -> wat - DebugTabCompletionI _input -> wat - DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input) - DebugFormatI -> pure "debug.format" + DebugSynhashTermI {} -> wat + DebugTabCompletionI {} -> wat DebugTypecheckedUnisonFileI {} -> wat DiffNamespaceI {} -> wat DisplayI {} -> wat DocsI {} -> wat DocsToHtmlI {} -> wat + EditDependentsI {} -> wat FindI {} -> wat FindShallowI {} -> wat - StructuredFindI {} -> wat - StructuredFindReplaceI {} -> wat HistoryI {} -> wat LibInstallI {} -> wat ListDependenciesI {} -> wat ListDependentsI {} -> wat LoadI {} -> wat - MergeI {} -> wat MergeCommitI {} -> wat + MergeI {} -> wat NamesI {} -> wat NamespaceDependenciesI {} -> wat PopBranchI {} -> wat @@ -1133,26 +1015,35 @@ inputDescription input = QuitI {} -> wat ReleaseDraftI {} -> wat ShowDefinitionI {} -> wat - EditNamespaceI paths -> - pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths)) - ShowReflogI {} -> wat + StructuredFindI {} -> wat + StructuredFindReplaceI {} -> wat + TextFindI {} -> wat + ShowRootReflogI {} -> pure "deprecated.root-reflog" + ShowGlobalReflogI {} -> pure "reflog.global" + ShowProjectReflogI mayProjName -> do + case mayProjName of + Nothing -> pure "project.reflog" + Just projName -> pure $ "project.reflog" <> into @Text projName + ShowProjectBranchReflogI mayProjBranch -> do + case mayProjBranch of + Nothing -> pure "branch.reflog" + Just (PP.ProjectAndBranch Nothing branchName) -> pure $ "branch.reflog" <> into @Text branchName + Just (PP.ProjectAndBranch (Just projName) branchName) -> pure $ "branch.reflog" <> into @Text (PP.ProjectAndBranch projName branchName) SwitchBranchI {} -> wat TestI {} -> wat TodoI {} -> wat UiI {} -> wat UpI {} -> wat - UpgradeI {} -> wat UpgradeCommitI {} -> wat + UpgradeI {} -> wat VersionI -> wat where - hp' :: Either SCH.ShortCausalHash Path' -> Cli Text - hp' = either (pure . Text.pack . show) p' p :: Path -> Cli Text - p = fmap tShow . Cli.resolvePath + p = fmap (into @Text) . Cli.resolvePath p' :: Path' -> Cli Text - p' = fmap tShow . Cli.resolvePath' + p' = fmap (into @Text) . Cli.resolvePath' brp :: BranchRelativePath -> Cli Text - brp = fmap from . ProjectUtils.resolveBranchRelativePath + brp = fmap (into @Text) . ProjectUtils.resolveBranchRelativePath ops :: Maybe Path.Split -> Cli Text ops = maybe (pure ".") ps wat = error $ show input ++ " is not expected to alter the branch" @@ -1167,12 +1058,10 @@ inputDescription input = hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq) ps' = p' . Path.unsplit' ps = p . Path.unsplit - looseCodeOrProjectToText :: Input.LooseCodeOrProject -> Cli Text - looseCodeOrProjectToText = \case - This path -> p' path - That branch -> pure (into @Text branch) - -- just trying to recover the syntax the user wrote - These path _branch -> pure (Path.toText' path) + bid2 :: BranchId2 -> Cli Text + bid2 = \case + Left sch -> pure $ into @Text sch + Right p -> brp p handleFindI :: Bool -> @@ -1182,86 +1071,97 @@ handleFindI :: Cli () handleFindI isVerbose fscope ws input = do Cli.Env {codebase} <- ask - (pped, names, searchRoot, branch0) <- case fscope of + case fscope of FindLocal p -> do searchRoot <- Cli.resolvePath' p - branch0 <- Cli.getBranch0At searchRoot + branch0 <- Cli.getBranch0FromProjectPath searchRoot let names = Branch.toNames (Branch.withoutLib branch0) -- Don't exclude anything from the pretty printer, since the type signatures we print for -- results may contain things in lib. - pped <- Cli.currentPrettyPrintEnvDecl - pure (pped, names, Just p, branch0) + currentNames <- Cli.currentNames + let pped = PPED.makePPED (PPE.hqNamer 10 currentNames) (PPE.suffixifyByHash currentNames) + let suffixifiedPPE = PPED.suffixifiedPPE pped + results <- searchBranch0 codebase branch0 names + if (null results) + then do + Cli.respond FindNoLocalMatches + -- We've already searched everything else, so now we search JUST the + -- names in lib. + let mayOnlyLibBranch = branch0 & Branch.children %%~ \cs -> Map.singleton NameSegment.libSegment <$> Map.lookup NameSegment.libSegment cs + case mayOnlyLibBranch of + Nothing -> respondResults codebase suffixifiedPPE (Just p) [] + Just onlyLibBranch -> do + let onlyLibNames = Branch.toNames onlyLibBranch + results <- searchBranch0 codebase branch0 onlyLibNames + respondResults codebase suffixifiedPPE (Just p) results + else respondResults codebase suffixifiedPPE (Just p) results FindLocalAndDeps p -> do searchRoot <- Cli.resolvePath' p - branch0 <- Cli.getBranch0At searchRoot + branch0 <- Cli.getBranch0FromProjectPath searchRoot let names = Branch.toNames (Branch.withoutTransitiveLibs branch0) -- Don't exclude anything from the pretty printer, since the type signatures we print for -- results may contain things in lib. - pped <- Cli.currentPrettyPrintEnvDecl - pure (pped, names, Just p, branch0) + currentNames <- Cli.currentNames + let pped = PPED.makePPED (PPE.hqNamer 10 currentNames) (PPE.suffixifyByHash currentNames) + let suffixifiedPPE = PPED.suffixifiedPPE pped + results <- searchBranch0 codebase branch0 names + respondResults codebase suffixifiedPPE (Just p) results FindGlobal -> do - globalNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getRootBranch0 - pped <- Cli.prettyPrintEnvDeclFromNames globalNames - currentBranch0 <- Cli.getCurrentBranch0 - pure (pped, globalNames, Nothing, currentBranch0) - let suffixifiedPPE = PPED.suffixifiedPPE pped - let getResults :: Names -> Cli [SearchResult] - getResults names = - case ws of - [] -> pure (List.sortBy SR.compareByName (SR.fromNames names)) - -- type query - ":" : ws -> do - typ <- parseSearchType (show input) (unwords ws) - let keepNamed = Set.intersection (Branch.deepReferents branch0) - (noExactTypeMatches, matches) <- do - Cli.runTransaction do - matches <- keepNamed <$> Codebase.termsOfType codebase typ - if null matches - then (True,) . keepNamed <$> Codebase.termsMentioningType codebase typ - else pure (False, matches) - when noExactTypeMatches (Cli.respond NoExactTypeMatches) - pure $ - -- in verbose mode, aliases are shown, so we collapse all - -- aliases to a single search result; in non-verbose mode, - -- a separate result may be shown for each alias - (if isVerbose then uniqueBy SR.toReferent else id) $ - searchResultsFor names (Set.toList matches) [] + Global.forAllProjectBranches \(projAndBranchNames, _ids) branch -> do + let branch0 = Branch.head branch + let projectRootNames = Names.makeAbsolute . Branch.toNames $ branch0 + let pped = PPED.makePPED (PPE.hqNamer 10 projectRootNames) (PPE.suffixifyByHash projectRootNames) + results <- searchBranch0 codebase branch0 projectRootNames + when (not $ null results) do + Cli.setNumberedArgs $ fmap (SA.SearchResult Nothing) results + results' <- Cli.runTransaction (Backend.loadSearchResults codebase results) + Cli.respond $ GlobalFindBranchResults projAndBranchNames (PPED.suffixifiedPPE pped) isVerbose results' + where + searchBranch0 :: Codebase.Codebase m Symbol Ann -> Branch0 IO -> Names -> Cli [SearchResult] + searchBranch0 codebase branch0 names = + case ws of + [] -> pure (List.sortBy SR.compareByName (SR.fromNames names)) + -- type query + ":" : ws -> do + typ <- parseSearchType (show input) (unwords ws) + let keepNamed = Set.intersection (Branch.deepReferents branch0) + (noExactTypeMatches, matches) <- do + Cli.runTransaction do + matches <- keepNamed <$> Codebase.termsOfType codebase typ + if null matches + then (True,) . keepNamed <$> Codebase.termsMentioningType codebase typ + else pure (False, matches) + when noExactTypeMatches (Cli.respond NoExactTypeMatches) + pure $ + -- in verbose mode, aliases are shown, so we collapse all + -- aliases to a single search result; in non-verbose mode, + -- a separate result may be shown for each alias + (if isVerbose then uniqueBy SR.toReferent else id) $ + searchResultsFor names (Set.toList matches) [] - -- name query - qs -> do - let anythingBeforeHash :: Megaparsec.Parsec (Lexer.Token Text) [Char] Text - anythingBeforeHash = Text.pack <$> Megaparsec.takeWhileP Nothing (/= '#') - let srs = - searchBranchScored - names - Find.simpleFuzzyScore - (mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs) - pure $ uniqueBy SR.toReferent srs - let respondResults results = do - Cli.setNumberedArgs $ fmap (SA.SearchResult searchRoot) results - results' <- Cli.runTransaction (Backend.loadSearchResults codebase results) - Cli.respond $ ListOfDefinitions fscope suffixifiedPPE isVerbose results' - results <- getResults names - case (results, fscope) of - ([], FindLocal {}) -> do - Cli.respond FindNoLocalMatches - -- We've already searched everything else, so now we search JUST the - -- names in lib. - let mayOnlyLibBranch = branch0 & Branch.children %%~ \cs -> Map.singleton NameSegment.libSegment <$> Map.lookup NameSegment.libSegment cs - case mayOnlyLibBranch of - Nothing -> respondResults [] - Just onlyLibBranch -> do - let onlyLibNames = Branch.toNames onlyLibBranch - results <- getResults onlyLibNames - respondResults results - _ -> respondResults results + -- name query + qs -> do + let anythingBeforeHash :: Megaparsec.Parsec (L.Token Text) [Char] Text + anythingBeforeHash = Text.pack <$> Megaparsec.takeWhileP Nothing (/= '#') + let srs = + searchBranchScored + names + Find.simpleFuzzyScore + (mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs) + pure $ uniqueBy SR.toReferent srs + respondResults :: Codebase.Codebase m Symbol Ann -> PPE.PrettyPrintEnv -> Maybe Path' -> [SearchResult] -> Cli () + respondResults codebase ppe searchRoot results = do + Cli.setNumberedArgs $ fmap (SA.SearchResult searchRoot) results + results' <- Cli.runTransaction (Backend.loadSearchResults codebase results) + Cli.respond $ ListOfDefinitions fscope ppe isVerbose results' handleDependencies :: HQ.HashQualified Name -> Cli () handleDependencies hq = do Cli.Env {codebase} <- ask -- todo: add flag to handle transitive efficiently lds <- resolveHQToLabeledDependencies hq - pped <- Cli.currentPrettyPrintEnvDecl + names <- Cli.currentNames + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) let suffixifiedPPE = PPED.suffixifiedPPE pped when (null lds) do Cli.returnEarly (LabeledReferenceNotFound hq) @@ -1295,114 +1195,17 @@ handleDependencies hq = do Cli.setNumberedArgs . map SA.HashQualified $ types <> terms Cli.respond $ ListDependencies suffixifiedPPE lds types terms -handleDependents :: HQ.HashQualified Name -> Cli () -handleDependents hq = do - -- todo: add flag to handle transitive efficiently - lds <- resolveHQToLabeledDependencies hq - -- Use an unsuffixified PPE here, so we display full names (relative to the current path), - -- rather than the shortest possible unambiguous name. - pped <- Cli.currentPrettyPrintEnvDecl - let fqppe = PPE.unsuffixifiedPPE pped - let ppe = PPE.suffixifiedPPE pped - when (null lds) do - Cli.returnEarly (LabeledReferenceNotFound hq) - - results <- for (toList lds) \ld -> do - -- The full set of dependent references, any number of which may not have names in the current namespace. - dependents <- - let tp = Codebase.dependents Queries.ExcludeOwnComponent - tm = \case - Referent.Ref r -> Codebase.dependents Queries.ExcludeOwnComponent r - Referent.Con (ConstructorReference r _cid) _ct -> - Codebase.dependents Queries.ExcludeOwnComponent r - in Cli.runTransaction (LD.fold tp tm ld) - let -- True is term names, False is type names - results :: [(Bool, HQ.HashQualified Name, Reference)] - results = do - r <- Set.toList dependents - Just (isTerm, hq) <- [(True,) <$> PPE.terms fqppe (Referent.Ref r), (False,) <$> PPE.types fqppe r] - fullName <- [HQ'.toName hq] - guard (not (Name.beginsWithSegment fullName NameSegment.libSegment)) - Just shortName <- pure $ PPE.terms ppe (Referent.Ref r) <|> PPE.types ppe r - pure (isTerm, HQ'.toHQ shortName, r) - pure results - let sort = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst) - let types = sort [(n, r) | (False, n, r) <- join results] - let terms = sort [(n, r) | (True, n, r) <- join results] - Cli.setNumberedArgs . map SA.HashQualified $ types <> terms - Cli.respond (ListDependents ppe lds types terms) - --- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. -handleShowDefinition :: OutputLocation -> ShowDefinitionScope -> NonEmpty (HQ.HashQualified Name) -> Cli () -handleShowDefinition outputLoc showDefinitionScope query = do - Cli.Env {codebase} <- ask - hqLength <- Cli.runTransaction Codebase.hashLength - let hasAbsoluteQuery = any (any Name.isAbsolute) query - (names, unbiasedPPED) <- case (hasAbsoluteQuery, showDefinitionScope) of - -- If any of the queries are absolute, use global names. - -- TODO: We should instead print each definition using the names from its project-branch root. - (True, _) -> do - root <- Cli.getRootBranch - let root0 = Branch.head root - let names = Names.makeAbsolute $ Branch.toNames root0 - pped <- Cli.prettyPrintEnvDeclFromNames names - pure (names, pped) - (_, ShowDefinitionGlobal) -> do - root <- Cli.getRootBranch - let root0 = Branch.head root - let names = Names.makeAbsolute $ Branch.toNames root0 - pped <- Cli.prettyPrintEnvDeclFromNames names - pure (names, pped) - (_, ShowDefinitionLocal) -> do - currentNames <- Cli.currentNames - pped <- Cli.prettyPrintEnvDeclFromNames currentNames - pure (currentNames, pped) - let pped = PPED.biasTo (mapMaybe HQ.toName (toList query)) unbiasedPPED - Backend.DefinitionResults terms types misses <- do - let nameSearch = NameSearch.makeNameSearch hqLength names - Cli.runTransaction (Backend.definitionsByName codebase nameSearch includeCycles Names.IncludeSuffixes (toList query)) - showDefinitions outputLoc pped terms types misses - where - -- `view`: don't include cycles; `edit`: include cycles - includeCycles = - case outputLoc of - ConsoleLocation -> Backend.DontIncludeCycles - FileLocation _ -> Backend.IncludeCycles - LatestFileLocation -> Backend.IncludeCycles - --- todo: compare to `getHQTerms` / `getHQTypes`. Is one universally better? -resolveHQToLabeledDependencies :: HQ.HashQualified Name -> Cli (Set LabeledDependency) -resolveHQToLabeledDependencies = \case - HQ.NameOnly n -> do - names <- Cli.currentNames - let terms, types :: Set LabeledDependency - terms = Set.map LD.referent . Name.searchBySuffix n $ Names.terms names - types = Set.map LD.typeRef . Name.searchBySuffix n $ Names.types names - pure $ terms <> types - -- rationale: the hash should be unique enough that the name never helps - HQ.HashQualified _n sh -> resolveHashOnly sh - HQ.HashOnly sh -> resolveHashOnly sh - where - resolveHashOnly sh = do - Cli.Env {codebase} <- ask - (terms, types) <- - Cli.runTransaction do - terms <- Backend.termReferentsByShortHash codebase sh - types <- Backend.typeReferencesByShortHash sh - pure (terms, types) - pure $ Set.map LD.referent terms <> Set.map LD.typeRef types - doDisplay :: OutputLocation -> Names -> Term Symbol () -> Cli () doDisplay outputLoc names tm = do Cli.Env {codebase} <- ask loopState <- State.get - pped <- Cli.prettyPrintEnvDeclFromNames names + let pped = PPED.makePPED (PPE.hqNamer 10 names) (suffixify names) let suffixifiedPPE = PPED.suffixifiedPPE pped (tms, typs) <- maybe mempty UF.indexByReference <$> Cli.getLatestTypecheckedFile let useCache = True evalTerm tm = fmap ErrorUtil.hush . fmap (fmap Term.unannotate) $ - RuntimeUtils.evalUnisonTermE True suffixifiedPPE useCache (Term.amap (const External) tm) + RuntimeUtils.evalUnisonTermE Sandboxed suffixifiedPPE useCache (Term.amap (const External) tm) loadTerm (Reference.DerivedId r) = case Map.lookup r tms of Nothing -> fmap (fmap Term.unannotate) $ Cli.runTransaction (Codebase.getTerm codebase r) Just (_, tm, _) -> pure (Just $ Term.unannotate tm) @@ -1417,12 +1220,18 @@ doDisplay outputLoc names tm = do rendered <- DisplayValues.displayTerm pped loadTerm loadTypeOfTerm' evalTerm loadDecl tm mayFP <- case outputLoc of ConsoleLocation -> pure Nothing - FileLocation path -> Just <$> Directory.canonicalizePath path - LatestFileLocation -> traverse Directory.canonicalizePath $ fmap fst (loopState ^. #latestFile) <|> Just "scratch.u" + FileLocation path _ -> Just <$> Directory.canonicalizePath path + LatestFileLocation _ -> traverse Directory.canonicalizePath $ fmap fst (loopState ^. #latestFile) <|> Just "scratch.u" whenJust mayFP \fp -> do liftIO $ prependFile fp (Text.pack . P.toPlain 80 $ rendered) Cli.respond $ DisplayRendered mayFP rendered where + suffixify = + case outputLoc of + ConsoleLocation -> PPE.suffixifyByHash + FileLocation _ _ -> PPE.suffixifyByHashName + LatestFileLocation _ -> PPE.suffixifyByHashName + prependFile :: FilePath -> Text -> IO () prependFile filePath txt = do exists <- Directory.doesFileExist filePath @@ -1433,58 +1242,6 @@ doDisplay outputLoc names tm = do else do writeUtf8 filePath txt --- | Show todo output if there are any conflicts or edits. -doShowTodoOutput :: Patch -> Path.Absolute -> Cli () -doShowTodoOutput patch scopePath = do - Cli.Env {codebase} <- ask - names0 <- Branch.toNames <$> Cli.getBranch0At scopePath - todo <- Cli.runTransaction (checkTodo codebase patch names0) - if TO.noConflicts todo && TO.noEdits todo - then Cli.respond NoConflictsOrEdits - else do - Cli.setNumberedArgs $ - SA.HashQualified . HQ.HashOnly . Reference.toShortHash . view _2 - <$> fst (TO.todoFrontierDependents todo) - pped <- Cli.currentPrettyPrintEnvDecl - Cli.respondNumbered $ TodoOutput pped todo - -checkTodo :: Codebase m Symbol Ann -> Patch -> Names -> Sqlite.Transaction (TO.TodoOutput Symbol Ann) -checkTodo codebase patch names0 = do - let -- Get the dependents of a reference which: - -- 1. Don't appear on the LHS of this patch - -- 2. Have a name in this namespace - getDependents :: Reference -> Sqlite.Transaction (Set Reference) - getDependents ref = do - dependents <- Codebase.dependents Queries.ExcludeSelf ref - pure (dependents & removeEditedThings & removeNamelessThings) - -- (r,r2) ∈ dependsOn if r depends on r2, excluding self-references (i.e. (r,r)) - dependsOn <- Monoid.foldMapM (\ref -> R.fromManyDom <$> getDependents ref <*> pure ref) edited - let dirty = R.dom dependsOn - transitiveDirty <- transitiveClosure getDependents dirty - (frontierTerms, frontierTypes) <- loadDisplayInfo codebase (R.ran dependsOn) - (dirtyTerms, dirtyTypes) <- loadDisplayInfo codebase dirty - pure $ - TO.TodoOutput - (Set.size transitiveDirty) - (frontierTerms, frontierTypes) - (score dirtyTerms, score dirtyTypes) - (Names.conflicts names0) - (Patch.conflicts patch) - where - -- Remove from a all references that were edited, i.e. appear on the LHS of this patch. - removeEditedThings :: Set Reference -> Set Reference - removeEditedThings = - (`Set.difference` edited) - -- Remove all references that don't have a name in the given namespace - removeNamelessThings :: Set Reference -> Set Reference - removeNamelessThings = - Set.filter (Names.contains names0) - -- todo: something more intelligent here? - score :: [(a, b)] -> [(TO.Score, a, b)] - score = map (\(x, y) -> (1, x, y)) - edited :: Set Reference - edited = R.dom (Patch._termEdits patch) <> R.dom (Patch._typeEdits patch) - confirmedCommand :: Input -> Cli Bool confirmedCommand i = do loopState <- State.get @@ -1572,20 +1329,21 @@ searchBranchScored names0 score queries = pair qn = (\score -> (Just score, result)) <$> score qn (Name.toText name) -doCompile :: Bool -> String -> HQ.HashQualified Name -> Cli () -doCompile native output main = do +doCompile :: Bool -> Bool -> String -> HQ.HashQualified Name -> Cli () +doCompile profile native output main = do Cli.Env {codebase, runtime, nativeRuntime} <- ask let theRuntime | native = nativeRuntime | otherwise = runtime (ref, ppe) <- resolveMainRef main - let codeLookup = () <$ Codebase.toCodeLookup codebase + let codeLookup = () <$ Codebase.codebaseToCodeLookup codebase outf | native = output | otherwise = output <> ".uc" + copts = Runtime.defaultCompileOpts {Runtime.profile = profile} whenJustM ( liftIO $ - Runtime.compileTo theRuntime codeLookup ppe ref outf + Runtime.compileTo theRuntime copts codeLookup ppe ref outf ) (Cli.returnEarly . EvaluationFailure) @@ -1602,8 +1360,8 @@ delete input doutput getTerms getTypes hqs' = do traverse ( \hq -> do absolute <- Cli.resolveSplit' hq - types <- getTypes absolute - terms <- getTerms absolute + types <- getTypes (first PP.absPath absolute) + terms <- getTerms (first PP.absPath absolute) return (hq, types, terms) ) hqs' @@ -1613,7 +1371,7 @@ delete input doutput getTerms getTypes hqs' = do then do let toName :: [(Path.HQSplit', Set Reference, Set referent)] -> [Name] toName notFounds = - mapMaybe (\(split, _, _) -> Path.toName' $ HashQualified.toName (HQSplit'.unsplitHQ' split)) notFounds + map (\(split, _, _) -> HQ'.toName $ Path.nameFromHQSplit' split) notFounds Cli.returnEarly $ NamesNotFound (toName notFounds) else do checkDeletes typesTermsTuple doutput input @@ -1622,19 +1380,22 @@ checkDeletes :: [(Path.HQSplit', Set Reference, Set Referent)] -> DeleteOutput - checkDeletes typesTermsTuples doutput inputs = do let toSplitName :: (Path.HQSplit', Set Reference, Set Referent) -> - Cli (Path.Split, Name, Set Reference, Set Referent) + Cli (Path.AbsSplit, Name, Set Reference, Set Referent) toSplitName hq = do - resolvedPath <- Path.convert <$> Cli.resolveSplit' (HQ'.toName <$> hq ^. _1) - return (resolvedPath, Path.unsafeToName (Path.unsplit resolvedPath), hq ^. _2, hq ^. _3) + (pp, ns) <- Cli.resolveSplit' (HQ'.toName <$> hq ^. _1) + let resolvedSplit = (pp.absPath, ns) + return + (resolvedSplit, Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative . Path.unabsolute) resolvedSplit, hq ^. _2, hq ^. _3) + -- get the splits and names with terms and types splitsNames <- traverse toSplitName typesTermsTuples let toRel :: (Ord ref) => Set ref -> Name -> R.Relation Name ref toRel setRef name = R.fromList (fmap (name,) (toList setRef)) let toDelete = fmap (\(_, names, types, terms) -> Names (toRel terms names) (toRel types names)) splitsNames -- make sure endangered is compeletely contained in paths - -- TODO: We should just check for endangerments from the project root, not the - -- global root! - rootNames <- Branch.toNames <$> Cli.getRootBranch0 + currentBranch <- Cli.getCurrentProjectRoot0 + let projectNames = Branch.toNames currentBranch + projectNamesSansLib = Branch.toNames (Branch.deleteLibdeps currentBranch) -- get only once for the entire deletion set let allTermsToDelete :: Set LabeledDependency allTermsToDelete = Set.unions (fmap Names.labeledReferences toDelete) @@ -1642,9 +1403,7 @@ checkDeletes typesTermsTuples doutput inputs = do endangered <- Cli.runTransaction $ traverse - ( \targetToDelete -> - getEndangeredDependents targetToDelete (allTermsToDelete) rootNames - ) + (\targetToDelete -> getEndangeredDependents targetToDelete allTermsToDelete projectNames projectNamesSansLib) toDelete -- If the overall dependency map is not completely empty, abort deletion let endangeredDeletions = List.filter (\m -> not $ null m || Map.foldr (\s b -> null s || b) False m) endangered @@ -1658,7 +1417,8 @@ checkDeletes typesTermsTuples doutput inputs = do ) before <- Cli.getCurrentBranch0 description <- inputDescription inputs - Cli.stepManyAt description deleteTypesTerms + pb <- Cli.getCurrentProjectBranch + Cli.stepManyAt pb description deleteTypesTerms case doutput of DeleteOutput'Diff -> do after <- Cli.getCurrentBranch0 @@ -1667,58 +1427,10 @@ checkDeletes typesTermsTuples doutput inputs = do DeleteOutput'NoDiff -> do Cli.respond Success else do - ppeDecl <- Cli.prettyPrintEnvDeclFromNames rootNames + let ppeDecl = PPED.makePPED (PPE.hqNamer 10 projectNames) (PPE.suffixifyByHash projectNames) let combineRefs = List.foldl (Map.unionWith NESet.union) Map.empty endangeredDeletions Cli.respondNumbered (CantDeleteDefinitions ppeDecl combineRefs) --- | Goal: When deleting, we might be removing the last name of a given definition (i.e. the --- definition is going "extinct"). In this case we may wish to take some action or warn the --- user about these "endangered" definitions which would now contain unnamed references. --- The argument `otherDesiredDeletions` is included in this function because the user might want to --- delete a term and all its dependencies in one command, so we give this function access to --- the full set of entities that the user wishes to delete. -getEndangeredDependents :: - -- | Prospective target for deletion - Names -> - -- | All entities we want to delete (including the target) - Set LabeledDependency -> - -- | Names from the current branch - Names -> - -- | map from references going extinct to the set of endangered dependents - Sqlite.Transaction (Map LabeledDependency (NESet LabeledDependency)) -getEndangeredDependents targetToDelete otherDesiredDeletions rootNames = do - -- names of terms left over after target deletion - let remainingNames :: Names - remainingNames = rootNames `Names.difference` targetToDelete - -- target refs for deletion - let refsToDelete :: Set LabeledDependency - refsToDelete = Names.labeledReferences targetToDelete - -- refs left over after deleting target - let remainingRefs :: Set LabeledDependency - remainingRefs = Names.labeledReferences remainingNames - -- remove the other targets for deletion from the remaining terms - let remainingRefsWithoutOtherTargets :: Set LabeledDependency - remainingRefsWithoutOtherTargets = Set.difference remainingRefs otherDesiredDeletions - -- deleting and not left over - let extinct :: Set LabeledDependency - extinct = refsToDelete `Set.difference` remainingRefs - let accumulateDependents :: LabeledDependency -> Sqlite.Transaction (Map LabeledDependency (Set LabeledDependency)) - accumulateDependents ld = - let ref = LD.fold id Referent.toReference ld - in Map.singleton ld . Set.map LD.termRef <$> Codebase.dependents Queries.ExcludeOwnComponent ref - -- All dependents of extinct, including terms which might themselves be in the process of being deleted. - allDependentsOfExtinct :: Map LabeledDependency (Set LabeledDependency) <- - Map.unionsWith (<>) <$> for (Set.toList extinct) accumulateDependents - - -- Filtered to only include dependencies which are not being deleted, but depend one which - -- is going extinct. - let extinctToEndangered :: Map LabeledDependency (NESet LabeledDependency) - extinctToEndangered = - allDependentsOfExtinct & Map.mapMaybe \endangeredDeps -> - let remainingEndangered = endangeredDeps `Set.intersection` remainingRefsWithoutOtherTargets - in NESet.nonEmptySet remainingEndangered - pure extinctToEndangered - displayI :: OutputLocation -> HQ.HashQualified Name -> @@ -1728,14 +1440,14 @@ displayI outputLoc hq = do (names, pped) <- if useRoot then do - root <- Cli.getRootBranch + root <- Cli.getCurrentProjectRoot let root0 = Branch.head root let names = Names.makeAbsolute $ Branch.toNames root0 - pped <- Cli.prettyPrintEnvDeclFromNames names + let pped = PPED.makePPED (PPE.hqNamer 10 names) (suffixify names) pure (names, pped) else do names <- Cli.currentNames - pped <- Cli.prettyPrintEnvDeclFromNames names + let pped = PPED.makePPED (PPE.hqNamer 10 names) (suffixify names) pure (names, pped) let suffixifiedPPE = PPE.suffixifiedPPE pped let bias = maybeToList $ HQ.toName hq @@ -1750,17 +1462,26 @@ displayI outputLoc hq = do then SearchTermsNotFound [hq] else TermAmbiguous suffixifiedPPE hq results let tm = Term.fromReferent External ref - tm <- RuntimeUtils.evalUnisonTerm True (PPE.biasTo bias $ suffixifiedPPE) True tm + tm <- RuntimeUtils.evalUnisonTerm Sandboxed (PPE.biasTo bias $ suffixifiedPPE) True tm doDisplay outputLoc names (Term.unannotate tm) Just (toDisplay, unisonFile) -> do let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile unisonFile names - filePPED <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile + let filePPED = PPED.makePPED (PPE.hqNamer 10 namesWithDefinitionsFromFile) (suffixify namesWithDefinitionsFromFile) + let suffixifiedFilePPE = PPE.biasTo bias $ PPE.suffixifiedPPE filePPED - (_, watches) <- evalUnisonFile Sandboxed suffixifiedFilePPE unisonFile [] + (_, watches) <- + evalUnisonFile Sandboxed suffixifiedFilePPE unisonFile [] & onLeftM \err -> + Cli.returnEarly (Output.EvaluationFailure err) (_, _, _, _, tm, _) <- Map.lookup toDisplay watches & onNothing (error $ "Evaluation dropped a watch expression: " <> Text.unpack (HQ.toText hq)) let ns = UF.addNamesFromTypeCheckedUnisonFile unisonFile names doDisplay outputLoc ns tm + where + suffixify = + case outputLoc of + ConsoleLocation -> PPE.suffixifyByHash + FileLocation _ _ -> PPE.suffixifyByHashName + LatestFileLocation _ -> PPE.suffixifyByHashName docsI :: Name -> Cli () docsI src = do @@ -1771,7 +1492,7 @@ docsI src = do (codebaseByName) Lastly check for `foo.doc` in the codebase and if found do `display foo.doc` -} dotDoc :: HQ.HashQualified Name - dotDoc = Name.convert . Name.joinDot src $ Name.fromSegment NameSegment.docSegment + dotDoc = HQ.NameOnly . Name.joinDot src $ Name.fromSegment NameSegment.docSegment findInScratchfileByName :: Cli () findInScratchfileByName = do @@ -1783,27 +1504,6 @@ docsI src = do displayI ConsoleLocation (Names.longestTermName 10 (Set.findMin s) namesInFile) _ -> displayI ConsoleLocation dotDoc -loadDisplayInfo :: - Codebase m Symbol Ann -> - Set Reference -> - Sqlite.Transaction - ( [(Reference, Maybe (Type Symbol Ann))], - [(Reference, DisplayObject () (DD.Decl Symbol Ann))] - ) -loadDisplayInfo codebase refs = do - termRefs <- filterM (Codebase.isTerm codebase) (toList refs) - typeRefs <- filterM (Codebase.isType codebase) (toList refs) - terms <- forM termRefs $ \r -> (r,) <$> Codebase.getTypeOfTerm codebase r - types <- forM typeRefs $ \r -> (r,) <$> loadTypeDisplayObject codebase r - pure (terms, types) - -loadTypeDisplayObject :: Codebase m Symbol Ann -> Reference -> Sqlite.Transaction (DisplayObject () (DD.Decl Symbol Ann)) -loadTypeDisplayObject codebase = \case - Reference.Builtin _ -> pure (BuiltinObject ()) - Reference.DerivedId id -> - maybe (MissingObject $ Reference.idToShortHash id) UserObject - <$> Codebase.getTypeDeclaration codebase id - lexedSource :: Text -> Text -> Cli (Text, [L.Token L.Lexeme]) lexedSource name src = do let tokens = L.lexer (Text.unpack name) (Text.unpack src) @@ -1824,13 +1524,15 @@ parseType input src = do Parser.ParsingEnv { uniqueNames = mempty, uniqueTypeGuid = \_ -> pure Nothing, - names + names, + maybeNamespace = Nothing, + localNamespacePrefixedTypesAndConstructors = mempty } typ <- Parsers.parseType (Text.unpack (fst lexed)) parsingEnv & onLeftM \err -> Cli.returnEarly (TypeParseError src err) - Type.bindNames Name.unsafeParseVar mempty names (Type.generalizeLowercase mempty typ) & onLeft \errs -> + Type.bindNames Name.unsafeParseVar Name.toVar Set.empty names (Type.generalizeLowercase mempty typ) & onLeft \errs -> Cli.returnEarly (ParseResolutionFailures src (toList errs)) -- Adds a watch expression of the given name to the file, if @@ -1861,14 +1563,10 @@ addWatch watchName (Just uf) = do ) _ -> addWatch watchName Nothing -looseCodeOrProjectToPath :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Path' -looseCodeOrProjectToPath = \case - Left pth -> pth - Right (ProjectAndBranch prj br) -> - Path.absoluteToPath' - ( ProjectUtils.projectBranchPath - ( ProjectAndBranch - (prj ^. #projectId) - (br ^. #branchId) - ) - ) +resolveBranchId2 :: BranchId2 -> Cli (Branch IO) +resolveBranchId2 = \case + Left sch -> Cli.resolveShortCausalHash sch + Right brp -> do + pp <- ProjectUtils.resolveBranchRelativePath brp + Cli.Env {codebase} <- ask + fromMaybe Branch.empty <$> liftIO (Codebase.getBranchAtProjectPath codebase pp) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs index e9d396cb29..bcfc05f2db 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs @@ -12,20 +12,20 @@ import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.NamesUtils qualified as Cli -import Unison.Cli.PrettyPrintUtils qualified as Cli import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.HandleInput.Update (doSlurpAdds) import Unison.Codebase.Editor.Input (Input) import Unison.Codebase.Editor.Output (Output (NoLastRunResult, SaveTermNameConflict, SlurpOutput)) import Unison.Codebase.Editor.Slurp qualified as Slurp import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult -import Unison.Codebase.Path qualified as Path import Unison.CommandLine.InputPattern qualified as InputPattern import Unison.CommandLine.InputPatterns qualified as InputPatterns import Unison.Name (Name) import Unison.Parser.Ann (Ann (External)) import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPE +import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Symbol (Symbol) import Unison.Syntax.Name qualified as Name import Unison.UnisonFile (TypecheckedUnisonFile) @@ -37,16 +37,16 @@ handleAddRun input resultName = do let resultVar = Name.toVar resultName uf <- addSavedTermToUnisonFile resultName Cli.Env {codebase} <- ask - currentPath <- Cli.getCurrentPath currentNames <- Cli.currentNames let sr = Slurp.slurpFile uf (Set.singleton resultVar) Slurp.AddOp currentNames let adds = SlurpResult.adds sr - Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf) Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf + let description = (Text.pack (InputPattern.patternName InputPatterns.saveExecuteResult) <> " " <> Name.toText resultName) + pp <- Cli.getCurrentProjectPath + Cli.stepAt description (pp, doSlurpAdds adds uf) let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile uf currentNames - pped <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile + let pped = PPED.makePPED (PPE.hqNamer 10 namesWithDefinitionsFromFile) (PPE.suffixifyByHash namesWithDefinitionsFromFile) let suffixifiedPPE = PPE.suffixifiedPPE pped - Cli.syncRoot (Text.pack (InputPattern.patternName InputPatterns.saveExecuteResult) <> " " <> Name.toText resultName) Cli.respond $ SlurpOutput input suffixifiedPPE sr addSavedTermToUnisonFile :: Name -> Cli (TypecheckedUnisonFile Symbol Ann) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 057d6a0c26..6df6178d5a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -1,44 +1,42 @@ -- | @branch@ input handler module Unison.Codebase.Editor.HandleInput.Branch - ( handleBranch, - CreateFrom (..), - doCreateBranch, - doCreateBranch', + ( CreateFrom (..), + handleBranch, + createBranch, ) where -import Data.These (These (..)) +import Control.Monad.Reader import Data.UUID.V4 qualified as UUID import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.Project qualified as Sqlite +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite +import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli -import Unison.Cli.MonadUtils qualified as Cli (getBranchAt, getCurrentPath, updateAt) +import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils +import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch) -import Unison.Codebase.Branch qualified as Branch (empty) +import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName) import Unison.Sqlite qualified as Sqlite data CreateFrom - = CreateFrom'Branch (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) - | CreateFrom'LooseCode Path.Absolute + = CreateFrom'NamespaceWithParent Sqlite.ProjectBranch (Branch IO) + | CreateFrom'ParentBranch Sqlite.ProjectBranch + | CreateFrom'Namespace (Branch IO) | CreateFrom'Nothingness -- | Create a new project branch from an existing project branch or namespace. handleBranch :: Input.BranchSourceI -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () -handleBranch sourceI projectAndBranchNames0 = do - projectAndBranchNames@(ProjectAndBranch projectName newBranchName) <- - case projectAndBranchNames0 of - ProjectAndBranch Nothing branchName -> ProjectUtils.hydrateNames (That branchName) - ProjectAndBranch (Just projectName) branchName -> pure (ProjectAndBranch projectName branchName) - +handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newBranchName) = do -- You can only create release branches with `branch.clone` -- -- We do allow creating draft release branches with `branch`, but you'll get different output if you use @@ -50,93 +48,81 @@ handleBranch sourceI projectAndBranchNames0 = do Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver) ProjectBranchNameKind'NothingSpecial -> pure () + currentProjectName <- Cli.getCurrentProjectPath <&> view (#project . #name) + let projectName = (fromMaybe currentProjectName mayProjectName) + destProject <- do + Cli.runTransactionWithRollback + \rollback -> do + Queries.loadProjectByName projectName & onNothingM do + -- We can't make the *first* branch of a project with `branch`; the project has to already exist. + rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName newBranchName)) + -- Compute what we should create the branch from. - createFrom <- + maySrcProjectAndBranch <- case sourceI of - Input.BranchSourceI'CurrentContext -> - ProjectUtils.getCurrentProjectBranch >>= \case - Nothing -> CreateFrom'LooseCode <$> Cli.getCurrentPath - Just (currentBranch, _restPath) -> pure (CreateFrom'Branch currentBranch) - Input.BranchSourceI'Empty -> pure CreateFrom'Nothingness - Input.BranchSourceI'LooseCodeOrProject (This sourcePath) -> do - currentPath <- Cli.getCurrentPath - pure (CreateFrom'LooseCode (Path.resolve currentPath sourcePath)) - Input.BranchSourceI'LooseCodeOrProject (That sourceBranch) -> - fmap CreateFrom'Branch do - ProjectUtils.expectProjectAndBranchByTheseNames - case sourceBranch of - ProjectAndBranch Nothing b -> That b - ProjectAndBranch (Just p) b -> These p b - -- For now, treat ambiguous parses as branch names, as this seems (far) more common than trying to create a - -- branch from a relative one-segment namespace. - -- - -- Future work: be smarter; for example, if there is such a relative namespace, but no such branch, maybe they - -- really meant create a branch from that namespace. - Input.BranchSourceI'LooseCodeOrProject (These _sourcePath sourceBranch) -> - fmap CreateFrom'Branch do - ProjectUtils.expectProjectAndBranchByTheseNames - case sourceBranch of - ProjectAndBranch Nothing b -> That b - ProjectAndBranch (Just p) b -> These p b - - project <- - Cli.runTransactionWithRollback \rollback -> do - Queries.loadProjectByName projectName & onNothingM do - -- We can't make the *first* branch of a project with `branch`; the project has to already exist. - rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) + Input.BranchSourceI'CurrentContext -> Just . view PP.projectAndBranch_ <$> Cli.getCurrentProjectPath + Input.BranchSourceI'Empty -> pure Nothing + Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do + pp <- Cli.getCurrentProjectPath + Just <$> ProjectUtils.resolveProjectBranchInProject (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just) - _ <- doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames) + case maySrcProjectAndBranch of + Just srcProjectAndBranch -> do + let description = "Branch created from " <> into @Text (srcProjectAndBranch & bimap (view #name) (view #name)) + void $ createBranch description (CreateFrom'ParentBranch (view #branch srcProjectAndBranch)) destProject (pure newBranchName) + Nothing -> do + let description = "Empty branch created" + void $ createBranch description CreateFrom'Nothingness destProject (pure newBranchName) Cli.respond $ Output.CreatedProjectBranch - ( case createFrom of - CreateFrom'Branch sourceBranch -> - if sourceBranch ^. #project . #projectId == project ^. #projectId + ( case maySrcProjectAndBranch of + Just sourceBranch -> + if sourceBranch ^. #project . #projectId == destProject ^. #projectId then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name) else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch - CreateFrom'LooseCode path -> Output.CreatedProjectBranchFrom'LooseCode path - CreateFrom'Nothingness -> Output.CreatedProjectBranchFrom'Nothingness + Nothing -> Output.CreatedProjectBranchFrom'Nothingness ) - projectAndBranchNames + (projectAndBranchNames & #project .~ projectName) --- | @doCreateBranch createFrom project branch description@: +-- | @createBranch description createFrom project getNewBranchName@: -- --- 1. Creates a new branch row for @branch@ in project @project@ (failing if @branch@ already exists in @project@) --- 2. Puts the branch contents from @createFrom@ in the root namespace., using @description@ for the reflog. --- 3. cds to the new branch in the root namespace. +-- 1. Creates a new branch row in @project@ at the name from @getNewBranchName@ (failing if branch already exists in @project@). +-- 2. Switches to the new branch. -- -- This bit of functionality is factored out from the main 'handleBranch' handler because it is also called by the -- @release.draft@ command, which essentially just creates a branch, but with some different output for the user. -- --- Returns the branch id of the newly-created branch. -doCreateBranch :: CreateFrom -> Sqlite.Project -> ProjectBranchName -> Text -> Cli ProjectBranchId -doCreateBranch createFrom project newBranchName description = do - sourceNamespaceObject <- - case createFrom of - CreateFrom'Branch (ProjectAndBranch _ sourceBranch) -> do - let sourceProjectId = sourceBranch ^. #projectId - let sourceBranchId = sourceBranch ^. #branchId - Cli.getBranchAt (ProjectUtils.projectBranchPath (ProjectAndBranch sourceProjectId sourceBranchId)) - CreateFrom'LooseCode sourcePath -> Cli.getBranchAt sourcePath - CreateFrom'Nothingness -> pure Branch.empty - let parentBranchId = - case createFrom of - CreateFrom'Branch (ProjectAndBranch _ sourceBranch) - | sourceBranch.projectId == project.projectId -> Just sourceBranch.branchId - _ -> Nothing - (newBranchId, _) <- doCreateBranch' sourceNamespaceObject parentBranchId project (pure newBranchName) description - pure newBranchId - -doCreateBranch' :: - Branch IO -> - Maybe ProjectBranchId -> +-- Returns the branch id and name of the newly-created branch. +createBranch :: + Text -> + CreateFrom -> Sqlite.Project -> Sqlite.Transaction ProjectBranchName -> - Text -> Cli (ProjectBranchId, ProjectBranchName) -doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName description = do +createBranch description createFrom project getNewBranchName = do let projectId = project ^. #projectId - (newBranchId, newBranchName) <- + Cli.Env {codebase} <- ask + (mayParentBranchId, newBranchCausalHashId) <- case createFrom of + CreateFrom'ParentBranch parentBranch -> Cli.runTransaction do + newBranchCausalHashId <- Q.expectProjectBranchHead parentBranch.projectId parentBranch.branchId + let parentBranchId = if parentBranch.projectId == projectId then Just parentBranch.branchId else Nothing + pure (parentBranchId, newBranchCausalHashId) + CreateFrom'Nothingness -> Cli.runTransaction do + (_, causalHashId) <- Codebase.emptyCausalHash + pure (Nothing, causalHashId) + CreateFrom'NamespaceWithParent parentBranch namespace -> do + liftIO $ Codebase.putBranch codebase namespace + Cli.runTransaction $ do + newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash namespace) + let parentBranchId = if parentBranch.projectId == projectId then Just parentBranch.branchId else Nothing + pure (parentBranchId, newBranchCausalHashId) + CreateFrom'Namespace branch -> do + liftIO $ Codebase.putBranch codebase branch + Cli.runTransaction $ do + newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash branch) + pure (Nothing, newBranchCausalHashId) + (newBranchName, newBranchId) <- Cli.runTransactionWithRollback \rollback -> do newBranchName <- getNewBranchName Queries.projectBranchExistsByName projectId newBranchName >>= \case @@ -146,16 +132,15 @@ doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName de -- `bar`, so the fork will succeed. newBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom) Queries.insertProjectBranch + description + newBranchCausalHashId Sqlite.ProjectBranch { projectId, branchId = newBranchId, name = newBranchName, - parentBranchId = parentBranchId + parentBranchId = mayParentBranchId } - Queries.setMostRecentBranch projectId newBranchId - pure (newBranchId, newBranchName) + pure (newBranchName, newBranchId) - let newBranchPath = ProjectUtils.projectBranchPath (ProjectAndBranch projectId newBranchId) - _ <- Cli.updateAt description newBranchPath (const sourceNamespaceObject) - Cli.cd newBranchPath + Cli.switchProject (ProjectAndBranch projectId newBranchId) pure (newBranchId, newBranchName) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs index cc73936683..fdb5bdf6c8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs @@ -7,14 +7,15 @@ where import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli -import Unison.Cli.ProjectUtils qualified as ProjectUtils +import Unison.Cli.MonadUtils qualified as Cli import Unison.Codebase.Editor.Output qualified as Output +import Unison.Codebase.ProjectPath qualified as PP import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), classifyProjectBranchName) handleBranchRename :: ProjectBranchName -> Cli () handleBranchRename newBranchName = do - (ProjectAndBranch project branch, _path) <- ProjectUtils.expectCurrentProjectBranch + PP.ProjectPath project branch _path <- Cli.getCurrentProjectPath case classifyProjectBranchName newBranchName of ProjectBranchNameKind'Contributor {} -> pure () diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branches.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branches.hs index ba7bf5c885..99381ea7c6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branches.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branches.hs @@ -10,14 +10,14 @@ import Network.URI (URI) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli -import Unison.Cli.ProjectUtils qualified as ProjectUtils +import Unison.Cli.MonadUtils qualified as Cli import Unison.Codebase.Editor.Output qualified as Output import Unison.Prelude -import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) +import Unison.Project (ProjectBranchName, ProjectName) handleBranches :: Maybe ProjectName -> Cli () handleBranches maybeProjectName = do - maybeCurrentProjectIds <- ProjectUtils.getCurrentProjectIds + pp <- Cli.getCurrentProjectPath (project, branches) <- Cli.runTransactionWithRollback \rollback -> do project <- @@ -26,8 +26,7 @@ handleBranches maybeProjectName = do Queries.loadProjectByName projectName & onNothingM do rollback (Output.LocalProjectDoesntExist projectName) Nothing -> do - ProjectAndBranch projectId _ <- maybeCurrentProjectIds & onNothing (rollback Output.NotOnProjectBranch) - Queries.expectProject projectId + pure (pp ^. #project) branches <- Queries.loadAllProjectBranchInfo (project ^. #projectId) pure (project, branches) Cli.respondNumbered (Output.ListBranches (project ^. #name) (f branches)) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitMerge.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitMerge.hs index 1c9061e5d1..62c46b2b5d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitMerge.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitMerge.hs @@ -5,13 +5,14 @@ module Unison.Codebase.Editor.HandleInput.CommitMerge where import U.Codebase.Sqlite.Project qualified +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge -import Unison.Codebase.Editor.HandleInput.ProjectSwitch qualified as ProjectSwitch import Unison.Codebase.Editor.Output qualified as Output import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Prelude @@ -21,29 +22,26 @@ import Unison.Project (ProjectAndBranch (..)) handleCommitMerge :: Cli () handleCommitMerge = do - (mergeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch + mergeProjectAndBranch <- Cli.getCurrentProjectAndBranch - -- Assert that this is a "merge" branch and get its parent, which is the branch we were on when we ran `merge`. + -- Assert that this is a "merge" branch, get its parent (which is the branch we were on when we ran `merge`), + -- and switch to the parent. parentBranchId <- ProjectUtils.getMergeBranchParent mergeProjectAndBranch.branch & onNothing (Cli.returnEarly Output.NoMergeInProgress) + parentBranch <- Cli.runTransaction do - Queries.expectProjectBranch mergeProjectAndBranch.project.projectId parentBranchId - - let parentProjectAndBranch = - ProjectAndBranch mergeProjectAndBranch.project parentBranch - - -- Switch to the parent - - ProjectSwitch.switchToProjectBranch (ProjectUtils.justTheIds parentProjectAndBranch) + parentBranch <- Queries.expectProjectBranch mergeProjectAndBranch.project.projectId parentBranchId + pure parentBranch + Cli.switchProject (ProjectAndBranch parentBranch.projectId parentBranch.branchId) -- Merge the merge branch into the parent Merge.doMergeLocalBranch TwoWay - { alice = parentProjectAndBranch, + { alice = ProjectAndBranch mergeProjectAndBranch.project parentBranch, bob = mergeProjectAndBranch } diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs index 3a85157e55..93d1188830 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs @@ -5,13 +5,14 @@ module Unison.Codebase.Editor.HandleInput.CommitUpgrade where import U.Codebase.Sqlite.Project qualified +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge -import Unison.Codebase.Editor.HandleInput.ProjectSwitch qualified as ProjectSwitch import Unison.Codebase.Editor.Output qualified as Output import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Prelude @@ -21,29 +22,26 @@ import Unison.Project (ProjectAndBranch (..)) handleCommitUpgrade :: Cli () handleCommitUpgrade = do - (upgradeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch + upgradeProjectAndBranch <- Cli.getCurrentProjectAndBranch - -- Assert that this is an "upgrade" branch and get its parent, which is the branch we were on when we ran `upgrade`. + -- Assert that this is an "upgrade" branch, get its parent (which is the branch we were on when we ran `upgrade`), + -- and switch to the parent. parentBranchId <- ProjectUtils.getUpgradeBranchParent upgradeProjectAndBranch.branch & onNothing (Cli.returnEarly Output.NoUpgradeInProgress) + parentBranch <- Cli.runTransaction do - Queries.expectProjectBranch upgradeProjectAndBranch.project.projectId parentBranchId - - let parentProjectAndBranch = - ProjectAndBranch upgradeProjectAndBranch.project parentBranch - - -- Switch to the parent - - ProjectSwitch.switchToProjectBranch (ProjectUtils.justTheIds parentProjectAndBranch) + parentBranch <- Queries.expectProjectBranch upgradeProjectAndBranch.project.projectId parentBranchId + pure parentBranch + Cli.switchProject (ProjectAndBranch parentBranch.projectId parentBranch.branchId) -- Merge the upgrade branch into the parent Merge.doMergeLocalBranch TwoWay - { alice = parentProjectAndBranch, + { alice = ProjectAndBranch upgradeProjectAndBranch.project parentBranch, bob = upgradeProjectAndBranch } diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugSynhashTerm.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugSynhashTerm.hs new file mode 100644 index 0000000000..42944c2dac --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugSynhashTerm.hs @@ -0,0 +1,66 @@ +-- | @debug.synhash.term@ input handler. +module Unison.Codebase.Editor.HandleInput.DebugSynhashTerm + ( handleDebugSynhashTerm, + ) +where + +import Control.Monad.Reader (ask) +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import U.Util.Base32Hex qualified as Base32Hex +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Cli.Pretty (prettyBase32Hex, prettyHash) +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch.Names qualified as Branch +import Unison.Codebase.Editor.Output (Output (..)) +import Unison.Hash (Hash) +import Unison.Hashable qualified as Hashable +import Unison.Merge.Synhash (hashBuiltinTermTokens, hashDerivedTermTokens) +import Unison.Name (Name) +import Unison.Names qualified as Names +import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..)) +import Unison.PrettyPrintEnvDecl.Names qualified as PPED +import Unison.Reference qualified as Reference +import Unison.Syntax.Name qualified as Name +import Unison.Util.Pretty (ColorText, Pretty) +import Unison.Util.Pretty qualified as Pretty + +handleDebugSynhashTerm :: Name -> Cli () +handleDebugSynhashTerm name = do + namespace <- Cli.getCurrentBranch0 + let names = Branch.toNames namespace + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) + + for_ (Names.refTermsNamed names name) \ref -> do + maybeTokens <- + case ref of + Reference.Builtin builtin -> pure (Just (hashBuiltinTermTokens builtin)) + Reference.DerivedId refId -> do + env <- ask + Cli.runTransaction (Codebase.getTerm env.codebase refId) <&> \case + Nothing -> Nothing + Just term -> Just (hashDerivedTermTokens pped.unsuffixifiedPPE term) + whenJust maybeTokens \tokens -> do + let filename = Name.toText name <> "-" <> Reference.toText ref <> "-synhash-tokens.txt" + let renderedTokens = + tokens + & map prettyToken + & Pretty.lines + & Pretty.toAnsiUnbroken + & Text.pack + liftIO (Text.writeFile (Text.unpack filename) renderedTokens) + Cli.respond (Output'DebugSynhashTerm ref (Hashable.accumulate tokens) filename) + +prettyToken :: Hashable.Token Hash -> Pretty ColorText +prettyToken = \case + Hashable.Bytes bytes -> "0x" <> prettyBase32Hex (Base32Hex.fromByteString bytes) + Hashable.Double n -> Pretty.string (show n) + Hashable.Hashed h -> prettyHash h + Hashable.Int n -> (if n >= 0 then "+" else mempty) <> Pretty.string (show n) + Hashable.Nat n -> Pretty.string (show n) + Hashable.Tag n -> "@" <> Pretty.string (show n) + Hashable.Text s -> Pretty.string (show s) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs index 72df1028fd..ccbcfcb267 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs @@ -5,19 +5,26 @@ module Unison.Codebase.Editor.HandleInput.DeleteBranch ) where -import Data.Map.Strict qualified as Map -import Data.These (These (..)) +import Control.Lens +import Data.List qualified as List +import U.Codebase.Sqlite.DbId +import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.Project qualified as Sqlite +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils -import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Path qualified as Path +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Editor.HandleInput.ProjectCreate +import Unison.Codebase.ProjectPath (ProjectPathG (..)) +import Unison.Codebase.SqliteCodebase.Operations qualified as Ops +import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.Prelude -import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) +import Unison.Project (ProjectAndBranch (..)) +import Unison.Sqlite qualified as Sqlite import Witch (unsafeFrom) -- | Delete a project branch. @@ -27,44 +34,64 @@ import Witch (unsafeFrom) -- project. handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleDeleteBranch projectAndBranchNamesToDelete = do - projectAndBranchToDelete <- - ProjectUtils.expectProjectAndBranchByTheseNames - case projectAndBranchNamesToDelete of - ProjectAndBranch Nothing branch -> That branch - ProjectAndBranch (Just project) branch -> These project branch - - maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch - - doDeleteProjectBranch projectAndBranchToDelete + ProjectPath currentProject currentBranch _ <- Cli.getCurrentProjectPath + projectAndBranchToDelete@(ProjectAndBranch projectOfBranchToDelete branchToDelete) <- ProjectUtils.resolveProjectBranchInProject currentProject (projectAndBranchNamesToDelete & #branch %~ Just) -- If the user is on the branch that they're deleting, we have to cd somewhere; try these in order: -- -- 1. cd to parent branch, if it exists -- 2. cd to "main", if it exists - -- 3. cd to loose code path `.` - whenJust maybeCurrentBranch \(currentProjectAndBranch, _restPath) -> - when (ProjectUtils.justTheIds currentProjectAndBranch == ProjectUtils.justTheIds projectAndBranchToDelete) do - newPath <- - case projectAndBranchToDelete.branch.parentBranchId of - Nothing -> - let loadMain = - Queries.loadProjectBranchByName projectAndBranchToDelete.project.projectId (unsafeFrom @Text "main") - in Cli.runTransaction loadMain <&> \case - Nothing -> Path.Absolute Path.empty - Just mainBranch -> ProjectUtils.projectBranchPath (ProjectUtils.justTheIds' mainBranch) - Just parentBranchId -> - pure $ - ProjectUtils.projectBranchPath - (ProjectAndBranch projectAndBranchToDelete.project.projectId parentBranchId) - Cli.cd newPath + -- 3. Any other branch in the codebase + -- 4. Create a new branch in the current project + when (branchToDelete ^. #branchId == currentBranch ^. #branchId) do + mayNextLocation <- + Cli.runTransaction . runMaybeT $ + asum + [ parentBranch (branchToDelete ^. #projectId) (branchToDelete ^. #parentBranchId), + findMainBranchInProjectExcept (currentProject ^. #projectId) (branchToDelete ^. #branchId), + -- Any branch in the codebase except the one we're deleting + findAnyBranchInProjectExcept (branchToDelete ^. #projectId) (branchToDelete ^. #branchId), + findAnyBranchInCodebaseExcept (branchToDelete ^. #projectId) (branchToDelete ^. #branchId), + createNewBranchInProjectExcept projectOfBranchToDelete.name branchToDelete.name + ] + + nextLoc <- mayNextLocation `whenNothing` projectCreate False Nothing + Cli.switchProject nextLoc + doDeleteProjectBranch projectAndBranchToDelete + where + parentBranch :: ProjectId -> Maybe ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + parentBranch projectId mayParentBranchId = do + parentBranchId <- hoistMaybe mayParentBranchId + pure (ProjectAndBranch projectId parentBranchId) + + findMainBranchInProjectExcept :: ProjectId -> ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + findMainBranchInProjectExcept projectId exceptBranchId = do + branch <- MaybeT $ Queries.loadProjectBranchByName projectId (unsafeFrom @Text "main") + guard (branch ^. #branchId /= exceptBranchId) + pure (ProjectAndBranch projectId (branch ^. #branchId)) + + findAnyBranchInProjectExcept :: ProjectId -> ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + findAnyBranchInProjectExcept projectId exceptBranchId = do + (someBranchId, _) <- MaybeT . fmap (List.find (\(branchId, _) -> branchId /= exceptBranchId)) $ Queries.loadAllProjectBranchesBeginningWith projectId Nothing + pure (ProjectAndBranch projectId someBranchId) + + findAnyBranchInCodebaseExcept :: ProjectId -> ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + findAnyBranchInCodebaseExcept exceptProjectId exceptBranchId = do + (_, pbIds) <- MaybeT . fmap (List.find (\(_, ids) -> ids /= ProjectAndBranch exceptProjectId exceptBranchId)) $ Queries.loadAllProjectBranchNamePairs + pure pbIds + + createNewBranchInProjectExcept :: ProjectName -> ProjectBranchName -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + createNewBranchInProjectExcept projectName (UnsafeProjectBranchName "main") = lift $ do + (_, emptyCausalHashId) <- Codebase.emptyCausalHash + Ops.insertProjectAndBranch projectName (UnsafeProjectBranchName "main2") emptyCausalHashId + <&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId + createNewBranchInProjectExcept projectName _ = lift $ do + (_, emptyCausalHashId) <- Codebase.emptyCausalHash + Ops.insertProjectAndBranch projectName (UnsafeProjectBranchName "main") emptyCausalHashId + <&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId -- | Delete a project branch and record an entry in the reflog. -doDeleteProjectBranch :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Cli () +doDeleteProjectBranch :: (HasCallStack) => ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Cli () doDeleteProjectBranch projectAndBranch = do Cli.runTransaction do Queries.deleteProjectBranch projectAndBranch.project.projectId projectAndBranch.branch.branchId - Cli.stepAt - ("delete.branch " <> into @Text (ProjectUtils.justTheNames projectAndBranch)) - ( Path.unabsolute (ProjectUtils.projectBranchesPath projectAndBranch.project.projectId), - over Branch.children (Map.delete (ProjectUtils.projectBranchSegment projectAndBranch.branch.branchId)) - ) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteNamespace.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteNamespace.hs new file mode 100644 index 0000000000..14281adc33 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteNamespace.hs @@ -0,0 +1,134 @@ +module Unison.Codebase.Editor.HandleInput.DeleteNamespace + ( handleDeleteNamespace, + getEndangeredDependents, + ) +where + +import Control.Lens hiding (from) +import Control.Lens qualified as Lens +import Control.Monad.State qualified as State +import Data.Map qualified as Map +import Data.Set qualified as Set +import Data.Set.NonEmpty (NESet) +import Data.Set.NonEmpty qualified as NESet +import U.Codebase.Sqlite.Queries qualified as Queries +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Branch.Names qualified as Branch +import Unison.Codebase.Editor.Input +import Unison.Codebase.Editor.Output +import Unison.Codebase.Path (Path) +import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as ProjectPath +import Unison.LabeledDependency (LabeledDependency) +import Unison.LabeledDependency qualified as LD +import Unison.NameSegment qualified as NameSegment +import Unison.Names (Names) +import Unison.Names qualified as Names +import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE +import Unison.PrettyPrintEnvDecl.Names qualified as PPED +import Unison.Referent qualified as Referent +import Unison.Sqlite qualified as Sqlite + +handleDeleteNamespace :: Input -> Insistence -> Maybe (Path, NameSegment.NameSegment) -> Cli () +handleDeleteNamespace input insistence = \case + Nothing -> do + loopState <- State.get + if loopState.lastInput == Just input || insistence == Force + then do + pp <- Cli.getCurrentProjectPath + _ <- Cli.updateAt (commandName <> " .") pp (const Branch.empty) + Cli.respond DeletedEverything + else Cli.respond DeleteEverythingConfirmation + Just p@(parentPath, childName) -> do + branch <- Cli.expectBranchAtPath (Path.unsplit p) + let toDelete = + Names.prefix0 + (Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p) + (Branch.toNames (Branch.head branch)) + afterDelete <- do + currentBranch <- Cli.getCurrentProjectRoot0 + let names = Branch.toNames currentBranch + namesSansLib = Branch.toNames (Branch.deleteLibdeps currentBranch) + endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names namesSansLib) + case (null endangerments, insistence) of + (True, _) -> pure (Cli.respond Success) + (False, Force) -> do + let ppeDecl = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) + pure do + Cli.respond Success + Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments + (False, Try) -> do + let ppeDecl = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) + Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments + Cli.returnEarlyWithoutOutput + parentPathAbs <- Cli.resolvePath parentPath + let description = commandName <> " " <> into @Text (parentPathAbs & ProjectPath.absPath_ %~ (`Lens.snoc` childName)) + -- We have to modify the parent in order to also wipe out the history at the + -- child. + Cli.updateAt description parentPathAbs (Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty) + afterDelete + where + commandName :: Text + commandName = + case insistence of + Try -> "delete.namespace" + Force -> "delete.namespace.force" + +-- How I might do it (is this any better than the current algorithm?) +-- +-- 1. Get all direct dependents of the deleted things in the current namespace. +-- 2. For each direct dependent, check a Names built from the deleted namespace – is it there? If not it's the last +-- name. + +-- | Goal: When deleting, we might be removing the last name of a given definition (i.e. the +-- definition is going "extinct"). In this case we may wish to take some action or warn the +-- user about these "endangered" definitions which would now contain unnamed references. +-- The argument `otherDesiredDeletions` is included in this function because the user might want to +-- delete a term and all its dependencies in one command, so we give this function access to +-- the full set of entities that the user wishes to delete. +getEndangeredDependents :: + -- | Prospective target for deletion + Names -> + -- | All entities we want to delete (including the target) + Set LabeledDependency -> + -- | Names from the current branch + Names -> + -- | Names from the current branch, sans `lib` + Names -> + -- | map from references going extinct to the set of endangered dependents + Sqlite.Transaction (Map LabeledDependency (NESet LabeledDependency)) +getEndangeredDependents targetToDelete otherDesiredDeletions rootNames rootNamesSansLib = do + -- deleting and not left over + let extinct :: Set LabeledDependency + extinct = Names.labeledReferences targetToDelete `Set.difference` refsAfterDeletingTarget rootNames + + let accumulateDependents :: LabeledDependency -> Sqlite.Transaction (Map LabeledDependency (Set LabeledDependency)) + accumulateDependents ld = + let ref = LD.fold id Referent.toReference ld + in Map.singleton ld . Set.map LD.termRef <$> Codebase.dependents Queries.ExcludeOwnComponent ref + + -- All dependents of extinct, including terms which might themselves be in the process of being deleted. + allDependentsOfExtinct :: Map LabeledDependency (Set LabeledDependency) <- + Map.unionsWith (<>) <$> for (Set.toList extinct) accumulateDependents + + -- Of all the dependents of things going extinct, we filter down to only those that are not themselves being deleted + -- too (per `otherDesiredDeletion`), and are also somewhere outside `lib`. This allows us to proceed with deleting + -- an entire dependency out of `lib` even if for some reason it contains the only source of names for some other + -- dependency. + let extinctToEndangered :: Map LabeledDependency (NESet LabeledDependency) + extinctToEndangered = + Map.mapMaybe + ( NESet.nonEmptySet + . Set.intersection (Set.difference (refsAfterDeletingTarget rootNamesSansLib) otherDesiredDeletions) + ) + allDependentsOfExtinct + pure extinctToEndangered + where + refsAfterDeletingTarget :: Names -> Set LabeledDependency + refsAfterDeletingTarget names = + Names.labeledReferences (names `Names.difference` targetToDelete) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteProject.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteProject.hs index 3ff51cf818..ee662c91ad 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteProject.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteProject.hs @@ -4,39 +4,53 @@ module Unison.Codebase.Editor.HandleInput.DeleteProject ) where -import Data.Function (on) +import Control.Lens +import Data.List qualified as List +import U.Codebase.Sqlite.DbId +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli -import Unison.Cli.ProjectUtils qualified as ProjectUtils -import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathG (..)) +import Unison.Codebase.SqliteCodebase.Operations qualified as Ops +import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.Prelude -import Unison.Project (ProjectAndBranch (..), ProjectName) +import Unison.Project (ProjectAndBranch (..)) +import Unison.Sqlite qualified as Sqlite -- | Delete a project handleDeleteProject :: ProjectName -> Cli () handleDeleteProject projectName = do - maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch + ProjectPath currentProject _ _ <- Cli.getCurrentProjectPath - deletedProject <- + projectToDelete <- Cli.runTransactionWithRollback \rollback -> do - project <- - Queries.loadProjectByName projectName & onNothingM do - rollback (Output.LocalProjectDoesntExist projectName) - Queries.deleteProject (project ^. #projectId) - pure project + Queries.loadProjectByName projectName & onNothingM do + rollback (Output.LocalProjectDoesntExist projectName) - let projectId = deletedProject ^. #projectId + when (projectToDelete.projectId == currentProject.projectId) do + nextLoc <- Cli.runTransaction $ findAnyBranchInCodebaseNotInProject (projectToDelete.projectId) `whenNothingM` createDummyProjectExcept projectToDelete.name + Cli.switchProject nextLoc - Cli.updateAt - ("delete.project " <> into @Text projectName) - (ProjectUtils.projectPath projectId) - (const Branch.empty) + Cli.runTransaction do + Queries.deleteProject (projectToDelete ^. #projectId) + where + findAnyBranchInCodebaseNotInProject :: ProjectId -> Sqlite.Transaction (Maybe (ProjectAndBranch ProjectId ProjectBranchId)) + findAnyBranchInCodebaseNotInProject exceptProjectId = do + Queries.loadAllProjectBranchNamePairs + <&> List.find (\(_, ProjectAndBranch projId _) -> projId /= exceptProjectId) + <&> fmap \(_, pbIds) -> pbIds - -- If the user is on the project that they're deleting, we cd to the root path - whenJust maybeCurrentBranch \(ProjectAndBranch currentProject _currentBranch, _restPath) -> - when (on (==) (view #projectId) deletedProject currentProject) do - Cli.cd (Path.Absolute Path.empty) + createDummyProjectExcept :: ProjectName -> Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + createDummyProjectExcept (UnsafeProjectName "scratch") = do + (_, emptyCausalHashId) <- Codebase.emptyCausalHash + Ops.insertProjectAndBranch (UnsafeProjectName "scratch2") (UnsafeProjectBranchName "main") emptyCausalHashId + <&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId + createDummyProjectExcept _ = do + (_, emptyCausalHashId) <- Codebase.emptyCausalHash + Ops.insertProjectAndBranch (UnsafeProjectName "scratch") (UnsafeProjectBranchName "main") emptyCausalHashId + <&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Dependents.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Dependents.hs new file mode 100644 index 0000000000..46e279c0a8 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Dependents.hs @@ -0,0 +1,68 @@ +module Unison.Codebase.Editor.HandleInput.Dependents + ( handleDependents, + ) +where + +import Data.Set qualified as Set +import U.Codebase.Sqlite.Queries qualified as Queries +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.NameResolutionUtils (resolveHQToLabeledDependencies) +import Unison.Cli.NamesUtils qualified as Cli +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Editor.Output +import Unison.Codebase.Editor.StructuredArgument qualified as SA +import Unison.ConstructorReference (GConstructorReference (..)) +import Unison.HashQualified qualified as HQ +import Unison.HashQualifiedPrime qualified as HQ' +import Unison.LabeledDependency qualified as LD +import Unison.Name (Name) +import Unison.Name qualified as Name +import Unison.NameSegment qualified as NameSegment +import Unison.Prelude +import Unison.PrettyPrintEnv qualified as PPE +import Unison.PrettyPrintEnv.Names qualified as PPE +import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo, empty) +import Unison.PrettyPrintEnvDecl.Names qualified as PPED +import Unison.Reference (Reference) +import Unison.Referent qualified as Referent +import Unison.Syntax.HashQualified qualified as HQ (toText) +import Unison.Util.List (nubOrdOn) + +handleDependents :: HQ.HashQualified Name -> Cli () +handleDependents hq = do + -- todo: add flag to handle transitive efficiently + lds <- resolveHQToLabeledDependencies hq + -- Use an unsuffixified PPE here, so we display full names (relative to the current path), + -- rather than the shortest possible unambiguous name. + names <- Cli.currentNames + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) + let fqppe = PPE.unsuffixifiedPPE pped + let ppe = PPE.suffixifiedPPE pped + when (null lds) do + Cli.returnEarly (LabeledReferenceNotFound hq) + + results <- for (toList lds) \ld -> do + -- The full set of dependent references, any number of which may not have names in the current namespace. + dependents <- + let tp = Codebase.dependents Queries.ExcludeOwnComponent + tm = \case + Referent.Ref r -> Codebase.dependents Queries.ExcludeOwnComponent r + Referent.Con (ConstructorReference r _cid) _ct -> + Codebase.dependents Queries.ExcludeOwnComponent r + in Cli.runTransaction (LD.fold tp tm ld) + let -- True is term names, False is type names + results :: [(Bool, HQ.HashQualified Name, Reference)] + results = do + r <- Set.toList dependents + Just (isTerm, hq) <- [(True,) <$> PPE.terms fqppe (Referent.Ref r), (False,) <$> PPE.types fqppe r] + fullName <- [HQ'.toName hq] + guard (not (Name.beginsWithSegment fullName NameSegment.libSegment)) + Just shortName <- pure $ PPE.terms ppe (Referent.Ref r) <|> PPE.types ppe r + pure (isTerm, HQ'.toHQ shortName, r) + pure results + let sort = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst) + let types = sort [(n, r) | (False, n, r) <- join results] + let terms = sort [(n, r) | (True, n, r) <- join results] + Cli.setNumberedArgs . map SA.HashQualified $ types <> terms + Cli.respond (ListDependents ppe lds types terms) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/EditDependents.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/EditDependents.hs new file mode 100644 index 0000000000..b2124c7628 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/EditDependents.hs @@ -0,0 +1,105 @@ +module Unison.Codebase.Editor.HandleInput.EditDependents + ( handleEditDependents, + ) +where + +import Control.Monad.Reader (ask) +import Data.Bifoldable (bifold) +import Data.Set qualified as Set +import U.Codebase.Sqlite.Operations qualified as Operations +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Cli.NameResolutionUtils (resolveHQName) +import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Branch.Names qualified as Branch +import Unison.Codebase.Editor.HandleInput.EditNamespace (getNamesForEdit) +import Unison.Codebase.Editor.HandleInput.ShowDefinition (showDefinitions) +import Unison.Codebase.Editor.Input (OutputLocation (..), RelativeToFold (..)) +import Unison.Codebase.Editor.Output qualified as Output +import Unison.ConstructorReference qualified as ConstructorReference +import Unison.HashQualified qualified as HQ +import Unison.Name (Name) +import Unison.Names (Names (..)) +import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE +import Unison.PrettyPrintEnvDecl.Names qualified as PPED +import Unison.Reference (TermReference, TypeReference) +import Unison.Reference qualified as Reference +import Unison.Referent qualified as Referent +import Unison.Util.Defns (Defns (..), DefnsF) +import Unison.Util.Defns qualified as Defns +import Unison.Util.Relation qualified as Relation + +handleEditDependents :: HQ.HashQualified Name -> Cli () +handleEditDependents name = do + -- Get all of the referents and type references this name refers to + refs0 <- resolveHQName name + + -- Since we don't track constructor dependents precisely, convert to just the term and type references + let refs :: DefnsF Set TermReference TypeReference + refs = + let f = \case + Referent.Con ref _ -> Defns.fromTypes (Set.singleton (ref ^. ConstructorReference.reference_)) + Referent.Ref ref -> Defns.fromTerms (Set.singleton ref) + in Defns Set.empty refs0.types <> foldMap f refs0.terms + + (ppe, types, terms) <- + Cli.withRespondRegion \respondRegion -> do + respondRegion (Output.Literal "Loading branch...") + + -- Load the current project namespace and throw away the libdeps + branch <- Cli.getCurrentBranch0 + let ppe = + let names = Branch.toNames branch + in PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHashName names) + + -- Throw away the libdeps + let branchWithoutLibdeps = Branch.deleteLibdeps branch + + -- Identify the local dependents of the input name + respondRegion (Output.Literal "Identifying dependents...") + dependents <- + Cli.runTransaction do + Operations.transitiveDependentsWithinScope + (Branch.deepTermReferenceIds branchWithoutLibdeps <> Branch.deepTypeReferenceIds branchWithoutLibdeps) + (bifold refs) + + let refsAndDependents = + Defns + { terms = + Set.unions + [ Set.mapMonotonic Referent.fromTermReference refs.terms, + Set.mapMonotonic Referent.fromTermReferenceId dependents.terms + ], + types = + Set.unions + [ refs.types, + Set.mapMonotonic Reference.fromId dependents.types + ] + } + + respondRegion (Output.Literal "Loading dependents...") + env <- ask + (types, terms) <- + Cli.runTransaction + ( getNamesForEdit + env.codebase + ppe + Names + { terms = + branchWithoutLibdeps + & Branch.deepTerms + & Relation.restrictDom refsAndDependents.terms + & Relation.swap, + types = + branchWithoutLibdeps + & Branch.deepTypes + & Relation.restrictDom refsAndDependents.types + & Relation.swap + } + ) + pure (ppe, types, terms) + + let misses = [] + showDefinitions (LatestFileLocation WithinFold) ppe terms types misses diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/EditNamespace.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/EditNamespace.hs index 6f75ba3a93..f7dec844cf 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/EditNamespace.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/EditNamespace.hs @@ -1,4 +1,8 @@ -module Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace) where +module Unison.Codebase.Editor.HandleInput.EditNamespace + ( handleEditNamespace, + getNamesForEdit, + ) +where import Control.Monad.Reader import Data.Foldable qualified as Foldable @@ -9,30 +13,43 @@ import U.Codebase.Reference (Reference' (..)) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli -import Unison.Cli.PrettyPrintUtils qualified as NamesUtils +import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Names qualified as Branch +import Unison.Codebase.Editor.DisplayObject (DisplayObject) import Unison.Codebase.Editor.DisplayObject qualified as DisplayObject import Unison.Codebase.Editor.HandleInput.ShowDefinition (showDefinitions) import Unison.Codebase.Editor.Input (OutputLocation (..)) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path +import Unison.DataDeclaration (Decl) import Unison.HashQualified qualified as HQ import Unison.Name (Name) +import Unison.Names (Names) import Unison.Names qualified as Names +import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..)) +import Unison.PrettyPrintEnvDecl.Names qualified as PPED +import Unison.Reference (TermReference, TypeReference) import Unison.Referent qualified as Referent import Unison.Server.Backend qualified as Backend +import Unison.Sqlite qualified as Sqlite +import Unison.Symbol (Symbol) import Unison.Syntax.DeclPrinter qualified as DeclPrinter +import Unison.Term (Term) +import Unison.Type (Type) import Unison.Util.Monoid (foldMapM) +import Unison.Util.Set qualified as Set handleEditNamespace :: OutputLocation -> [Path] -> Cli () handleEditNamespace outputLoc paths0 = do Cli.Env {codebase} <- ask currentBranch <- Cli.getCurrentBranch0 - ppe <- NamesUtils.currentPrettyPrintEnvDecl + let currentNames = Branch.toNames currentBranch + let ppe = PPED.makePPED (PPE.hqNamer 10 currentNames) (PPE.suffixifyByHashName currentNames) -- Adjust the requested list of paths slightly: if it's missing (i.e. `edit.namespace` without arguments), then behave -- as if the empty path (which there is no syntax for, heh) was supplied. @@ -47,53 +64,67 @@ handleEditNamespace outputLoc paths0 = do List.nubOrd paths & foldMap \path -> let branch = (if path == Path.empty then Branch.withoutLib else id) (Branch.getAt0 path currentBranch) names = Branch.toNames branch - in -- PPED.makePPED (PPE.hqNamer hashLen ns) (PPE.suffixifyByHash ns) - - case Path.toName path of + in case Path.toName path of Nothing -> names Just pathPrefix -> Names.prefix0 pathPrefix names + (types, terms) <- Cli.runTransaction (getNamesForEdit codebase ppe allNamesToEdit) + let misses = [] + showDefinitions outputLoc ppe terms types misses + +-- | Get names "for edit": gets types and terms out the codebase as display objects, but is careful not to get an +-- auto-generated record accessor term like `Foo.bar.set` if it's also getting the corresponding type `Foo`. This is +-- because these name are "for edit", i.e. going into a scratch file, where parsing the record type will generate +-- its accessors. +getNamesForEdit :: + Codebase m Symbol Ann -> + PrettyPrintEnvDecl -> + Names -> + Sqlite.Transaction + ( Map TypeReference (DisplayObject () (Decl Symbol Ann)), + Map TermReference (DisplayObject (Type Symbol Ann) (Term Symbol Ann)) + ) +getNamesForEdit codebase ppe allNamesToEdit = do let termRefs = Names.termReferences allNamesToEdit let typeRefs = Names.typeReferences allNamesToEdit - (types, terms) <- - Cli.runTransaction do - (types, accessorNames) <- - Foldable.foldlM - ( \(types, accessorNames) ref -> - case ref of - ReferenceBuiltin _ -> do - let !types1 = Map.insert ref (DisplayObject.BuiltinObject ()) types - pure (types1, accessorNames) - ReferenceDerived refId -> do - decl <- Codebase.unsafeGetTypeDeclaration codebase refId - let !types1 = Map.insert ref (DisplayObject.UserObject decl) types - let !accessorNames1 = - accessorNames <> case decl of - Left _effectDecl -> Set.empty - Right dataDecl -> - let declAccessorNames :: Name -> Set Name - declAccessorNames declName = - case DeclPrinter.getFieldAndAccessorNames - ppe.unsuffixifiedPPE - ref - (HQ.fromName declName) - dataDecl of - Nothing -> Set.empty - Just (_fieldNames, theAccessorNames) -> Set.fromList theAccessorNames - in foldMap declAccessorNames (Names.namesForReference allNamesToEdit ref) - pure (types1, accessorNames1) - ) - (Map.empty, Set.empty) - typeRefs - terms <- - termRefs & foldMapM \ref -> - let isRecordAccessor = - not (Set.disjoint (Names.namesForReferent allNamesToEdit (Referent.fromTermReference ref)) accessorNames) - in if isRecordAccessor - then pure Map.empty - else Map.singleton ref <$> Backend.displayTerm codebase ref - pure (types, terms) + (types, accessorNames) <- + Foldable.foldlM + ( \(types, accessorNames) ref -> + case ref of + ReferenceBuiltin _ -> do + let !types1 = Map.insert ref (DisplayObject.BuiltinObject ()) types + pure (types1, accessorNames) + ReferenceDerived refId -> do + decl <- Codebase.unsafeGetTypeDeclaration codebase refId + let !types1 = Map.insert ref (DisplayObject.UserObject decl) types + let !accessorNames1 = + accessorNames <> case decl of + Left _effectDecl -> Set.empty + Right dataDecl -> + let declAccessorNames :: Name -> Set Name + declAccessorNames declName = + case DeclPrinter.getFieldAndAccessorNames + ppe.unsuffixifiedPPE + ref + (HQ.fromName declName) + dataDecl of + Nothing -> Set.empty + Just (_fieldNames, theAccessorNames) -> Set.fromList theAccessorNames + in foldMap declAccessorNames (Names.namesForReference allNamesToEdit ref) + pure (types1, accessorNames1) + ) + (Map.empty, Set.empty) + typeRefs - let misses = [] - showDefinitions outputLoc ppe terms types misses + terms <- + termRefs & foldMapM \ref -> + let isRecordAccessor = + Set.intersects + (Names.namesForReferent allNamesToEdit (Referent.fromTermReference ref)) + accessorNames + in if isRecordAccessor + then pure Map.empty + else Map.singleton ref <$> Backend.displayTerm codebase ref + + pure (types, terms) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs index 45fb100a44..b18b360db2 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs @@ -1,6 +1,7 @@ module Unison.Codebase.Editor.HandleInput.FindAndReplace ( handleStructuredFindReplaceI, handleStructuredFindI, + handleTextFindI, ) where @@ -20,7 +21,7 @@ import Unison.Codebase.Branch.Names qualified as Branch import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment qualified as NameSegment @@ -28,6 +29,7 @@ import Unison.Names (Names) import Unison.Names qualified as Names import Unison.NamesWithHistory qualified as Names import Unison.Parser.Ann (Ann (..)) +import Unison.Pattern qualified as Pattern import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnv.Names qualified as PPE @@ -50,7 +52,7 @@ import Unison.Var qualified as Var handleStructuredFindReplaceI :: HQ.HashQualified Name -> Cli () handleStructuredFindReplaceI rule = do - Cli.Env {writeSource} <- ask + env <- ask uf0 <- Cli.expectLatestParsedFile let (prepare, uf, finish) = UF.prepareRewrite uf0 (ppe, _ns, rules) <- lookupRewrite InvalidStructuredFindReplace prepare rule @@ -65,7 +67,7 @@ handleStructuredFindReplaceI rule = do #latestTypecheckedFile .= Just (Left . snd $ uf') let msg = "| Rewrote using: " let rendered = Text.pack . P.toPlain 80 $ renderRewrittenFile ppe msg uf' - liftIO $ writeSource (Text.pack dest) rendered + liftIO $ env.writeSource (Text.pack dest) rendered True Cli.respond $ OutputRewrittenFile dest vs handleStructuredFindI :: HQ.HashQualified Name -> Cli () @@ -91,6 +93,48 @@ handleStructuredFindI rule = do Cli.setNumberedArgs $ map SA.HashQualified results Cli.respond (ListStructuredFind results) +handleTextFindI :: Bool -> [String] -> Cli () +handleTextFindI allowLib tokens = do + Cli.Env {codebase} <- ask + currentBranch <- Cli.getCurrentBranch0 + hqLength <- Cli.runTransaction Codebase.hashLength + let names = Branch.toNames currentBranch + let ppe = PPED.makePPED (PPE.hqNamer hqLength names) (PPE.suffixifyByHash names) + let fqppe = PPED.unsuffixifiedPPE ppe + results :: [(HQ.HashQualified Name, Referent)] <- pure $ do + r <- Set.toList (Relation.ran $ Names.terms names) + Just hq <- [PPE.terms fqppe r] + fullName <- [HQ'.toName hq] + guard (allowLib || not (Name.beginsWithSegment fullName NameSegment.libSegment)) + Referent.Ref _ <- pure r + Just shortName <- [PPE.terms (PPED.suffixifiedPPE ppe) r] + pure (HQ'.toHQ shortName, r) + let ok (hq, Referent.Ref (Reference.DerivedId r)) = do + oe <- Cli.runTransaction (Codebase.getTerm codebase r) + pure $ (hq, maybe False containsTokens oe) + ok (hq, _) = pure (hq, False) + results0 <- traverse ok results + let results = Alphabetical.sortAlphabetically [hq | (hq, True) <- results0] + Cli.setNumberedArgs $ map SA.HashQualified results + Cli.respond (ListTextFind allowLib results) + where + tokensTxt = Text.pack <$> tokens + containsTokens tm = + hasAll . join $ ABT.find txts tm + where + hasAll txts = all (\tok -> any (\haystack -> Text.isInfixOf tok haystack) txts) tokensTxt + txts (Term.Text' haystack) = ABT.Found [haystack] + txts (Term.Nat' haystack) = ABT.Found [Text.pack (show haystack)] + txts (Term.Int' haystack) = ABT.Found [Text.pack (show haystack)] + txts (Term.Float' haystack) = ABT.Found [Text.pack (show haystack)] + txts (Term.Char' haystack) = ABT.Found [Text.pack [haystack]] + txts (Term.Match' _ cases) = ABT.Found r + where + r = join $ Pattern.foldMap' txtPattern . Term.matchPattern <$> cases + txts _ = ABT.Continue + txtPattern (Pattern.Text _ txt) = [txt] + txtPattern _ = [] + lookupRewrite :: (HQ.HashQualified Name -> Output) -> ([Symbol] -> Term Symbol Ann -> Term Symbol Ann) -> diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FormatFile.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FormatFile.hs index fde32e2235..e0f2cf4294 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FormatFile.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FormatFile.hs @@ -39,7 +39,7 @@ import Unison.Var qualified as Var -- | Format a file, returning a list of Text replacements to apply to the file. formatFile :: - Monad m => + (Monad m) => (Maybe (UnisonFile Symbol Ann.Ann) -> Maybe (TypecheckedUnisonFile Symbol Ann.Ann) -> m PPED.PrettyPrintEnvDecl) -> Int -> Path.Absolute -> @@ -197,7 +197,7 @@ annToInterval ann = annToRange ann <&> rangeToInterval -- | Returns 'True' if the given symbol is a term with a user provided type signature in the -- parsed file, false otherwise. -hasUserTypeSignature :: Eq v => UnisonFile v a -> v -> Bool +hasUserTypeSignature :: (Eq v) => UnisonFile v a -> v -> Bool hasUserTypeSignature parsedFile sym = Map.toList (UF.terms parsedFile) & any (\(v, (_, trm)) -> v == sym && isJust (Term.getTypeAnnotation trm)) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Global.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Global.hs new file mode 100644 index 0000000000..1306497b61 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Global.hs @@ -0,0 +1,22 @@ +module Unison.Codebase.Editor.HandleInput.Global (forAllProjectBranches) where + +import Control.Monad.Reader +import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) +import U.Codebase.Sqlite.Queries qualified as Q +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch (Branch) +import Unison.Core.Project +import Unison.Prelude +import Unison.Util.Monoid (foldMapM) + +-- | Map over ALL project branches in the codebase. +-- This is a _very_ big hammer, that you should basically never use, except for things like debugging or migrations. +forAllProjectBranches :: (Monoid r) => ((ProjectAndBranch ProjectName ProjectBranchName, ProjectAndBranch ProjectId ProjectBranchId) -> Branch IO -> Cli r) -> Cli r +forAllProjectBranches f = do + Cli.Env {codebase} <- ask + projectBranches <- Cli.runTransaction Q.loadAllProjectBranchNamePairs + projectBranches & foldMapM \(names, ids@(ProjectAndBranch projId branchId)) -> do + b <- liftIO $ Codebase.expectProjectBranchRoot codebase projId branchId + f (names, ids) b diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs index 4c30120170..52e70188c8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs @@ -10,8 +10,6 @@ import Data.Map.Strict qualified as Map import Data.Maybe (fromJust) import Data.Set qualified as Set import Data.Text qualified as Text -import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..)) -import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch (..)) import Unison.Cli.DownloadUtils import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -22,6 +20,7 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Core.Project (ProjectBranchName) import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment (libSegment) @@ -40,14 +39,6 @@ import Unison.Syntax.NameSegment qualified as NameSegment (unsafeParseText) handleInstallLib :: Bool -> ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease) -> Cli () handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBranchName) = do - (currentProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch - - let currentProjectBranchPath = - ProjectUtils.projectBranchPath $ - ProjectAndBranch - currentProjectAndBranch.project.projectId - currentProjectAndBranch.branch.branchId - libdepProject <- ProjectUtils.expectRemoteProjectByName libdepProjectName libdepBranchName <- @@ -79,7 +70,7 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran -- -- For example, if the best name is "foo", and libdeps "foo" and "foo__2" already exist, then we'll get "foo__3". libdepNameSegment :: NameSegment <- do - currentBranchObject <- Cli.getBranch0At currentProjectBranchPath + currentBranchObject <- Cli.getCurrentProjectRoot0 pure $ fresh (\i -> NameSegment.unsafeParseText . (<> "__" <> tShow i) . NameSegment.toUnescapedText) @@ -90,13 +81,12 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran (makeDependencyName libdepProjectName libdepBranchName) let libdepPath :: Path.Absolute - libdepPath = - Path.resolve - currentProjectBranchPath - (Path.Relative (Path.fromList [NameSegment.libSegment, libdepNameSegment])) + libdepPath = Path.Absolute $ Path.fromList [NameSegment.libSegment, libdepNameSegment] let reflogDescription = "lib.install " <> into @Text libdepProjectAndBranchNames - _didUpdate <- Cli.updateAt reflogDescription libdepPath (\_empty -> remoteBranchObject) + pp <- Cli.getCurrentProjectPath + let libDepPP = pp & PP.absPath_ .~ libdepPath + _didUpdate <- Cli.updateAt reflogDescription libDepPP (\_empty -> remoteBranchObject) Cli.respond (Output.InstalledLibdep libdepProjectAndBranchNames libdepNameSegment) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LSPDebug.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LSPDebug.hs new file mode 100644 index 0000000000..dc4f0cc14d --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LSPDebug.hs @@ -0,0 +1,15 @@ +module Unison.Codebase.Editor.HandleInput.LSPDebug (debugLspNameCompletion) where + +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.NamesUtils qualified as Cli +import Unison.Codebase.Editor.Output (Output (DisplayDebugLSPNameCompletions)) +import Unison.LSP.Completion qualified as Completion +import Unison.Prelude + +debugLspNameCompletion :: Text -> Cli () +debugLspNameCompletion prefix = do + names <- Cli.currentNames + let ct = Completion.namesToCompletionTree names + let (_, matches) = Completion.completionsForQuery ct prefix + Cli.respond $ DisplayDebugLSPNameCompletions matches diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs index a9259fc969..dd1f62eb02 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs @@ -10,37 +10,46 @@ import Control.Lens ((.=)) import Control.Monad.Reader (ask) import Control.Monad.State.Strict qualified as State import Data.Map.Strict qualified as Map +import Data.Set qualified as Set import Data.Text qualified as Text import System.Environment (withArgs) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.NamesUtils qualified as Cli -import Unison.Cli.PrettyPrintUtils qualified as Cli import Unison.Cli.TypeCheck (computeTypecheckingEnvironment) import Unison.Cli.UniqueTypeGuidLookup qualified as Cli import Unison.Codebase qualified as Codebase +import Unison.Codebase.Editor.HandleInput.RuntimeUtils (EvalMode (..)) import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.Slurp qualified as Slurp +import Unison.Codebase.Execute qualified as Codebase import Unison.Codebase.Runtime qualified as Runtime import Unison.FileParsers qualified as FileParsers import Unison.Names (Names) +import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) import Unison.Parser.Ann qualified as Ann import Unison.Parsers qualified as Parsers import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE +import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED +import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Reference qualified as Reference import Unison.Result qualified as Result import Unison.Symbol (Symbol) +import Unison.Syntax.Name qualified as Name import Unison.Syntax.Parser qualified as Parser import Unison.Term (Term) import Unison.Term qualified as Term import Unison.UnisonFile (TypecheckedUnisonFile) +import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UF +import Unison.Util.Timing qualified as Timing +import Unison.Var qualified as Var import Unison.WatchKind qualified as WK handleLoad :: Maybe FilePath -> Cli () @@ -62,14 +71,19 @@ loadUnisonFile sourceName text = do unisonFile <- withFile currentNames sourceName text let sr = Slurp.slurpFile unisonFile mempty Slurp.CheckOp currentNames let names = UF.addNamesFromTypeCheckedUnisonFile unisonFile currentNames - pped <- Cli.prettyPrintEnvDeclFromNames names + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) let ppe = PPE.suffixifiedPPE pped Cli.respond $ Output.Typechecked sourceName ppe sr unisonFile - (bindings, e) <- evalUnisonFile Permissive ppe unisonFile [] - let e' = Map.map go e - go (ann, kind, _hash, _uneval, eval, isHit) = (ann, kind, eval, isHit) - when (not (null e')) do - Cli.respond $ Output.Evaluated text ppe bindings e' + + when (not . null $ UF.watchComponents unisonFile) do + Timing.time "evaluating watches" do + evalUnisonFile Permissive ppe unisonFile [] >>= \case + Right (bindings, e) -> do + when (not (null e)) do + let f (ann, kind, _hash, _uneval, eval, isHit) = (ann, kind, eval, isHit) + Cli.respond $ Output.Evaluated text ppe bindings (Map.map f e) + Left err -> Cli.respond (Output.EvaluationFailure err) + #latestTypecheckedFile .= Just (Right unisonFile) where withFile :: @@ -78,18 +92,20 @@ loadUnisonFile sourceName text = do Text -> Cli (TypecheckedUnisonFile Symbol Ann) withFile names sourceName text = do - currentPath <- Cli.getCurrentPath + pp <- Cli.getCurrentProjectPath State.modify' \loopState -> loopState - & #latestFile .~ Just (Text.unpack sourceName, False) - & #latestTypecheckedFile .~ Nothing + & (#latestFile .~ Just (Text.unpack sourceName, False)) + & (#latestTypecheckedFile .~ Nothing) Cli.Env {codebase, generateUniqueName} <- ask uniqueName <- liftIO generateUniqueName let parsingEnv = Parser.ParsingEnv { uniqueNames = uniqueName, - uniqueTypeGuid = Cli.loadUniqueTypeGuid currentPath, - names + uniqueTypeGuid = Cli.loadUniqueTypeGuid pp, + names, + maybeNamespace = Nothing, + localNamespacePrefixedTypesAndConstructors = mempty } unisonFile <- Cli.runTransaction (Parsers.parseFile (Text.unpack sourceName) (Text.unpack text) parsingEnv) @@ -101,8 +117,29 @@ loadUnisonFile sourceName text = do computeTypecheckingEnvironment (FileParsers.ShouldUseTndr'Yes parsingEnv) codebase [] unisonFile let Result.Result notes maybeTypecheckedUnisonFile = FileParsers.synthesizeFile typecheckingEnv unisonFile maybeTypecheckedUnisonFile & onNothing do - let namesWithFileDefinitions = UF.addNamesFromUnisonFile unisonFile names - pped <- Cli.prettyPrintEnvDeclFromNames namesWithFileDefinitions + let pped = + let ns = + names + -- Shadow just the type decl and constructor names (because the unison file didn't typecheck so we + -- don't have term `Names`) + & Names.shadowing (UF.toNames unisonFile) + in PPED.makePPED + (PPE.hqNamer 10 ns) + ( PPE.suffixifyByHashWithUnhashedTermsInScope + ( Set.union + (Set.map Name.unsafeParseVar (Map.keysSet (UF.terms unisonFile))) + ( foldMap + ( foldMap \case + (v, _, _) -> + case Var.typeOf v of + Var.User _ -> Set.singleton (Name.unsafeParseVar v) + _ -> Set.empty + ) + (UF.watches unisonFile) + ) + ) + ns + ) let suffixifiedPPE = PPED.suffixifiedPPE pped let tes = [err | Result.TypeError err <- toList notes] cbs = @@ -117,8 +154,6 @@ loadUnisonFile sourceName text = do Cli.respond (Output.CompilerBugs text suffixifiedPPE cbs) Cli.returnEarlyWithoutOutput -data EvalMode = Sandboxed | Permissive | Native - -- | Evaluate all watched expressions in a UnisonFile and return -- their results, keyed by the name of the watch variable. The tuple returned -- has the form: @@ -141,29 +176,34 @@ evalUnisonFile :: TypecheckedUnisonFile Symbol Ann -> [String] -> Cli - ( [(Symbol, Term Symbol ())], - Map Symbol (Ann, WK.WatchKind, Reference.Id, Term Symbol (), Term Symbol (), Bool) + ( Either + Runtime.Error + ( [(Symbol, Term Symbol ())], + Map Symbol (Ann, WK.WatchKind, Reference.Id, Term Symbol (), Term Symbol (), Bool) + ) ) evalUnisonFile mode ppe unisonFile args = do - Cli.Env {codebase, runtime, sandboxedRuntime, nativeRuntime} <- ask + env <- ask + let theRuntime = case mode of - Sandboxed -> sandboxedRuntime - Permissive -> runtime - Native -> nativeRuntime + Sandboxed -> env.sandboxedRuntime + Permissive -> env.runtime + Native -> env.nativeRuntime let watchCache :: Reference.Id -> IO (Maybe (Term Symbol ())) watchCache ref = do - maybeTerm <- Codebase.runTransaction codebase (Codebase.lookupWatchCache codebase ref) + maybeTerm <- Codebase.runTransaction env.codebase (Codebase.lookupWatchCache env.codebase ref) pure (Term.amap (\(_ :: Ann) -> ()) <$> maybeTerm) Cli.with_ (withArgs args) do - (nts, errs, map) <- - Cli.ioE (Runtime.evaluateWatches (Codebase.toCodeLookup codebase) ppe watchCache theRuntime unisonFile) \err -> do - Cli.returnEarly (Output.EvaluationFailure err) - when (not $ null errs) (RuntimeUtils.displayDecompileErrors errs) - for_ (Map.elems map) \(_loc, kind, hash, _src, value, isHit) -> do - -- only update the watch cache when there are no errors - when (not isHit && null errs) do - let value' = Term.amap (\() -> Ann.External) value - Cli.runTransaction (Codebase.putWatch kind hash value') - pure (nts, map) + let codeLookup = Codebase.codebaseToCodeLookup env.codebase + liftIO (Runtime.evaluateWatches codeLookup ppe watchCache theRuntime unisonFile) >>= \case + Right (nts, errs, map) -> do + when (not $ null errs) (RuntimeUtils.displayDecompileErrors errs) + for_ (Map.elems map) \(_loc, kind, hash, _src, value, isHit) -> do + -- only update the watch cache when there are no errors + when (not isHit && null errs) do + let value' = Term.amap (\() -> Ann.External) value + Cli.runTransaction (Codebase.putWatch kind hash value') + pure (Right (nts, map)) + Left err -> pure (Left err) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Ls.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Ls.hs new file mode 100644 index 0000000000..2331f637d7 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Ls.hs @@ -0,0 +1,38 @@ +module Unison.Codebase.Editor.HandleInput.Ls + ( handleLs, + ) +where + +import Control.Monad.Reader (ask) +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Cli.NamesUtils qualified as Cli +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Editor.Output +import Unison.Codebase.Editor.StructuredArgument qualified as SA +import Unison.Codebase.Path (Path') +import Unison.Codebase.ProjectPath (ProjectPathG (..)) +import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE +import Unison.PrettyPrintEnvDecl qualified as PPED +import Unison.PrettyPrintEnvDecl.Names qualified as PPED +import Unison.Server.Backend qualified as Backend + +handleLs :: Path' -> Cli () +handleLs pathArg = do + Cli.Env {codebase} <- ask + pp <- Cli.resolvePath' pathArg + projectRootBranch <- Cli.runTransaction $ Codebase.expectShallowProjectBranchRoot pp.branch + entries <- liftIO (Backend.lsAtPath codebase projectRootBranch (pp.absPath)) + Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries + names <- Cli.currentNames + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) + let suffixifiedPPE = PPED.suffixifiedPPE pped + -- This used to be a delayed action which only forced the loading of the root + -- branch when it was necessary for printing the results, but that got wiped out + -- when we ported to the new Cli monad. + -- It would be nice to restore it, but it's pretty rare that it actually results + -- in an improvement, so perhaps it's not worth the effort. + let buildPPE = pure suffixifiedPPE + Cli.respond $ ListShallow buildPPE entries diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index ba382842ba..72920b190d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -1,3 +1,4 @@ +-- | @merge@ input handler. module Unison.Codebase.Editor.HandleInput.Merge2 ( handleMerge, @@ -8,27 +9,25 @@ module Unison.Codebase.Editor.HandleInput.Merge2 LcaMergeInfo (..), doMerge, doMergeLocalBranch, + + -- * API exported for @todo@ + hasDefnsInLib, ) where -import Control.Lens (mapped, _1) import Control.Monad.Reader (ask) -import Control.Monad.Writer (Writer) -import Control.Monad.Writer qualified as Writer -import Data.Bifoldable (bifoldMap) -import Data.Bitraversable (bitraverse) -import Data.Foldable qualified as Foldable +import Data.Algorithm.Diff qualified as Diff import Data.List qualified as List -import Data.List.NonEmpty (pattern (:|)) -import Data.List.NonEmpty qualified as List.NonEmpty import Data.Map.Strict qualified as Map -import Data.Semialign (align, unzip) -import Data.Set qualified as Set -import Data.Set.NonEmpty (NESet) -import Data.Set.NonEmpty qualified as Set.NonEmpty +import Data.Semialign (zipWith) import Data.Text qualified as Text import Data.Text.IO qualified as Text import Data.These (These (..)) +import System.Directory (canonicalizePath, getTemporaryDirectory, removeFile) +import System.Environment (lookupEnv) +import System.FilePath (()) +import System.IO.Temp qualified as Temporary +import System.Process qualified as Process import Text.ANSI qualified as Text import Text.Builder qualified import Text.Builder qualified as Text (Builder) @@ -36,113 +35,91 @@ import U.Codebase.Branch qualified as V2 (Branch (..), CausalBranch) import U.Codebase.Branch qualified as V2.Branch import U.Codebase.Causal qualified as V2.Causal import U.Codebase.HashTags (CausalHash, unCausalHash) -import U.Codebase.Reference (Reference, TermReferenceId, TypeReference, TypeReferenceId) -import U.Codebase.Referent qualified as V2 (Referent) +import U.Codebase.Reference (TermReferenceId, TypeReference, TypeReferenceId) import U.Codebase.Sqlite.DbId (ProjectId) import U.Codebase.Sqlite.Operations qualified as Operations import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Queries -import Unison.Builtin.Decls qualified as Builtin.Decls import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceAndTarget (..), MergeSourceOrTarget (..)) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils +import Unison.Cli.UpdateUtils + ( getNamespaceDependentsOf3, + hydrateDefns, + loadNamespaceDefinitions, + ) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Names qualified as Branch +import Unison.Codebase.BranchUtil qualified as BranchUtil import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch -import Unison.Codebase.Editor.HandleInput.Update2 - ( getNamespaceDependentsOf2, - makeParsingEnv, - prettyParseTypecheck2, - typecheckedUnisonFileToBranchAdds, - ) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode (..)) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathG (..)) +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache) import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions import Unison.Codebase.SqliteCodebase.Operations qualified as Operations -import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) import Unison.DataDeclaration (Decl) +import Unison.DataDeclaration qualified as DataDeclaration import Unison.Debug qualified as Debug -import Unison.Hash (Hash) import Unison.Hash qualified as Hash -import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' -import Unison.Merge.CombineDiffs (CombinedDiffOp (..), combineDiffs) -import Unison.Merge.Database (MergeDatabase (..), makeMergeDatabase, referent2to1) -import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason (..), checkDeclCoherency, lenientCheckDeclCoherency) -import Unison.Merge.DeclNameLookup (DeclNameLookup (..), expectConstructorNames) -import Unison.Merge.Diff qualified as Merge -import Unison.Merge.DiffOp (DiffOp (..)) -import Unison.Merge.EitherWay (EitherWay (..)) -import Unison.Merge.EitherWayI (EitherWayI (..)) +import Unison.Merge qualified as Merge import Unison.Merge.EitherWayI qualified as EitherWayI -import Unison.Merge.Libdeps qualified as Merge -import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs) -import Unison.Merge.Synhashed (Synhashed (..)) import Unison.Merge.Synhashed qualified as Synhashed -import Unison.Merge.ThreeWay (ThreeWay (..)) import Unison.Merge.ThreeWay qualified as ThreeWay -import Unison.Merge.TwoOrThreeWay (TwoOrThreeWay (..)) -import Unison.Merge.TwoWay (TwoWay (..)) -import Unison.Merge.TwoWay qualified as TwoWay -import Unison.Merge.TwoWayI qualified as TwoWayI -import Unison.Merge.Unconflicts (Unconflicts (..)) -import Unison.Merge.Unconflicts qualified as Unconflicts -import Unison.Merge.Updated (Updated (..)) import Unison.Name (Name) -import Unison.Name qualified as Name +import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment -import Unison.NameSegment.Internal (NameSegment (NameSegment)) -import Unison.NameSegment.Internal qualified as NameSegment -import Unison.Names (Names) -import Unison.Names qualified as Names +import Unison.Parser.Ann (Ann) import Unison.Prelude -import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) -import Unison.PrettyPrintEnv.Names qualified as PPE -import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..)) -import Unison.PrettyPrintEnvDecl.Names qualified as PPED -import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, Semver (..), classifyProjectBranchName) +import Unison.Project + ( ProjectAndBranch (..), + ProjectBranchName, + ProjectBranchNameKind (..), + ProjectName, + Semver (..), + classifyProjectBranchName, + ) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent -import Unison.Referent' qualified as Referent' +import Unison.ReferentPrime qualified as Referent' import Unison.Sqlite (Transaction) import Unison.Sqlite qualified as Sqlite -import Unison.Syntax.DeclPrinter (AccessorName) -import Unison.Syntax.DeclPrinter qualified as DeclPrinter +import Unison.Symbol (Symbol) import Unison.Syntax.Name qualified as Name -import Unison.Syntax.TermPrinter qualified as TermPrinter import Unison.Term (Term) import Unison.Type (Type) -import Unison.Typechecker qualified as Typechecker -import Unison.Util.BiMultimap (BiMultimap) +import Unison.UnisonFile (TypecheckedUnisonFile) +import Unison.UnisonFile qualified as UnisonFile import Unison.Util.BiMultimap qualified as BiMultimap -import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, alignDefnsWith, defnsAreEmpty, zipDefnsWith, zipDefnsWith3) +import Unison.Util.Conflicted (Conflicted) +import Unison.Util.Defn (Defn) +import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, alignDefnsWith) import Unison.Util.Monoid qualified as Monoid -import Unison.Util.Nametree (Nametree (..), flattenNametree, traverseNametreeWithName, unflattenNametree) -import Unison.Util.Pretty (ColorText, Pretty) +import Unison.Util.Nametree (Nametree (..), unflattenNametree) import Unison.Util.Pretty qualified as Pretty import Unison.Util.Relation (Relation) import Unison.Util.Relation qualified as Relation import Unison.Util.Star2 (Star2) import Unison.Util.Star2 qualified as Star2 -import Unison.Util.SyntaxText (SyntaxText') -import Unison.Var (Var) +import Unison.WatchKind qualified as WatchKind import Witch (unsafeFrom) import Prelude hiding (unzip, zip, zipWith) handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do -- Assert that Alice (us) is on a project branch, and grab the causal hash. - (aliceProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch + ProjectPath aliceProject aliceProjectBranch _path <- Cli.getCurrentProjectPath + let aliceProjectAndBranch = ProjectAndBranch aliceProject aliceProjectBranch -- Resolve Bob's maybe-project-name + branch-name to the info the merge algorithm needs: the project name, branch -- name, and causal hash. @@ -158,7 +135,7 @@ handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do let bobProjectAndBranch = ProjectAndBranch bobProject bobProjectBranch doMergeLocalBranch - TwoWay + Merge.TwoWay { alice = aliceProjectAndBranch, bob = bobProjectAndBranch } @@ -192,13 +169,12 @@ doMerge info = do then realDebugFunctions else fakeDebugFunctions - let alicePath = ProjectUtils.projectBranchPath (ProjectUtils.justTheIds info.alice.projectAndBranch) let aliceBranchNames = ProjectUtils.justTheNames info.alice.projectAndBranch let mergeSource = MergeSourceOrTarget'Source info.bob.source let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames let mergeSourceAndTarget = MergeSourceAndTarget {alice = aliceBranchNames, bob = info.bob.source} - Cli.Env {codebase} <- ask + env <- ask finalOutput <- Cli.label \done -> do @@ -208,235 +184,269 @@ doMerge info = do -- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done. when (info.lca.causalHash == Just info.alice.causalHash) do - bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash) - _ <- Cli.updateAt info.description alicePath (\_aliceBranch -> bobBranch) + bobBranch <- liftIO (Codebase.expectBranchForHash env.codebase info.bob.causalHash) + _ <- Cli.updateAt info.description (PP.projectBranchRoot info.alice.projectAndBranch) (\_aliceBranch -> bobBranch) done (Output.MergeSuccessFastForward mergeSourceAndTarget) - -- Create a bunch of cached database lookup functions - db <- makeMergeDatabase codebase - - -- Load Alice/Bob/LCA causals - causals <- Cli.runTransaction do - traverse - Operations.expectCausalBranchByCausalHash - TwoOrThreeWay - { alice = info.alice.causalHash, - bob = info.bob.causalHash, - lca = info.lca.causalHash - } - - liftIO (debugFunctions.debugCausals causals) - - -- Load Alice/Bob/LCA branches - branches <- - Cli.runTransaction do - alice <- causals.alice.value - bob <- causals.bob.value - lca <- for causals.lca \causal -> causal.value - pure TwoOrThreeWay {lca, alice, bob} - - -- Assert that neither Alice nor Bob have defns in lib - for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do - libdeps <- - case Map.lookup NameSegment.libSegment branch.children of - Nothing -> pure V2.Branch.empty - Just libdeps -> Cli.runTransaction libdeps.value - when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do - done (Output.MergeDefnsInLib who) - - -- Load Alice/Bob/LCA definitions and decl name lookups - (defns3, declNameLookups, lcaDeclToConstructors) <- do - let emptyNametree = Nametree {value = Defns Map.empty Map.empty, children = Map.empty} - let loadDefns branch = - Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName -> - done case conflictedName of - ConflictedName'Term name refs -> Output.MergeConflictedTermName name refs - ConflictedName'Type name refs -> Output.MergeConflictedTypeName name refs - let load = \case - Nothing -> pure (emptyNametree, DeclNameLookup Map.empty Map.empty) - Just (who, branch) -> do - defns <- loadDefns branch - declNameLookup <- - Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err -> - done case err of - IncoherentDeclReason'ConstructorAlias typeName conName1 conName2 -> - Output.MergeConstructorAlias who typeName conName1 conName2 - IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName who name - IncoherentDeclReason'NestedDeclAlias shorterName longerName -> - Output.MergeNestedDeclAlias who shorterName longerName - IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor who name - pure (defns, declNameLookup) - - (aliceDefns0, aliceDeclNameLookup) <- load (Just (mergeTarget, branches.alice)) - (bobDefns0, bobDeclNameLookup) <- load (Just (mergeSource, branches.bob)) - lcaDefns0 <- maybe (pure emptyNametree) loadDefns branches.lca - lcaDeclToConstructors <- Cli.runTransaction (lenientCheckDeclCoherency db.loadDeclNumConstructors lcaDefns0) - - let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns) - let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0} - let declNameLookups = TwoWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup} - - pure (defns3, declNameLookups, lcaDeclToConstructors) - - let defns = ThreeWay.forgetLca defns3 - - liftIO (debugFunctions.debugDefns defns3 declNameLookups lcaDeclToConstructors) - - -- Diff LCA->Alice and LCA->Bob - diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns3) - - liftIO (debugFunctions.debugDiffs diffs) - - -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias - for_ ((,) <$> TwoWay mergeTarget mergeSource <*> diffs) \(who, diff) -> - whenJust (findConflictedAlias defns3.lca diff) \(name1, name2) -> - done (Output.MergeConflictedAliases who name1 name2) - - -- Combine the LCA->Alice and LCA->Bob diffs together - let diff = combineDiffs diffs - - liftIO (debugFunctions.debugCombinedDiff diff) - - -- Partition the combined diff into the conflicted things and the unconflicted things - (conflicts, unconflicts) <- - partitionCombinedDiffs defns declNameLookups diff & onLeft \name -> - done (Output.MergeConflictInvolvingBuiltin name) - - liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts) - - -- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there - -- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are) - dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts) - - liftIO (debugFunctions.debugDependents dependents) - - let stageOne :: DefnsF (Map Name) Referent TypeReference - stageOne = - makeStageOne - declNameLookups - conflicts - unconflicts - dependents - (bimap BiMultimap.range BiMultimap.range defns3.lca) - - liftIO (debugFunctions.debugStageOne stageOne) - - -- Load and merge Alice's and Bob's libdeps - mergedLibdeps <- - Cli.runTransaction do - libdeps <- loadLibdeps branches - libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps) - - -- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names - let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl - mkPpes defnsNames libdepsNames = - defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier - where - suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames) - let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps) - - hydratedThings <- do - Cli.runTransaction do - for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) -> - let hydrate = hydrateDefns (Codebase.unsafeGetTermComponent codebase) Operations.expectDeclComponent - in (,) <$> hydrate conflicts1 <*> hydrate dependents1 - - let (renderedConflicts, renderedDependents) = - let honk declNameLookup ppe defns = - let (types, accessorNames) = - Writer.runWriter $ - defns.types & Map.traverseWithKey \name (ref, typ) -> - renderTypeBinding - -- Sort of a hack; since the decl printer looks in the PPE for names of constructors, - -- we just delete all term names out and add back the constructors... - -- probably no need to wipe out the suffixified side but we do it anyway - (setPpedToConstructorNames declNameLookup name ref ppe) - name - ref - typ - terms = - defns.terms & Map.mapMaybeWithKey \name (term, typ) -> - if Set.member name accessorNames - then Nothing - else Just (renderTermBinding ppe.suffixifiedPPE name term typ) - in Defns {terms, types} - in unzip $ - ( \declNameLookup (conflicts, dependents) ppe -> - let honk1 = honk declNameLookup ppe - in (honk1 conflicts, honk1 dependents) - ) - <$> declNameLookups - <*> hydratedThings - <*> ppes - - let prettyUnisonFile = - makePrettyUnisonFile - TwoWay - { alice = into @Text aliceBranchNames, - bob = - case info.bob.source of - MergeSource'LocalProjectBranch bobBranchNames -> into @Text bobBranchNames - MergeSource'RemoteProjectBranch bobBranchNames - | aliceBranchNames == bobBranchNames -> "remote " <> into @Text bobBranchNames - | otherwise -> into @Text bobBranchNames - MergeSource'RemoteLooseCode info -> - case Path.toName info.path of - Nothing -> "" - Just name -> Name.toText name + Cli.withRespondRegion \respondRegion -> do + respondRegion (Output.Literal "Loading branches...") + + -- Load Alice/Bob/LCA causals + causals <- + Cli.runTransaction do + traverse + Operations.expectCausalBranchByCausalHash + Merge.TwoOrThreeWay + { alice = info.alice.causalHash, + bob = info.bob.causalHash, + lca = info.lca.causalHash } - renderedConflicts - renderedDependents - - let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps - - maybeTypecheckedUnisonFile <- - let thisMergeHasConflicts = - -- Eh, they'd either both be null, or neither, but just check both maps anyway - not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob) - in if thisMergeHasConflicts - then pure Nothing - else do - currentPath <- Cli.getCurrentPath - parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch) - prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe - - let parents = - (\causal -> (causal.causalHash, Codebase.expectBranchForHash codebase causal.causalHash)) <$> causals - - case maybeTypecheckedUnisonFile of - Nothing -> do - Cli.Env {writeSource} <- ask - (_temporaryBranchId, temporaryBranchName) <- - HandleInput.Branch.doCreateBranch' - (Branch.mergeNode stageOneBranch parents.alice parents.bob) - (Just info.alice.projectAndBranch.branch.branchId) - info.alice.projectAndBranch.project - (findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget) - info.description - scratchFilePath <- - Cli.getLatestFile <&> \case - Nothing -> "scratch.u" - Just (file, _) -> file - liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) - pure (Output.MergeFailure scratchFilePath mergeSourceAndTarget temporaryBranchName) - Just tuf -> do - Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) - let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch - _ <- - Cli.updateAt - info.description - alicePath - (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) - pure (Output.MergeSuccess mergeSourceAndTarget) + + liftIO (debugFunctions.debugCausals causals) + + -- Load Alice/Bob/LCA branches + branches <- + Cli.runTransaction do + alice <- causals.alice.value + bob <- causals.bob.value + lca <- for causals.lca \causal -> causal.value + pure Merge.TwoOrThreeWay {lca, alice, bob} + + -- Assert that neither Alice nor Bob have defns in lib + for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do + whenM (Cli.runTransaction (hasDefnsInLib branch)) do + done (Output.MergeDefnsInLib who) + + -- Load Alice/Bob/LCA definitions + -- + -- FIXME: Oops, if this fails due to a conflicted name, we don't actually say where the conflicted name came from. + -- We should have a better error message (even though you can't do anything about conflicted names in the LCA). + nametrees3 :: Merge.ThreeWay (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) <- do + let referent2to1 = Conversions.referent2to1 (Codebase.getDeclType env.codebase) + let action :: + (forall a. Defn (Conflicted Name Referent) (Conflicted Name TypeReference) -> Transaction a) -> + Transaction (Merge.ThreeWay (Nametree (DefnsF (Map NameSegment) Referent TypeReference))) + action rollback = do + alice <- loadNamespaceDefinitions referent2to1 branches.alice & onLeftM rollback + bob <- loadNamespaceDefinitions referent2to1 branches.bob & onLeftM rollback + lca <- + case branches.lca of + Nothing -> pure Nametree {value = Defns Map.empty Map.empty, children = Map.empty} + Just lca -> loadNamespaceDefinitions referent2to1 lca & onLeftM rollback + pure Merge.ThreeWay {alice, bob, lca} + Cli.runTransactionWithRollback2 (\rollback -> Right <$> action (rollback . Left)) + & onLeftM (done . Output.ConflictedDefn "merge") + + libdeps3 <- Cli.runTransaction (loadLibdeps branches) + + let blob0 = Merge.makeMergeblob0 nametrees3 libdeps3 + + -- Hydrate + hydratedDefns :: + Merge.ThreeWay + ( DefnsF + (Map Name) + (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) + (TypeReferenceId, Decl Symbol Ann) + ) <- + Cli.runTransaction $ + traverse + ( hydrateDefns + (Codebase.unsafeGetTermComponent env.codebase) + Operations.expectDeclComponent + ) + ( let f = Map.mapMaybe Referent.toTermReferenceId . BiMultimap.range + g = Map.mapMaybe Reference.toId . BiMultimap.range + in bimap f g <$> blob0.defns + ) + + respondRegion (Output.Literal "Computing diff between branches...") + + blob1 <- + Merge.makeMergeblob1 blob0 hydratedDefns & onLeft \case + Merge.Alice reason -> done (Output.IncoherentDeclDuringMerge mergeTarget reason) + Merge.Bob reason -> done (Output.IncoherentDeclDuringMerge mergeSource reason) + + liftIO (debugFunctions.debugDiffs blob1.diffs) + + liftIO (debugFunctions.debugCombinedDiff blob1.diff) + + blob2 <- + Merge.makeMergeblob2 blob1 & onLeft \err -> + done case err of + Merge.Mergeblob2Error'ConflictedAlias defn0 -> + case defn0 of + Merge.Alice defn -> Output.MergeConflictedAliases mergeTarget defn + Merge.Bob defn -> Output.MergeConflictedAliases mergeSource defn + Merge.Mergeblob2Error'ConflictedBuiltin defn -> Output.MergeConflictInvolvingBuiltin defn + + liftIO (debugFunctions.debugPartitionedDiff blob2.conflicts blob2.unconflicts) + + respondRegion (Output.Literal "Loading dependents of changes...") + + dependents0 <- + Cli.runTransaction $ + for ((,) <$> ThreeWay.forgetLca blob2.defns <*> blob2.coreDependencies) \(defns, deps) -> + getNamespaceDependentsOf3 defns deps + + respondRegion (Output.Literal "Loading and merging library dependencies...") + + -- Load libdeps + (mergedLibdeps, lcaLibdeps) <- do + -- We make a fresh branch cache to load the branch of libdeps. + -- It would probably be better to reuse the codebase's branch cache. + -- FIXME how slow/bad is this without that branch cache? + Cli.runTransaction do + branchCache <- Sqlite.unsafeIO newBranchCache + let load children = + Conversions.branch2to1 + branchCache + (Codebase.getDeclType env.codebase) + V2.Branch {terms = Map.empty, types = Map.empty, patches = Map.empty, children} + mergedLibdeps <- load blob2.libdeps + lcaLibdeps <- load blob2.lcaLibdeps + pure (mergedLibdeps, lcaLibdeps) + + let hasConflicts = + blob2.hasConflicts + + respondRegion (Output.Literal "Rendering Unison file...") + + let blob3 = + Merge.makeMergeblob3 + blob2 + dependents0 + (Branch.toNames mergedLibdeps) + (Branch.toNames lcaLibdeps) + Merge.TwoWay + { alice = into @Text aliceBranchNames, + bob = + case info.bob.source of + MergeSource'LocalProjectBranch bobBranchNames -> into @Text bobBranchNames + MergeSource'RemoteProjectBranch bobBranchNames + | aliceBranchNames == bobBranchNames -> "remote " <> into @Text bobBranchNames + | otherwise -> into @Text bobBranchNames + MergeSource'RemoteLooseCode info -> + case Path.toName info.path of + Nothing -> "" + Just name -> Name.toText name + } + + maybeBlob5 <- + if hasConflicts + then pure Nothing + else case Merge.makeMergeblob4 blob3 of + Left _parseErr -> pure Nothing + Right blob4 -> do + respondRegion (Output.Literal "Typechecking Unison file...") + typeLookup <- Cli.runTransaction (Codebase.typeLookupForDependencies env.codebase blob4.dependencies) + pure case Merge.makeMergeblob5 blob4 typeLookup of + Left _typecheckErr -> Nothing + Right blob5 -> Just blob5 + + let parents = + causals <&> \causal -> (causal.causalHash, Codebase.expectBranchForHash env.codebase causal.causalHash) + + blob5 <- + maybeBlob5 & onNothing do + env <- ask + (_temporaryBranchId, temporaryBranchName) <- + HandleInput.Branch.createBranch + info.description + ( HandleInput.Branch.CreateFrom'NamespaceWithParent + info.alice.projectAndBranch.branch + ( Branch.mergeNode + (defnsAndLibdepsToBranch0 env.codebase blob3.stageTwo mergedLibdeps) + parents.alice + parents.bob + ) + ) + info.alice.projectAndBranch.project + (findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget) + + -- Merge conflicts? Have UCM_MERGETOOL? Result + -- ---------------- ------------------- ------------------------------------------------------------ + -- No No Put code that doesn't parse or typecheck in scratch.u + -- No Yes Put code that doesn't parse or typecheck in scratch.u + -- Yes No Put code that doesn't parse (because conflicts) in scratch.u + -- Yes Yes Run that cool tool + + maybeMergetool <- + if hasConflicts + then liftIO (lookupEnv "UCM_MERGETOOL") + else pure Nothing + + case maybeMergetool of + Nothing -> do + scratchFilePath <- + Cli.getLatestFile <&> \case + Nothing -> "scratch.u" + Just (file, _) -> file + liftIO $ env.writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 blob3.unparsedFile) True + done (Output.MergeFailure scratchFilePath mergeSourceAndTarget temporaryBranchName) + Just mergetool0 -> do + let aliceFilenameSlug = mangleBranchName mergeSourceAndTarget.alice.branch + let bobFilenameSlug = mangleMergeSource mergeSourceAndTarget.bob + makeTempFilename <- + liftIO do + tmpdir0 <- getTemporaryDirectory + tmpdir1 <- canonicalizePath tmpdir0 + tmpdir2 <- Temporary.createTempDirectory tmpdir1 "unison-merge" + pure \filename -> Text.pack (tmpdir2 Text.unpack (Text.Builder.run filename)) + let lcaFilename = makeTempFilename (aliceFilenameSlug <> "-" <> bobFilenameSlug <> "-base.u") + let aliceFilename = makeTempFilename (aliceFilenameSlug <> ".u") + let bobFilename = makeTempFilename (bobFilenameSlug <> ".u") + let mergedFilename = Text.Builder.run (aliceFilenameSlug <> "-" <> bobFilenameSlug <> "-merged.u") + let mergetool = + mergetool0 + & Text.pack + & Text.replace "$BASE" lcaFilename + & Text.replace "$LOCAL" aliceFilename + & Text.replace "$MERGED" mergedFilename + & Text.replace "$REMOTE" bobFilename + exitCode <- + liftIO do + let aliceFileContents = Text.pack (Pretty.toPlain 80 blob3.unparsedSoloFiles.alice) + let bobFileContents = Text.pack (Pretty.toPlain 80 blob3.unparsedSoloFiles.bob) + removeFile (Text.unpack mergedFilename) <|> pure () + env.writeSource lcaFilename (Text.pack (Pretty.toPlain 80 blob3.unparsedSoloFiles.lca)) True + env.writeSource aliceFilename aliceFileContents True + env.writeSource bobFilename bobFileContents True + env.writeSource + mergedFilename + ( makeMergedFileContents + mergeSourceAndTarget + aliceFileContents + bobFileContents + ) + True + let createProcess = (Process.shell (Text.unpack mergetool)) {Process.delegate_ctlc = True} + Process.withCreateProcess createProcess \_ _ _ -> Process.waitForProcess + done (Output.MergeFailureWithMergetool mergeSourceAndTarget temporaryBranchName mergetool exitCode) + + Cli.runTransaction (Codebase.addDefsToCodebase env.codebase blob5.file) + Cli.updateProjectBranchRoot_ + info.alice.projectAndBranch.branch + info.description + ( \_aliceBranch -> + Branch.mergeNode + ( Branch.batchUpdates + (typecheckedUnisonFileToBranchAdds blob5.file) + (defnsAndLibdepsToBranch0 env.codebase blob3.stageOne mergedLibdeps) + ) + parents.alice + parents.bob + ) + pure (Output.MergeSuccess mergeSourceAndTarget) Cli.respond finalOutput -doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli () +doMergeLocalBranch :: Merge.TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli () doMergeLocalBranch branches = do (aliceCausalHash, bobCausalHash, lcaCausalHash) <- Cli.runTransaction do - aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.alice) - bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.bob) + aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.alice ^. #branch) + bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.bob ^. #branch) -- Using Alice and Bob's causal hashes, find the LCA (if it exists) lcaCausalHash <- Operations.lca aliceCausalHash bobCausalHash pure (aliceCausalHash, bobCausalHash, lcaCausalHash) @@ -465,8 +475,8 @@ doMergeLocalBranch branches = do -- Loading basic info out of the database loadLibdeps :: - TwoOrThreeWay (V2.Branch Transaction) -> - Transaction (ThreeWay (Map NameSegment (V2.CausalBranch Transaction))) + Merge.TwoOrThreeWay (V2.Branch Transaction) -> + Transaction (Merge.ThreeWay (Map NameSegment (V2.CausalBranch Transaction))) loadLibdeps branches = do lca <- case branches.lca of @@ -474,7 +484,7 @@ loadLibdeps branches = do Just lcaBranch -> load lcaBranch alice <- load branches.alice bob <- load branches.bob - pure ThreeWay {lca, alice, bob} + pure Merge.ThreeWay {lca, alice, bob} where load :: V2.Branch Transaction -> Transaction (Map NameSegment (V2.CausalBranch Transaction)) load branch = @@ -485,195 +495,19 @@ loadLibdeps branches = do pure libdepsBranch.children ------------------------------------------------------------------------------------------------------------------------ --- Creating Unison files - -hydrateDefns :: - (Monad m, Ord name) => - (Hash -> m [term]) -> - (Hash -> m [typ]) -> - DefnsF (Map name) TermReferenceId TypeReferenceId -> - m (DefnsF (Map name) term (TypeReferenceId, typ)) -hydrateDefns getTermComponent getTypeComponent = do - bitraverse (hydrateTerms getTermComponent) (hydrateTypes getTypeComponent) - -hydrateTerms :: (Monad m, Ord name) => (Hash -> m [term]) -> Map name TermReferenceId -> m (Map name term) -hydrateTerms getTermComponent terms = - componenty getTermComponent terms \_ _ -> id - -hydrateTypes :: - (Monad m, Ord name) => - (Hash -> m [typ]) -> - Map name TypeReferenceId -> - m (Map name (TypeReferenceId, typ)) -hydrateTypes getTypeComponent types = - componenty getTypeComponent types \_ -> (,) - -componenty :: - forall a b name m. - (Monad m, Ord name) => - (Hash -> m [a]) -> - Map name Reference.Id -> - (name -> Reference.Id -> a -> b) -> - m (Map name b) -componenty getComponent things modify = - Foldable.foldlM f Map.empty (foldMap (Set.singleton . Reference.idToHash) things) - where - f :: Map name b -> Hash -> m (Map name b) - f acc hash = - List.foldl' g acc . Reference.componentFor hash <$> getComponent hash - - g :: Map name b -> (Reference.Id, a) -> Map name b - g acc (ref, thing) = - Set.foldl' (h ref thing) acc (BiMultimap.lookupDom ref things2) +-- Merge precondition violation checks - h :: Reference.Id -> a -> Map name b -> name -> Map name b - h ref thing acc name = - Map.insert name (modify name ref thing) acc - - things2 :: BiMultimap Reference.Id name - things2 = - BiMultimap.fromRange things - -renderTermBinding :: (Monoid a, Var v) => PrettyPrintEnv -> Name -> Term v a -> Type v a -> Pretty ColorText -renderTermBinding ppe (HQ.NameOnly -> name) term typ = - Pretty.syntaxToColor rendered - where - rendered :: Pretty (SyntaxText' Reference) - rendered = - if Typechecker.isEqual (Builtin.Decls.testResultListType mempty) typ - then "test> " <> TermPrinter.prettyBindingWithoutTypeSignature ppe name term - else TermPrinter.prettyBinding ppe name term - -renderTypeBinding :: - (Var v) => - PrettyPrintEnvDecl -> - Name -> - TypeReferenceId -> - Decl v a -> - Writer (Set AccessorName) (Pretty ColorText) -renderTypeBinding ppe name ref decl = - Pretty.syntaxToColor <$> DeclPrinter.prettyDeclW ppe (Reference.fromId ref) (HQ.NameOnly name) decl - -setPpedToConstructorNames :: DeclNameLookup -> Name -> TypeReferenceId -> PrettyPrintEnvDecl -> PrettyPrintEnvDecl -setPpedToConstructorNames declNameLookup name ref = - set (#unsuffixifiedPPE . #termNames) referentNames - . set (#suffixifiedPPE . #termNames) referentNames - where - constructorNameMap :: Map ConstructorReference Name - constructorNameMap = - Map.fromList - ( name - & expectConstructorNames declNameLookup - & List.zip [0 ..] - & over (mapped . _1) (ConstructorReference (Reference.fromId ref)) - ) - - referentNames :: Referent -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)] - referentNames = \case - Referent.Con conRef _ -> - case Map.lookup conRef constructorNameMap of - Nothing -> [] - Just conName -> let hqConName = HQ'.NameOnly conName in [(hqConName, hqConName)] - Referent.Ref _ -> [] - -makePrettyUnisonFile :: - TwoWay Text -> - TwoWay (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)) -> - TwoWay (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)) -> - Pretty ColorText -makePrettyUnisonFile authors conflicts dependents = - fold - [ conflicts - -- Merge the two maps together into one, remembering who authored what - & TwoWay.twoWay (zipDefnsWith align align) - -- Sort alphabetically - & inAlphabeticalOrder - -- Render each conflict, types then terms (even though a type can conflict with a term, in which case they - -- would not be adjacent in the file), with an author comment above each conflicted thing - & ( let f = - foldMap \case - This x -> alice x - That y -> bob y - These x y -> alice x <> bob y - where - alice = prettyBinding (Just (Pretty.text authors.alice)) - bob = prettyBinding (Just (Pretty.text authors.bob)) - in bifoldMap f f - ), - -- Show message that delineates where conflicts end and dependents begin only when there are both conflicts and - -- dependents - let thereAre defns = TwoWay.or (not . defnsAreEmpty <$> defns) - in if thereAre conflicts && thereAre dependents - then - fold - [ "-- The definitions below are not conflicted, but they each depend on one or more\n", - "-- conflicted definitions above.\n\n" - ] - else mempty, - dependents - -- Merge dependents together into one map (they are disjoint) - & TwoWay.twoWay (zipDefnsWith Map.union Map.union) - -- Sort alphabetically - & inAlphabeticalOrder - -- Render each dependent, types then terms, without bothering to comment attribution - & (let f = foldMap (prettyBinding Nothing) in bifoldMap f f) - ] - where - prettyBinding maybeComment binding = - fold - [ case maybeComment of - Nothing -> mempty - Just comment -> "-- " <> comment <> "\n", - binding, - "\n", - "\n" - ] - - inAlphabeticalOrder :: DefnsF (Map Name) a b -> DefnsF [] a b - inAlphabeticalOrder = - bimap f f - where - f = map snd . List.sortOn (Name.toText . fst) . Map.toList +hasDefnsInLib :: (Applicative m) => V2.Branch m -> m Bool +hasDefnsInLib branch = do + libdeps <- + case Map.lookup NameSegment.libSegment branch.children of + Nothing -> pure V2.Branch.empty + Just libdeps -> libdeps.value + pure (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) ------------------------------------------------------------------------------------------------------------------------ -- --- Given just named term/type reference ids, fill out all names that occupy the term and type namespaces. This is simply --- the given names plus all of the types' constructors. --- --- For example, if the input is --- --- declNameLookup = { --- "Maybe" => ["Maybe.Nothing", "Maybe.Just"] --- } --- defns = { --- terms = { "foo" => #foo } --- types = { "Maybe" => #Maybe } --- } --- --- then the output is --- --- defns = { --- terms = { "foo", "Maybe.Nothing", "Maybe.Just" } --- types = { "Maybe" } --- } -refIdsToNames :: DeclNameLookup -> DefnsF (Map Name) term typ -> DefnsF Set Name Name -refIdsToNames declNameLookup = - bifoldMap goTerms goTypes - where - goTerms :: Map Name term -> DefnsF Set Name Name - goTerms terms = - Defns {terms = Map.keysSet terms, types = Set.empty} - - goTypes :: Map Name typ -> DefnsF Set Name Name - goTypes types = - Defns - { terms = foldMap (Set.fromList . expectConstructorNames declNameLookup) names, - types = names - } - where - names = Map.keysSet types - defnsAndLibdepsToBranch0 :: Codebase IO v a -> DefnsF (Map Name) Referent TypeReference -> @@ -683,7 +517,7 @@ defnsAndLibdepsToBranch0 codebase defns libdeps = let -- Unflatten the collection of terms into tree, ditto for types nametrees :: DefnsF2 Nametree (Map NameSegment) Referent TypeReference nametrees = - bimap go go defns + bimap unflattenNametree unflattenNametree defns -- Align the tree of terms and tree of types into one tree nametree :: Nametree (DefnsF (Map NameSegment) Referent TypeReference) @@ -702,10 +536,6 @@ defnsAndLibdepsToBranch0 codebase defns libdeps = -- Awkward: we have a Branch Transaction but we need a Branch IO (because reasons) branch2 = Branch.transform0 (Codebase.runTransaction codebase) branch1 in branch2 - where - go :: (Ord v) => Map Name v -> Nametree (Map NameSegment v) - go = - unflattenNametree . BiMultimap.fromRange nametreeToBranch0 :: Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> Branch0 m nametreeToBranch0 nametree = @@ -723,123 +553,6 @@ nametreeToBranch0 nametree = rel2star rel = Star2.Star2 {fact = Relation.dom rel, d1 = rel, d2 = Relation.empty} --- FIXME: let's come up with a better term for "dependencies" in the implementation of this function -identifyDependents :: - TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> - TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) -> - DefnsF Unconflicts Referent TypeReference -> - Transaction (TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId)) -identifyDependents defns conflicts unconflicts = do - let -- The other person's (i.e. with "Alice" and "Bob" swapped) solo-deleted and solo-updated names - theirSoloUpdatesAndDeletes :: TwoWay (DefnsF Set Name Name) - theirSoloUpdatesAndDeletes = - TwoWay.swap (unconflictedSoloDeletedNames <> unconflictedSoloUpdatedNames) - where - unconflictedSoloDeletedNames :: TwoWay (DefnsF Set Name Name) - unconflictedSoloDeletedNames = - bitraverse Unconflicts.soloDeletedNames Unconflicts.soloDeletedNames unconflicts - - unconflictedSoloUpdatedNames :: TwoWay (DefnsF Set Name Name) - unconflictedSoloUpdatedNames = - bitraverse Unconflicts.soloUpdatedNames Unconflicts.soloUpdatedNames unconflicts - - let dependencies :: TwoWay (Set Reference) - dependencies = - fold - [ -- One source of dependencies: Alice's versions of Bob's unconflicted deletes and updates, and vice-versa. - -- - -- This is name-based: if Bob updates the *name* "foo", then we go find the thing that Alice calls "foo" (if - -- anything), no matter what its hash is. - defnsReferences - <$> ( zipDefnsWith BiMultimap.restrictRan BiMultimap.restrictRan - <$> theirSoloUpdatesAndDeletes - <*> defns - ), - -- The other source of dependencies: Alice's own conflicted things, and ditto for Bob. - -- - -- An example: suppose Alice has foo#alice and Bob has foo#bob, so foo is conflicted. Furthermore, suppose - -- Alice has bar#bar that depends on foo#alice. - -- - -- We want Alice's #alice to be considered a dependency, so that when we go off and find dependents of these - -- dependencies to put in the scratch file for type checking and propagation, we find bar#bar. - -- - -- Note that this is necessary even if bar#bar is unconflicted! We don't want bar#bar to be put directly - -- into the namespace / parsing context for the conflicted merge, because it has an unnamed reference on - -- foo#alice. It rather ought to be in the scratchfile alongside the conflicted foo#alice and foo#bob, so - -- that when that conflict is resolved, it will propagate to bar. - let f :: (Foldable t) => t Reference.Id -> Set Reference - f = - List.foldl' (\acc ref -> Set.insert (Reference.DerivedId ref) acc) Set.empty . Foldable.toList - in bifoldMap f f <$> conflicts - ] - - dependents0 <- - for ((,) <$> defns <*> dependencies) \(defns1, dependencies1) -> - getNamespaceDependentsOf2 defns1 dependencies1 - - -- There is some subset of Alice's dependents (and ditto for Bob of course) that we don't ultimately want/need to put - -- into the scratch file: those for which any of the following are true: - -- - -- 1. It is Alice-conflicted (since we only want to return *unconflicted* things). - -- 2. It was deleted by Bob. - -- 3. It was updated by Bob and not updated by Alice. - let dependents1 :: TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) - dependents1 = - zipDefnsWith Map.withoutKeys Map.withoutKeys - <$> dependents0 - <*> ((bimap Map.keysSet Map.keysSet <$> conflicts) <> theirSoloUpdatesAndDeletes) - - -- Of the remaining dependents, it's still possible that the maps are not disjoint. But whenever the same name key - -- exists in Alice's and Bob's dependents, the value will either be equal (by Unison hash)... - -- - -- { alice = { terms = {"foo" => #alice} } } - -- { bob = { terms = {"foo" => #alice} } } - -- - -- ...or synhash-equal (i.e. the term or type received different auto-propagated updates)... - -- - -- { alice = { terms = {"foo" => #alice} } } - -- { bob = { terms = {"foo" => #bob} } } - -- - -- So, we can arbitrarily keep Alice's, because they will render the same. - -- - -- { alice = { terms = {"foo" => #alice} } } - -- { bob = { terms = {} } } - let dependents2 :: TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) - dependents2 = - dependents1 & over #bob \bob -> - zipDefnsWith Map.difference Map.difference bob dependents1.alice - - pure dependents2 - -makeStageOne :: - TwoWay DeclNameLookup -> - TwoWay (DefnsF (Map Name) termid typeid) -> - DefnsF Unconflicts term typ -> - TwoWay (DefnsF (Map Name) termid typeid) -> - DefnsF (Map Name) term typ -> - DefnsF (Map Name) term typ -makeStageOne declNameLookups conflicts unconflicts dependents = - zipDefnsWith3 makeStageOneV makeStageOneV unconflicts (f conflicts <> f dependents) - where - f :: TwoWay (DefnsF (Map Name) term typ) -> DefnsF Set Name Name - f defns = - fold (refIdsToNames <$> declNameLookups <*> defns) - -makeStageOneV :: Unconflicts v -> Set Name -> Map Name v -> Map Name v -makeStageOneV unconflicts namesToDelete = - (`Map.withoutKeys` namesToDelete) . Unconflicts.apply unconflicts - -defnsReferences :: Defns (BiMultimap Referent name) (BiMultimap TypeReference name) -> Set Reference -defnsReferences = - bifoldMap (Set.map Referent.toReference . BiMultimap.dom) BiMultimap.dom - -defnsToNames :: Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> Names -defnsToNames defns = - Names.Names - { terms = Relation.fromMap (BiMultimap.range defns.terms), - types = Relation.fromMap (BiMultimap.range defns.types) - } - findTemporaryBranchName :: ProjectId -> MergeSourceAndTarget -> Transaction ProjectBranchName findTemporaryBranchName projectId mergeSourceAndTarget = do ProjectUtils.findTemporaryBranchName projectId preferred @@ -853,26 +566,27 @@ findTemporaryBranchName projectId mergeSourceAndTarget = do <> "-into-" <> mangleBranchName mergeSourceAndTarget.alice.branch - mangleMergeSource :: MergeSource -> Text.Builder - mangleMergeSource = \case - MergeSource'LocalProjectBranch (ProjectAndBranch _project branch) -> mangleBranchName branch - MergeSource'RemoteProjectBranch (ProjectAndBranch _project branch) -> "remote-" <> mangleBranchName branch - MergeSource'RemoteLooseCode info -> manglePath info.path - mangleBranchName :: ProjectBranchName -> Text.Builder - mangleBranchName name = - case classifyProjectBranchName name of - ProjectBranchNameKind'Contributor user name1 -> - Text.Builder.text user - <> Text.Builder.char '-' - <> mangleBranchName name1 - ProjectBranchNameKind'DraftRelease semver -> "releases-drafts-" <> mangleSemver semver - ProjectBranchNameKind'Release semver -> "releases-" <> mangleSemver semver - ProjectBranchNameKind'NothingSpecial -> Text.Builder.text (into @Text name) - +mangleMergeSource :: MergeSource -> Text.Builder +mangleMergeSource = \case + MergeSource'LocalProjectBranch (ProjectAndBranch _project branch) -> mangleBranchName branch + MergeSource'RemoteProjectBranch (ProjectAndBranch _project branch) -> "remote-" <> mangleBranchName branch + MergeSource'RemoteLooseCode info -> manglePath info.path + where manglePath :: Path -> Text.Builder manglePath = Monoid.intercalateMap "-" (Text.Builder.text . NameSegment.toUnescapedText) . Path.toList +mangleBranchName :: ProjectBranchName -> Text.Builder +mangleBranchName name = + case classifyProjectBranchName name of + ProjectBranchNameKind'Contributor user name1 -> + Text.Builder.text user + <> Text.Builder.char '-' + <> mangleBranchName name1 + ProjectBranchNameKind'DraftRelease semver -> "releases-drafts-" <> mangleSemver semver + ProjectBranchNameKind'Release semver -> "releases-" <> mangleSemver semver + ProjectBranchNameKind'NothingSpecial -> Text.Builder.text (into @Text name) + where mangleSemver :: Semver -> Text.Builder mangleSemver (Semver x y z) = Text.Builder.decimal x @@ -881,192 +595,118 @@ findTemporaryBranchName projectId mergeSourceAndTarget = do <> Text.Builder.char '.' <> Text.Builder.decimal z --- Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined --- in the "lib" namespace. --- --- Fails if there is a conflicted name. -loadNamespaceDefinitions :: - forall m. - (Monad m) => - (V2.Referent -> m Referent) -> - V2.Branch m -> - m (Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference))) -loadNamespaceDefinitions referent2to1 = - fmap assertNamespaceHasNoConflictedNames . go (Map.delete NameSegment.libSegment) - where - go :: - (forall x. Map NameSegment x -> Map NameSegment x) -> - V2.Branch m -> - m (Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference)) - go f branch = do - terms <- for branch.terms (fmap (Set.NonEmpty.fromList . List.NonEmpty.fromList) . traverse referent2to1 . Map.keys) - let types = Map.map (Set.NonEmpty.unsafeFromSet . Map.keysSet) branch.types - children <- - for (f branch.children) \childCausal -> do - child <- childCausal.value - go id child - pure Nametree {value = Defns {terms, types}, children} - -data ConflictedName - = ConflictedName'Term !Name !(NESet Referent) - | ConflictedName'Type !Name !(NESet TypeReference) - --- | Assert that there are no unconflicted names in a namespace. -assertNamespaceHasNoConflictedNames :: - Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference) -> - Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -assertNamespaceHasNoConflictedNames = - traverseNametreeWithName \names defns -> do - terms <- - defns.terms & Map.traverseWithKey \name -> - assertUnconflicted (ConflictedName'Term (Name.fromReverseSegments (name :| names))) - types <- - defns.types & Map.traverseWithKey \name -> - assertUnconflicted (ConflictedName'Type (Name.fromReverseSegments (name :| names))) - pure Defns {terms, types} - where - assertUnconflicted :: (NESet ref -> ConflictedName) -> NESet ref -> Either ConflictedName ref - assertUnconflicted conflicted refs - | Set.NonEmpty.size refs == 1 = Right (Set.NonEmpty.findMin refs) - | otherwise = Left (conflicted refs) - --- @findConflictedAlias namespace diff@, given an old namespace and a diff to a new namespace, will return the first --- "conflicted alias" encountered (if any), where a "conflicted alias" is a pair of names that referred to the same --- thing in the old namespace, but different things in the new one. --- --- For example, if the old namespace was --- --- foo = #foo --- bar = #foo --- --- and the new namespace is --- --- foo = #baz --- bar = #qux --- --- then (foo, bar) is a conflicted alias. --- --- This function currently doesn't return whether the conflicted alias is a decl or a term, but it certainly could. -findConflictedAlias :: - (Ord term, Ord typ) => - Defns (BiMultimap term Name) (BiMultimap typ Name) -> - DefnsF3 (Map Name) DiffOp Synhashed term typ -> - Maybe (Name, Name) -findConflictedAlias defns diff = - asum [go defns.terms diff.terms, go defns.types diff.types] +typecheckedUnisonFileToBranchAdds :: TypecheckedUnisonFile Symbol Ann -> [(Path, Branch0 m -> Branch0 m)] +typecheckedUnisonFileToBranchAdds tuf = do + declAdds ++ termAdds where - go :: forall ref. (Ord ref) => BiMultimap ref Name -> Map Name (DiffOp (Synhashed ref)) -> Maybe (Name, Name) - go namespace diff = - asum (map f (Map.toList diff)) + declAdds :: [(Path, Branch0 m -> Branch0 m)] + declAdds = do + foldMap makeDataDeclAdds (Map.toList (UnisonFile.dataDeclarationsId' tuf)) + ++ foldMap makeEffectDeclUpdates (Map.toList (UnisonFile.effectDeclarationsId' tuf)) where - f :: (Name, DiffOp (Synhashed ref)) -> Maybe (Name, Name) - f (name, op) = - case op of - DiffOp'Add _ -> Nothing - DiffOp'Delete _ -> Nothing - DiffOp'Update hashed1 -> - BiMultimap.lookupPreimage name namespace - & Set.delete name - & Set.toList - & map (g hashed1.new) - & asum - where - g :: Synhashed ref -> Name -> Maybe (Name, Name) - g hashed1 alias = - case Map.lookup alias diff of - Just (DiffOp'Update hashed2) | hashed1 == hashed2.new -> Nothing - -- If "foo" was updated but its alias "bar" was deleted, that's ok - Just (DiffOp'Delete _) -> Nothing - _ -> Just (name, alias) - --- Given a name like "base", try "base__1", then "base__2", etc, until we find a name that doesn't --- clash with any existing dependencies. -getTwoFreshNames :: Set NameSegment -> NameSegment -> (NameSegment, NameSegment) -getTwoFreshNames names name0 = - go2 0 + makeDataDeclAdds (symbol, (typeRefId, dataDecl)) = makeDeclAdds (symbol, (typeRefId, Right dataDecl)) + makeEffectDeclUpdates (symbol, (typeRefId, effectDecl)) = makeDeclAdds (symbol, (typeRefId, Left effectDecl)) + + makeDeclAdds :: (Symbol, (TypeReferenceId, Decl Symbol Ann)) -> [(Path, Branch0 m -> Branch0 m)] + makeDeclAdds (symbol, (typeRefId, decl)) = + let insertTypeAction = BranchUtil.makeAddTypeName (splitVar symbol) (Reference.fromId typeRefId) + insertTypeConstructorActions = + zipWith + (\sym rid -> BranchUtil.makeAddTermName (splitVar sym) (Reference.fromId <$> rid)) + (DataDeclaration.constructorVars (DataDeclaration.asDataDecl decl)) + (DataDeclaration.declConstructorReferents typeRefId decl) + in insertTypeAction : insertTypeConstructorActions + + termAdds :: [(Path, Branch0 m -> Branch0 m)] + termAdds = + tuf + & UnisonFile.hashTermsId + & Map.toList + & mapMaybe \(var, (_, ref, wk, _, _)) -> do + guard (WatchKind.watchKindShouldBeStoredInDatabase wk) + Just (BranchUtil.makeAddTermName (splitVar var) (Referent.fromTermReferenceId ref)) + + splitVar :: Symbol -> Path.Split + splitVar = Path.splitFromName . Name.unsafeParseVar + +------------------------------------------------------------------------------------------------------------------------ +-- Making file with conflict markers + +makeMergedFileContents :: MergeSourceAndTarget -> Text -> Text -> Text +makeMergedFileContents sourceAndTarget aliceContents bobContents = + let f :: (Text.Builder, Diff.Diff Text) -> Diff.Diff Text -> (Text.Builder, Diff.Diff Text) + f (acc, previous) line = + case (previous, line) of + (Diff.Both {}, Diff.Both bothLine _) -> go (Text.Builder.text bothLine) + (Diff.Both {}, Diff.First aliceLine) -> go (aliceSlug <> Text.Builder.text aliceLine) + (Diff.Both {}, Diff.Second bobLine) -> go (aliceSlug <> middleSlug <> Text.Builder.text bobLine) + (Diff.First {}, Diff.Both bothLine _) -> go (middleSlug <> bobSlug <> Text.Builder.text bothLine) + (Diff.First {}, Diff.First aliceLine) -> go (Text.Builder.text aliceLine) + (Diff.First {}, Diff.Second bobLine) -> go (middleSlug <> Text.Builder.text bobLine) + (Diff.Second {}, Diff.Both bothLine _) -> go (bobSlug <> Text.Builder.text bothLine) + (Diff.Second {}, Diff.First aliceLine) -> go (bobSlug <> aliceSlug <> Text.Builder.text aliceLine) + (Diff.Second {}, Diff.Second bobLine) -> go (Text.Builder.text bobLine) + where + go content = + let !acc1 = acc <> content <> newline + in (acc1, line) + in Diff.getDiff (Text.lines aliceContents) (Text.lines bobContents) + & List.foldl' f (mempty @Text.Builder, Diff.Both Text.empty Text.empty) + & fst + & Text.Builder.run where - -- if - -- name0 = "base" - -- names = {"base__5", "base__6"} - -- then - -- go2 4 = ("base__4", "base__7") - go2 :: Integer -> (NameSegment, NameSegment) - go2 !i - | Set.member name names = go2 (i + 1) - | otherwise = (name, go1 (i + 1)) - where - name = mangled i - - -- if - -- name0 = "base" - -- names = {"base__5", "base__6"} - -- then - -- go1 5 = "base__7" - go1 :: Integer -> NameSegment - go1 !i - | Set.member name names = go1 (i + 1) - | otherwise = name - where - name = mangled i - - mangled :: Integer -> NameSegment - mangled i = - NameSegment (NameSegment.toUnescapedText name0 <> "__" <> tShow i) - -libdepsToBranch0 :: MergeDatabase -> Map NameSegment (V2.CausalBranch Transaction) -> Transaction (Branch0 Transaction) -libdepsToBranch0 db libdeps = do - let branch :: V2.Branch Transaction - branch = - V2.Branch - { terms = Map.empty, - types = Map.empty, - patches = Map.empty, - children = libdeps - } - - -- We make a fresh branch cache to load the branch of libdeps. - -- It would probably be better to reuse the codebase's branch cache. - -- FIXME how slow/bad is this without that branch cache? - branchCache <- Sqlite.unsafeIO newBranchCache - Conversions.branch2to1 branchCache db.loadDeclType branch + aliceSlug :: Text.Builder + aliceSlug = + "<<<<<<< " <> Text.Builder.text (into @Text sourceAndTarget.alice.branch) <> newline + + middleSlug :: Text.Builder + middleSlug = "=======\n" + + bobSlug :: Text.Builder + bobSlug = + ">>>>>>> " + <> ( case sourceAndTarget.bob of + MergeSource'LocalProjectBranch bobProjectAndBranch -> + Text.Builder.text (into @Text bobProjectAndBranch.branch) + MergeSource'RemoteProjectBranch bobProjectAndBranch -> + "remote " <> Text.Builder.text (into @Text bobProjectAndBranch.branch) + MergeSource'RemoteLooseCode info -> + case Path.toName info.path of + Nothing -> "" + Just name -> Text.Builder.text (Name.toText name) + ) + <> newline + + newline :: Text.Builder + newline = "\n" ------------------------------------------------------------------------------------------------------------------------ -- Debugging by printing a bunch of stuff out data DebugFunctions = DebugFunctions - { debugCausals :: TwoOrThreeWay (V2.CausalBranch Transaction) -> IO (), - debugDefns :: - ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> - TwoWay DeclNameLookup -> - Map Name [Maybe Name] -> - IO (), - debugDiffs :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> IO (), - debugCombinedDiff :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO (), + { debugCausals :: Merge.TwoOrThreeWay (V2.CausalBranch Transaction) -> IO (), + debugDiffs :: Merge.TwoWay (DefnsF3 (Map Name) Merge.DiffOp Merge.Synhashed Referent TypeReference) -> IO (), + debugCombinedDiff :: DefnsF2 (Map Name) Merge.CombinedDiffOp Referent TypeReference -> IO (), debugPartitionedDiff :: - TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) -> - DefnsF Unconflicts Referent TypeReference -> - IO (), - debugDependents :: TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) -> IO (), - debugStageOne :: DefnsF (Map Name) Referent TypeReference -> IO () + Merge.TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) -> + DefnsF Merge.Unconflicts Referent TypeReference -> + IO () } realDebugFunctions :: DebugFunctions realDebugFunctions = DebugFunctions { debugCausals = realDebugCausals, - debugDefns = realDebugDefns, debugDiffs = realDebugDiffs, debugCombinedDiff = realDebugCombinedDiff, - debugPartitionedDiff = realDebugPartitionedDiff, - debugDependents = realDebugDependents, - debugStageOne = realDebugStageOne + debugPartitionedDiff = realDebugPartitionedDiff } fakeDebugFunctions :: DebugFunctions fakeDebugFunctions = - DebugFunctions mempty mempty mempty mempty mempty mempty mempty + DebugFunctions mempty mempty mempty mempty -realDebugCausals :: TwoOrThreeWay (V2.CausalBranch Transaction) -> IO () +realDebugCausals :: Merge.TwoOrThreeWay (V2.CausalBranch Transaction) -> IO () realDebugCausals causals = do Text.putStrLn (Text.bold "\n=== Alice causal hash ===") Text.putStrLn (Hash.toBase32HexText (unCausalHash causals.alice.causalHash)) @@ -1077,37 +717,19 @@ realDebugCausals causals = do Nothing -> "Nothing" Just causal -> "Just " <> Hash.toBase32HexText (unCausalHash causal.causalHash) -realDebugDefns :: - ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> - TwoWay DeclNameLookup -> - Map Name [Maybe Name] -> - IO () -realDebugDefns defns declNameLookups _lcaDeclNameLookup = do - Text.putStrLn (Text.bold "\n=== Alice definitions ===") - debugDefns1 (bimap BiMultimap.range BiMultimap.range defns.alice) - - Text.putStrLn (Text.bold "\n=== Bob definitions ===") - debugDefns1 (bimap BiMultimap.range BiMultimap.range defns.bob) - - Text.putStrLn (Text.bold "\n=== Alice constructor names ===") - debugConstructorNames declNameLookups.alice.declToConstructors - - Text.putStrLn (Text.bold "\n=== Bob constructor names ===") - debugConstructorNames declNameLookups.bob.declToConstructors - -realDebugDiffs :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> IO () +realDebugDiffs :: Merge.TwoWay (DefnsF3 (Map Name) Merge.DiffOp Merge.Synhashed Referent TypeReference) -> IO () realDebugDiffs diffs = do Text.putStrLn (Text.bold "\n=== LCA→Alice diff ===") renderDiff diffs.alice Text.putStrLn (Text.bold "\n=== LCA→Bob diff ===") renderDiff diffs.bob where - renderDiff :: DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference -> IO () + renderDiff :: DefnsF3 (Map Name) Merge.DiffOp Merge.Synhashed Referent TypeReference -> IO () renderDiff diff = do renderThings referentLabel diff.terms renderThings (const "type") diff.types - renderThings :: (ref -> Text) -> Map Name (DiffOp (Synhashed ref)) -> IO () + renderThings :: (ref -> Text) -> Map Name (Merge.DiffOp (Merge.Synhashed ref)) -> IO () renderThings label things = for_ (Map.toList things) \(name, op) -> let go color action x = @@ -1120,21 +742,21 @@ realDebugDiffs diffs = do <> " #" <> Hash.toBase32HexText (Synhashed.hash x) in Text.putStrLn case op of - DiffOp'Add x -> go Text.green "+" x - DiffOp'Delete x -> go Text.red "-" x - DiffOp'Update x -> go Text.yellow "%" x.new + Merge.DiffOp'Add x -> go Text.green "+" x + Merge.DiffOp'Delete x -> go Text.red "-" x + Merge.DiffOp'Update x -> go Text.yellow "%" x.new -realDebugCombinedDiff :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO () +realDebugCombinedDiff :: DefnsF2 (Map Name) Merge.CombinedDiffOp Referent TypeReference -> IO () realDebugCombinedDiff diff = do Text.putStrLn (Text.bold "\n=== Combined diff ===") renderThings referentLabel Referent.toText diff.terms renderThings (const "type") Reference.toText diff.types where - renderThings :: (ref -> Text) -> (ref -> Text) -> Map Name (CombinedDiffOp ref) -> IO () + renderThings :: (ref -> Text) -> (ref -> Text) -> Map Name (Merge.CombinedDiffOp ref) -> IO () renderThings label renderRef things = for_ (Map.toList things) \(name, op) -> Text.putStrLn case op of - CombinedDiffOp'Add who -> + Merge.CombinedDiffOp'Add who -> Text.green $ "+ " <> Text.italic (label (EitherWayI.value who)) @@ -1145,7 +767,7 @@ realDebugCombinedDiff diff = do <> " (" <> renderWho who <> ")" - CombinedDiffOp'Delete who -> + Merge.CombinedDiffOp'Delete who -> Text.red $ "- " <> Text.italic (label (EitherWayI.value who)) @@ -1156,7 +778,7 @@ realDebugCombinedDiff diff = do <> " (" <> renderWho who <> ")" - CombinedDiffOp'Update who -> + Merge.CombinedDiffOp'Update who -> Text.yellow $ "% " <> Text.italic (label (EitherWayI.value who).new) @@ -1167,7 +789,7 @@ realDebugCombinedDiff diff = do <> " (" <> renderWho who <> ")" - CombinedDiffOp'Conflict ref -> + Merge.CombinedDiffOp'Conflict ref -> Text.magenta $ "! " <> Text.italic (label ref.alice) @@ -1180,50 +802,50 @@ realDebugCombinedDiff diff = do <> "/" <> renderRef ref.bob - renderWho :: EitherWayI v -> Text + renderWho :: Merge.EitherWayI v -> Text renderWho = \case - OnlyAlice _ -> "Alice" - OnlyBob _ -> "Bob" - AliceAndBob _ -> "Alice and Bob" + Merge.OnlyAlice _ -> "Alice" + Merge.OnlyBob _ -> "Bob" + Merge.AliceAndBob _ -> "Alice and Bob" realDebugPartitionedDiff :: - TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) -> - DefnsF Unconflicts Referent TypeReference -> + Merge.TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) -> + DefnsF Merge.Unconflicts Referent TypeReference -> IO () realDebugPartitionedDiff conflicts unconflicts = do Text.putStrLn (Text.bold "\n=== Alice conflicts ===") - renderConflicts "termid" conflicts.alice.terms (Alice ()) - renderConflicts "typeid" conflicts.alice.types (Alice ()) + renderConflicts "termid" conflicts.alice.terms (Merge.Alice ()) + renderConflicts "typeid" conflicts.alice.types (Merge.Alice ()) Text.putStrLn (Text.bold "\n=== Bob conflicts ===") - renderConflicts "termid" conflicts.bob.terms (Bob ()) - renderConflicts "typeid" conflicts.bob.types (Bob ()) + renderConflicts "termid" conflicts.bob.terms (Merge.Bob ()) + renderConflicts "typeid" conflicts.bob.types (Merge.Bob ()) Text.putStrLn (Text.bold "\n=== Alice unconflicts ===") - renderUnconflicts Text.green "+" referentLabel Referent.toText unconflicts.terms.adds.alice (OnlyAlice ()) - renderUnconflicts Text.green "+" (const "type") Reference.toText unconflicts.types.adds.alice (OnlyAlice ()) - renderUnconflicts Text.red "-" referentLabel Referent.toText unconflicts.terms.deletes.alice (OnlyAlice ()) - renderUnconflicts Text.red "-" (const "type") Reference.toText unconflicts.types.deletes.alice (OnlyAlice ()) - renderUnconflicts Text.yellow "%" referentLabel Referent.toText unconflicts.terms.updates.alice (OnlyAlice ()) - renderUnconflicts Text.yellow "%" (const "type") Reference.toText unconflicts.types.updates.alice (OnlyAlice ()) + renderUnconflicts Text.green "+" referentLabel Referent.toText unconflicts.terms.adds.alice + renderUnconflicts Text.green "+" (const "type") Reference.toText unconflicts.types.adds.alice + renderUnconflicts Text.red "-" referentLabel Referent.toText unconflicts.terms.deletes.alice + renderUnconflicts Text.red "-" (const "type") Reference.toText unconflicts.types.deletes.alice + renderUnconflicts Text.yellow "%" referentLabel Referent.toText unconflicts.terms.updates.alice + renderUnconflicts Text.yellow "%" (const "type") Reference.toText unconflicts.types.updates.alice Text.putStrLn (Text.bold "\n=== Bob unconflicts ===") - renderUnconflicts Text.green "+" referentLabel Referent.toText unconflicts.terms.adds.bob (OnlyBob ()) - renderUnconflicts Text.green "+" (const "type") Reference.toText unconflicts.types.adds.bob (OnlyBob ()) - renderUnconflicts Text.red "-" referentLabel Referent.toText unconflicts.terms.deletes.bob (OnlyBob ()) - renderUnconflicts Text.red "-" (const "type") Reference.toText unconflicts.types.deletes.bob (OnlyBob ()) - renderUnconflicts Text.yellow "%" referentLabel Referent.toText unconflicts.terms.updates.bob (OnlyBob ()) - renderUnconflicts Text.yellow "%" (const "type") Reference.toText unconflicts.types.updates.bob (OnlyBob ()) + renderUnconflicts Text.green "+" referentLabel Referent.toText unconflicts.terms.adds.bob + renderUnconflicts Text.green "+" (const "type") Reference.toText unconflicts.types.adds.bob + renderUnconflicts Text.red "-" referentLabel Referent.toText unconflicts.terms.deletes.bob + renderUnconflicts Text.red "-" (const "type") Reference.toText unconflicts.types.deletes.bob + renderUnconflicts Text.yellow "%" referentLabel Referent.toText unconflicts.terms.updates.bob + renderUnconflicts Text.yellow "%" (const "type") Reference.toText unconflicts.types.updates.bob Text.putStrLn (Text.bold "\n=== Alice-and-Bob unconflicts ===") - renderUnconflicts Text.green "+" referentLabel Referent.toText unconflicts.terms.adds.both (AliceAndBob ()) - renderUnconflicts Text.green "+" (const "type") Reference.toText unconflicts.types.adds.both (AliceAndBob ()) - renderUnconflicts Text.red "-" referentLabel Referent.toText unconflicts.terms.deletes.both (AliceAndBob ()) - renderUnconflicts Text.red "-" (const "type") Reference.toText unconflicts.types.deletes.both (AliceAndBob ()) - renderUnconflicts Text.yellow "%" referentLabel Referent.toText unconflicts.terms.updates.both (AliceAndBob ()) - renderUnconflicts Text.yellow "%" (const "type") Reference.toText unconflicts.types.updates.both (AliceAndBob ()) + renderUnconflicts Text.green "+" referentLabel Referent.toText unconflicts.terms.adds.both + renderUnconflicts Text.green "+" (const "type") Reference.toText unconflicts.types.adds.both + renderUnconflicts Text.red "-" referentLabel Referent.toText unconflicts.terms.deletes.both + renderUnconflicts Text.red "-" (const "type") Reference.toText unconflicts.types.deletes.both + renderUnconflicts Text.yellow "%" referentLabel Referent.toText unconflicts.terms.updates.both + renderUnconflicts Text.yellow "%" (const "type") Reference.toText unconflicts.types.updates.both where - renderConflicts :: Text -> Map Name Reference.Id -> EitherWay () -> IO () + renderConflicts :: Text -> Map Name Reference.Id -> Merge.EitherWay () -> IO () renderConflicts label conflicts who = for_ (Map.toList conflicts) \(name, ref) -> Text.putStrLn $ @@ -1235,7 +857,7 @@ realDebugPartitionedDiff conflicts unconflicts = do <> " " <> Reference.idToText ref <> " (" - <> (case who of Alice () -> "Alice"; Bob () -> "Bob") + <> (case who of Merge.Alice () -> "Alice"; Merge.Bob () -> "Bob") <> ")" renderUnconflicts :: @@ -1244,9 +866,8 @@ realDebugPartitionedDiff conflicts unconflicts = do (ref -> Text) -> (ref -> Text) -> Map Name ref -> - EitherWayI () -> IO () - renderUnconflicts color action label renderRef unconflicts who = + renderUnconflicts color action label renderRef unconflicts = for_ (Map.toList unconflicts) \(name, ref) -> Text.putStrLn $ color $ @@ -1257,48 +878,6 @@ realDebugPartitionedDiff conflicts unconflicts = do <> Name.toText name <> " " <> renderRef ref - <> " (" - <> (case who of OnlyAlice () -> "Alice"; OnlyBob () -> "Bob"; AliceAndBob () -> "Alice and Bob") - <> ")" - -realDebugDependents :: TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) -> IO () -realDebugDependents dependents = do - Text.putStrLn (Text.bold "\n=== Alice dependents of Bob deletes, Bob updates, and Alice conflicts ===") - renderThings "termid" dependents.alice.terms - renderThings "typeid" dependents.alice.types - Text.putStrLn (Text.bold "\n=== Bob dependents of Alice deletes, Alice updates, and Bob conflicts ===") - renderThings "termid" dependents.bob.terms - renderThings "typeid" dependents.bob.types - where - renderThings :: Text -> Map Name Reference.Id -> IO () - renderThings label things = - for_ (Map.toList things) \(name, ref) -> - Text.putStrLn $ - Text.italic label - <> " " - <> Name.toText name - <> " " - <> Reference.idToText ref - -realDebugStageOne :: DefnsF (Map Name) Referent TypeReference -> IO () -realDebugStageOne defns = do - Text.putStrLn (Text.bold "\n=== Stage 1 ===") - debugDefns1 defns - -debugConstructorNames :: Map Name [Name] -> IO () -debugConstructorNames names = - for_ (Map.toList names) \(typeName, conNames) -> - Text.putStrLn (Name.toText typeName <> " => " <> Text.intercalate ", " (map Name.toText conNames)) - -debugDefns1 :: DefnsF (Map Name) Referent TypeReference -> IO () -debugDefns1 defns = do - renderThings referentLabel Referent.toText defns.terms - renderThings (const "type") Reference.toText defns.types - where - renderThings :: (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO () - renderThings label renderRef things = - for_ (Map.toList things) \(name, ref) -> - Text.putStrLn (Text.italic (label ref) <> " " <> Name.toText name <> " " <> renderRef ref) referentLabel :: Referent -> Text referentLabel ref diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs index 77b4bc8514..d7b926e8fe 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs @@ -8,7 +8,7 @@ import Unison.Codebase.Editor.HandleInput.MoveTerm (moveTermSteps) import Unison.Codebase.Editor.HandleInput.MoveType (moveTypeSteps) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Prelude handleMoveAll :: Bool -> Path.Path' -> Path.Path' -> Text -> Cli () @@ -23,5 +23,6 @@ handleMoveAll hasConfirmed src' dest' description = do case (moveBranchFunc, moveTermTypeSteps) of (Nothing, []) -> Cli.respond (Output.MoveNothingFound src') (mupdates, steps) -> do - Cli.updateAndStepAt description (maybeToList mupdates) steps + pp <- Cli.getCurrentProjectPath + Cli.updateAndStepAt description (pp ^. #branch) (maybeToList mupdates) steps Cli.respond Output.Success diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs index 21b41511b0..eb6b3effbf 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs @@ -7,17 +7,21 @@ import Unison.Codebase.Branch (Branch) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.Output (Output (..)) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Prelude +-- | Note: Currently only allows moving within the same project-branch, should be easy to change in the future if +-- needed. moveBranchFunc :: Bool -> Path.Path' -> Path.Path' -> Cli (Maybe (Path.Absolute, Branch IO -> Branch IO)) moveBranchFunc hasConfirmed src' dest' = do - srcAbs <- Cli.resolvePath' src' - destAbs <- Cli.resolvePath' dest' + -- We currently only support moving within the same project branch. + srcPP@(PP.ProjectPath _proj _projBranch srcAbs) <- Cli.resolvePath' src' + PP.ProjectPath _ _ destAbs <- Cli.resolvePath' dest' destBranchExists <- Cli.branchExistsAtPath' dest' let isRootMove = (Path.isRoot srcAbs || Path.isRoot destAbs) when (isRootMove && not hasConfirmed) do Cli.returnEarly MoveRootBranchConfirmation - Cli.getMaybeBranchAt srcAbs >>= traverse \srcBranch -> do + Cli.getMaybeBranchFromProjectPath srcPP >>= traverse \srcBranch -> do -- We want the move to appear as a single step in the root namespace, but we need to make -- surgical changes in both the root and the destination, so we make our modifications at the shared parent of -- those changes such that they appear as a single change in the root. @@ -37,6 +41,7 @@ doMoveBranch :: Text -> Bool -> Path.Path' -> Path.Path' -> Cli () doMoveBranch actionDescription hasConfirmed src' dest' = do moveBranchFunc hasConfirmed src' dest' >>= \case Nothing -> Cli.respond (BranchNotFound src') - Just (path, func) -> do - _ <- Cli.updateAt actionDescription path func + Just (absPath, func) -> do + pp <- Cli.resolvePath' (Path.AbsolutePath' absPath) + _ <- Cli.updateAt actionDescription pp func Cli.respond Success diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs index 374e58ac56..e8dbde0229 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs @@ -1,6 +1,6 @@ module Unison.Codebase.Editor.HandleInput.MoveTerm (doMoveTerm, moveTermSteps) where -import Control.Lens (_2) +import Control.Lens (_1, _2) import Data.Set qualified as Set import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -9,13 +9,14 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.BranchUtil qualified as BranchUtil import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path (Path, Path') +import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path -import Unison.HashQualified' qualified as HQ' +import Unison.Codebase.ProjectPath qualified as PP +import Unison.HashQualifiedPrime qualified as HQ' import Unison.NameSegment (NameSegment) import Unison.Prelude -moveTermSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path, Branch0 m -> Branch0 m)] +moveTermSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path.Absolute, Branch0 m -> Branch0 m)] moveTermSteps src' dest' = do src <- Cli.resolveSplit' src' srcTerms <- Cli.getTermsAt src @@ -26,14 +27,14 @@ moveTermSteps src' dest' = do Cli.returnEarly (Output.DeleteNameAmbiguous hqLength src' srcTerms Set.empty) [srcTerm] -> do dest <- Cli.resolveSplit' dest' - destTerms <- Cli.getTermsAt (Path.convert dest) + destTerms <- Cli.getTermsAt (HQ'.NameOnly <$> dest) when (not (Set.null destTerms)) do Cli.returnEarly (Output.TermAlreadyExists dest' destTerms) - let p = Path.convert src + let p = src & _1 %~ view PP.absPath_ pure [ -- Mitchell: throwing away any hash-qualification here seems wrong! BranchUtil.makeDeleteTermName (over _2 HQ'.toName p) srcTerm, - BranchUtil.makeAddTermName (Path.convert dest) srcTerm + BranchUtil.makeAddTermName (over _1 (view PP.absPath_) dest) srcTerm ] doMoveTerm :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli () @@ -41,5 +42,6 @@ doMoveTerm src' dest' description = do steps <- moveTermSteps src' dest' when (null steps) do Cli.returnEarly (Output.TermNotFound src') - Cli.stepManyAt description steps + pb <- Cli.getCurrentProjectBranch + Cli.stepManyAt pb description steps Cli.respond Output.Success diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs index 95f3ba09b5..9c6125c205 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs @@ -1,6 +1,6 @@ module Unison.Codebase.Editor.HandleInput.MoveType (doMoveType, moveTypeSteps) where -import Control.Lens (_2) +import Control.Lens (_1, _2) import Data.Set qualified as Set import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -9,13 +9,14 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.BranchUtil qualified as BranchUtil import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path (Path, Path') +import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path -import Unison.HashQualified' qualified as HQ' +import Unison.Codebase.ProjectPath qualified as PP +import Unison.HashQualifiedPrime qualified as HQ' import Unison.NameSegment (NameSegment) import Unison.Prelude -moveTypeSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path, Branch0 m -> Branch0 m)] +moveTypeSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path.Absolute, Branch0 m -> Branch0 m)] moveTypeSteps src' dest' = do src <- Cli.resolveSplit' src' srcTypes <- Cli.getTypesAt src @@ -26,14 +27,14 @@ moveTypeSteps src' dest' = do Cli.returnEarly (Output.DeleteNameAmbiguous hqLength src' Set.empty srcTypes) [srcType] -> do dest <- Cli.resolveSplit' dest' - destTypes <- Cli.getTypesAt (Path.convert dest) + destTypes <- Cli.getTypesAt (HQ'.NameOnly <$> dest) when (not (Set.null destTypes)) do Cli.returnEarly (Output.TypeAlreadyExists dest' destTypes) - let p = Path.convert src + let p = over _1 (view PP.absPath_) src pure [ -- Mitchell: throwing away any hash-qualification here seems wrong! BranchUtil.makeDeleteTypeName (over _2 HQ'.toName p) srcType, - BranchUtil.makeAddTypeName (Path.convert dest) srcType + BranchUtil.makeAddTypeName (over _1 (view PP.absPath_) dest) srcType ] doMoveType :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli () @@ -41,5 +42,6 @@ doMoveType src' dest' description = do steps <- moveTypeSteps src' dest' when (null steps) do Cli.returnEarly (Output.TypeNotFound src') - Cli.stepManyAt description steps + pb <- Cli.getCurrentProjectBranch + Cli.stepManyAt pb description steps Cli.respond Output.Success diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs index 068a28832b..e801b43393 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs @@ -9,12 +9,11 @@ import Data.Map qualified as Map import Data.Set qualified as Set import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli -import Unison.Cli.PrettyPrintUtils qualified as Cli +import Unison.Cli.NamesUtils qualified as Cli import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Branch.Names qualified as Branch import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path import Unison.DataDeclaration qualified as DD @@ -22,9 +21,10 @@ import Unison.LabeledDependency (LabeledDependency) import Unison.LabeledDependency qualified as LD import Unison.Name (Name) import Unison.NameSegment qualified as NameSegment -import Unison.Names qualified as Names import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED +import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.Sqlite qualified as Sqlite @@ -35,19 +35,18 @@ import Unison.Util.Relation qualified as Relation handleNamespaceDependencies :: Maybe Path.Path' -> Cli.Cli () handleNamespaceDependencies namespacePath' = do Cli.Env {codebase} <- ask - path <- maybe Cli.getCurrentPath Cli.resolvePath' namespacePath' + pp <- maybe Cli.getCurrentProjectPath Cli.resolvePath' namespacePath' + let pb = pp ^. #branch branch <- - Cli.getMaybeBranch0At path & onNothingM do - Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath (Path.absoluteToPath' path))) + Cli.getMaybeBranch0FromProjectPath pp & onNothingM do + Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath pp)) externalDependencies <- Cli.runTransaction (namespaceDependencies codebase branch) - currentPPED <- Cli.currentPrettyPrintEnvDecl - globalNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getRootBranch0 - globalPPED <- Cli.prettyPrintEnvDeclFromNames globalNames - -- We explicitly include a global unsuffixified fallback on namespace dependencies since - -- the things we want names for are obviously outside of our scope. - let ppeWithFallback = PPED.unsuffixifiedPPE $ PPED.addFallback globalPPED currentPPED - Cli.respondNumbered $ Output.ListNamespaceDependencies ppeWithFallback path externalDependencies + names <- Cli.projectBranchNames pb + + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) + let ppe = PPED.unsuffixifiedPPE pped + Cli.respondNumbered $ Output.ListNamespaceDependencies ppe pp externalDependencies -- | Check the dependencies of all types and terms in the current namespace, -- returns a map of dependencies which do not have a name within the current namespace, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDiffUtils.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDiffUtils.hs index 0416672e3e..b6265e4fec 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDiffUtils.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDiffUtils.hs @@ -10,7 +10,6 @@ import Unison.Builtin qualified as Builtin import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.NamesUtils qualified as Cli -import Unison.Cli.PrettyPrintUtils qualified as Cli import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) @@ -21,7 +20,9 @@ import Unison.DataDeclaration qualified as DD import Unison.Parser.Ann (Ann (..)) import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE +import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED +import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Sqlite qualified as Sqlite @@ -36,8 +37,9 @@ diffHelper before after = Cli.Env {codebase} <- ask hqLength <- Cli.runTransaction Codebase.hashLength diff <- liftIO (BranchDiff.diff0 before after) - names <- Cli.currentNames - pped <- Cli.prettyPrintEnvDeclFromNames names + names <- Cli.currentNames <&> \currentNames -> currentNames <> Branch.toNames before <> Branch.toNames after + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) + let suffixifiedPPE = PPED.suffixifiedPPE pped fmap (suffixifiedPPE,) do OBranchDiff.toOutput diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs index 5d15bf659c..8a872d18b8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs @@ -5,24 +5,21 @@ module Unison.Codebase.Editor.HandleInput.ProjectClone where import Control.Lens (_2) -import Control.Monad.Reader (ask) import Data.These (These (..)) import Data.UUID.V4 qualified as UUID import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..)) import U.Codebase.Sqlite.DbId qualified as Sqlite import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..)) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite +import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli -import Unison.Cli.MonadUtils qualified as Cli (updateAt) -import Unison.Cli.ProjectUtils (projectBranchPath) +import Unison.Cli.MonadUtils qualified as Cli (getCurrentProjectAndBranch) import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.Share.Projects qualified as Share -import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path (Path) import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectName, projectNameUserSlug) import Unison.Sqlite qualified as Sqlite @@ -39,9 +36,9 @@ data RemoteProjectKey -- | Clone a remote branch. handleClone :: ProjectAndBranchNames -> Maybe ProjectAndBranchNames -> Cli () handleClone remoteNames0 maybeLocalNames0 = do - maybeCurrentProjectBranch <- ProjectUtils.getCurrentProjectBranch - resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead maybeCurrentProjectBranch remoteNames0 - localNames1 <- resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames0 + currentProjectBranch <- Cli.getCurrentProjectAndBranch + resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead currentProjectBranch remoteNames0 + localNames1 <- resolveLocalNames currentProjectBranch resolvedRemoteNames maybeLocalNames0 cloneInto localNames1 resolvedRemoteNames.branch data ResolvedRemoteNames = ResolvedRemoteNames @@ -78,63 +75,59 @@ data ResolvedRemoteNamesFrom -- otherwise abort resolveRemoteNames :: Share.IncludeSquashedHead -> - Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) -> + (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> ProjectAndBranchNames -> Cli ResolvedRemoteNames -resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case - ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName -> - case maybeCurrentProjectBranch of - Nothing -> resolveP remoteProjectName - Just (currentProjectAndBranch, _path) -> - case projectNameUserSlug remoteProjectName of - Nothing -> resolveB remoteBranchName - Just _ -> - Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case - Nothing -> resolveP remoteProjectName - Just remoteBranchProjectId -> do - -- Fetching these in parallel would be an improvement - maybeRemoteProject <- Share.getProjectByName remoteProjectName - maybeRemoteBranch <- - Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case - Share.GetProjectBranchResponseBranchNotFound -> Nothing - Share.GetProjectBranchResponseProjectNotFound -> Nothing - Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch - case (maybeRemoteProject, maybeRemoteBranch) of - (Just remoteProject, Nothing) -> do - let remoteProjectId = remoteProject.projectId - let remoteProjectName = remoteProject.projectName - let remoteBranchName = unsafeFrom @Text "main" - remoteBranch <- - ProjectUtils.expectRemoteProjectBranchByName - includeSquashed - (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) - pure - ResolvedRemoteNames - { branch = remoteBranch, - from = ResolvedRemoteNamesFrom'Project - } - (Nothing, Just remoteBranch) -> - pure - ResolvedRemoteNames - { branch = remoteBranch, - from = ResolvedRemoteNamesFrom'Branch - } - -- Treat neither existing and both existing uniformly as "ambiguous input" - -- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating - -- wouldn't help, because we did enough work to know neither thing exists" - _ -> do - branchProjectName <- - Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri) - Cli.returnEarly $ - Output.AmbiguousCloneRemote - remoteProjectName - (ProjectAndBranch branchProjectName remoteBranchName) +resolveRemoteNames includeSquashed currentProjectAndBranch = \case + ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName -> do + case projectNameUserSlug remoteProjectName of + Nothing -> resolveB remoteBranchName + Just _ -> + Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case + Nothing -> resolveP remoteProjectName + Just remoteBranchProjectId -> do + -- Fetching these in parallel would be an improvement + maybeRemoteProject <- Share.getProjectByName remoteProjectName + maybeRemoteBranch <- + Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case + Share.GetProjectBranchResponseBranchNotFound -> Nothing + Share.GetProjectBranchResponseProjectNotFound -> Nothing + Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch + case (maybeRemoteProject, maybeRemoteBranch) of + (Just remoteProject, Nothing) -> do + let remoteProjectId = remoteProject.projectId + let remoteProjectName = remoteProject.projectName + let remoteBranchName = unsafeFrom @Text "main" + remoteBranch <- + ProjectUtils.expectRemoteProjectBranchByName + includeSquashed + (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) + pure + ResolvedRemoteNames + { branch = remoteBranch, + from = ResolvedRemoteNamesFrom'Project + } + (Nothing, Just remoteBranch) -> + pure + ResolvedRemoteNames + { branch = remoteBranch, + from = ResolvedRemoteNamesFrom'Branch + } + -- Treat neither existing and both existing uniformly as "ambiguous input" + -- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating + -- wouldn't help, because we did enough work to know neither thing exists" + _ -> do + branchProjectName <- + Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri) + Cli.returnEarly $ + Output.AmbiguousCloneRemote + remoteProjectName + (ProjectAndBranch branchProjectName remoteBranchName) ProjectAndBranchNames'Unambiguous (This p) -> resolveP p ProjectAndBranchNames'Unambiguous (That b) -> resolveB b ProjectAndBranchNames'Unambiguous (These p b) -> resolvePB p b where resolveB branchName = do - (currentProjectAndBranch, _path) <- maybeCurrentProjectBranch & onNothing (Cli.returnEarly Output.NotOnProjectBranch) remoteProjectId <- Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) & onNothingM do Cli.returnEarly (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri currentProjectAndBranch) @@ -181,11 +174,11 @@ resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case -- `clone @foo/bar` resulted in treating `@foo/bar` as a contributor branch of the current project, then it is as if -- the user typed `clone /@foo/bar` instead, which is equivalent to the two-arg `clone /@foo/bar /@foo/bar`. resolveLocalNames :: - Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) -> + (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> ResolvedRemoteNames -> Maybe ProjectAndBranchNames -> Cli (ProjectAndBranch LocalProjectKey ProjectBranchName) -resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames = +resolveLocalNames (ProjectAndBranch currentProject _) resolvedRemoteNames maybeLocalNames = resolve case maybeLocalNames of Nothing -> ProjectAndBranchNames'Unambiguous case resolvedRemoteNames.from of @@ -199,14 +192,11 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames resolve names = case names of - ProjectAndBranchNames'Ambiguous localProjectName localBranchName -> - case maybeCurrentProjectBranch of - Nothing -> resolveP localProjectName - Just (ProjectAndBranch currentProject _, _path) -> do - Cli.returnEarly $ - Output.AmbiguousCloneLocal - (ProjectAndBranch localProjectName remoteBranchName) - (ProjectAndBranch currentProject.name localBranchName) + ProjectAndBranchNames'Ambiguous localProjectName localBranchName -> do + Cli.returnEarly $ + Output.AmbiguousCloneLocal + (ProjectAndBranch localProjectName remoteBranchName) + (ProjectAndBranch currentProject.name localBranchName) ProjectAndBranchNames'Unambiguous (This localProjectName) -> resolveP localProjectName ProjectAndBranchNames'Unambiguous (That localBranchName) -> resolveB localBranchName ProjectAndBranchNames'Unambiguous (These localProjectName localBranchName) -> resolvePB localProjectName localBranchName @@ -215,8 +205,6 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames go (LocalProjectKey'Name localProjectName) remoteBranchName resolveB localBranchName = do - (ProjectAndBranch currentProject _, _path) <- - maybeCurrentProjectBranch & onNothing (Cli.returnEarly Output.NotOnProjectBranch) go (LocalProjectKey'Project currentProject) localBranchName resolvePB localProjectName localBranchName = @@ -254,7 +242,11 @@ cloneInto localProjectBranch remoteProjectBranch = do pure (localProjectId, localProjectName) Right localProject -> pure (localProject.projectId, localProject.name) localBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom) + causalHashId <- Q.expectCausalHashIdByCausalHash branchHead + let description = "Cloned from " <> into @Text (ProjectAndBranch remoteProjectName remoteBranchName) Queries.insertProjectBranch + description + causalHashId Sqlite.ProjectBranch { projectId = localProjectId, branchId = localBranchId, @@ -277,12 +269,8 @@ cloneInto localProjectBranch remoteProjectBranch = do localProjectBranch.branch ) - -- Manipulate the root namespace and cd - Cli.Env {codebase} <- ask - theBranch <- liftIO (Codebase.expectBranchForHash codebase branchHead) - let path = projectBranchPath (over #project fst localProjectAndBranch) - Cli.updateAt ("clone " <> into @Text remoteProjectBranchNames) path (const theBranch) - Cli.cd path + let newProjectAndBranch = (over #project fst localProjectAndBranch) + Cli.switchProject newProjectAndBranch -- Return the remote project id associated with the given project branch loadAssociatedRemoteProjectId :: diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs index 8ffe4e9777..e9f6e99e95 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs @@ -4,23 +4,23 @@ module Unison.Codebase.Editor.HandleInput.ProjectCreate ) where +import Control.Lens import Control.Monad.Reader (ask) -import Data.Map.Strict qualified as Map import Data.Text qualified as Text -import Data.UUID.V4 qualified as UUID import System.Random.Shuffle qualified as RandomShuffle import U.Codebase.Sqlite.DbId +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.Queries (expectCausalHashIdByCausalHash) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli -import Unison.Cli.MonadUtils qualified as Cli (stepAt) -import Unison.Cli.ProjectUtils (projectBranchPath) import Unison.Cli.Share.Projects qualified as Share import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Causal qualified as Causal import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path qualified as Path import Unison.Codebase.SqliteCodebase.Operations qualified as Ops import Unison.NameSegment qualified as NameSegment import Unison.Prelude @@ -55,14 +55,12 @@ import Witch (unsafeFrom) -- -- For now, it doesn't seem worth it to do (1) or (2), since we want to do (3) eventually, and we'd rather not waste too -- much time getting everything perfectly correct before we get there. -projectCreate :: Bool -> Maybe ProjectName -> Cli () +projectCreate :: Bool -> Maybe ProjectName -> Cli (ProjectAndBranch ProjectId ProjectBranchId) projectCreate tryDownloadingBase maybeProjectName = do - projectId <- liftIO (ProjectId <$> UUID.nextRandom) - branchId <- liftIO (ProjectBranchId <$> UUID.nextRandom) - let branchName = unsafeFrom @Text "main" + (_, emptyCausalHashId) <- Cli.runTransaction Codebase.emptyCausalHash - projectName <- + (project, branch) <- case maybeProjectName of Nothing -> do randomProjectNames <- liftIO generateRandomProjectNames @@ -70,23 +68,21 @@ projectCreate tryDownloadingBase maybeProjectName = do let loop = \case [] -> error (reportBug "E066388" "project name supply is supposed to be infinite") projectName : projectNames -> - Queries.projectExistsByName projectName >>= \case - False -> do - Ops.insertProjectAndBranch projectId projectName branchId branchName - pure projectName - True -> loop projectNames + Queries.loadProjectByName projectName >>= \case + Nothing -> do + (project, branch) <- Ops.insertProjectAndBranch projectName branchName emptyCausalHashId + pure (project, branch) + Just _project -> loop projectNames loop randomProjectNames Just projectName -> do Cli.runTransactionWithRollback \rollback -> do Queries.projectExistsByName projectName >>= \case False -> do - Ops.insertProjectAndBranch projectId projectName branchId branchName - pure projectName + Ops.insertProjectAndBranch projectName branchName emptyCausalHashId True -> rollback (Output.ProjectNameAlreadyExists projectName) - let path = projectBranchPath ProjectAndBranch {project = projectId, branch = branchId} - Cli.respond (Output.CreatedProject (isNothing maybeProjectName) projectName) - Cli.cd path + Cli.respond (Output.CreatedProject (isNothing maybeProjectName) project.name) + Cli.switchProject (ProjectAndBranch project.projectId branch.branchId) maybeBaseLatestReleaseBranchObject <- if tryDownloadingBase @@ -126,30 +122,29 @@ projectCreate tryDownloadingBase maybeProjectName = do pure maybeBaseLatestReleaseBranchObject else pure Nothing - let projectBranchObject = - case maybeBaseLatestReleaseBranchObject of - Nothing -> Branch.empty0 - Just baseLatestReleaseBranchObject -> - let -- lib.base - projectBranchLibBaseObject = - over - Branch.children - (Map.insert NameSegment.baseSegment baseLatestReleaseBranchObject) - Branch.empty0 - projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty - in over - Branch.children - (Map.insert NameSegment.libSegment projectBranchLibObject) - Branch.empty0 - - Cli.stepAt reflogDescription (Path.unabsolute path, const projectBranchObject) + for_ maybeBaseLatestReleaseBranchObject \baseLatestReleaseBranchObject -> do + -- lib.base + let projectBranchLibBaseObject = + Branch.empty0 + & Branch.children + . at NameSegment.baseSegment + .~ Just baseLatestReleaseBranchObject + projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty + let branchWithBase = + Branch.empty + & Branch.history + . Causal.head_ + . Branch.children + . at NameSegment.libSegment + .~ Just projectBranchLibObject + Cli.Env {codebase} <- ask + liftIO $ Codebase.putBranch codebase branchWithBase + Cli.runTransaction $ do + baseBranchCausalHashId <- expectCausalHashIdByCausalHash (Branch.headHash branchWithBase) + Queries.setProjectBranchHead "Include latest base library" project.projectId branch.branchId baseBranchCausalHashId Cli.respond Output.HappyCoding - where - reflogDescription = - case maybeProjectName of - Nothing -> "project.create" - Just projectName -> "project.create " <> into @Text projectName + pure ProjectAndBranch {project = project.projectId, branch = branch.branchId} -- An infinite list of random project names that looks like -- diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectRename.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectRename.hs index f7d960d2df..117f12bb80 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectRename.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectRename.hs @@ -4,21 +4,22 @@ module Unison.Codebase.Editor.HandleInput.ProjectRename ) where +import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli -import Unison.Cli.ProjectUtils qualified as ProjectUtils +import Unison.Cli.MonadUtils qualified as Cli import Unison.Codebase.Editor.Output qualified as Output import Unison.Prelude -import Unison.Project (ProjectName) +import Unison.Project (ProjectAndBranch (..), ProjectName) handleProjectRename :: ProjectName -> Cli () handleProjectRename newName = do - project <- ProjectUtils.expectCurrentProject - let oldName = project ^. #name + ProjectAndBranch project _branch <- Cli.getCurrentProjectAndBranch + let oldName = project.name when (oldName /= newName) do Cli.runTransactionWithRollback \rollback -> do Queries.loadProjectByName newName >>= \case Just _ -> rollback (Output.ProjectNameAlreadyExists newName) - Nothing -> Queries.renameProject (project ^. #projectId) newName + Nothing -> Queries.renameProject project.projectId newName Cli.respond (Output.RenamedProject oldName newName) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs index 688ba58363..8799fa4e2f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs @@ -1,16 +1,15 @@ -- | @switch@ input handler module Unison.Codebase.Editor.HandleInput.ProjectSwitch ( projectSwitch, - switchToProjectBranch, ) where import Data.These (These (..)) -import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) -import U.Codebase.Sqlite.Project qualified +import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase.Editor.Output qualified as Output import Unison.Prelude @@ -29,51 +28,46 @@ import Witch (unsafeFrom) projectSwitch :: ProjectAndBranchNames -> Cli () projectSwitch projectNames = do case projectNames of - ProjectAndBranchNames'Ambiguous projectName branchName -> - ProjectUtils.getCurrentProjectBranch >>= \case - Nothing -> switchToProjectAndBranchByTheseNames (This projectName) - Just (ProjectAndBranch currentProject _currentBranch, _restPath) -> do - (projectExists, branchExists) <- - Cli.runTransaction do - (,) - <$> Queries.projectExistsByName projectName - <*> Queries.projectBranchExistsByName currentProject.projectId branchName - case (projectExists, branchExists) of - (False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName) - (False, True) -> switchToProjectAndBranchByTheseNames (These currentProject.name branchName) - (True, False) -> switchToProjectAndBranchByTheseNames (This projectName) - (True, True) -> - Cli.respondNumbered $ - Output.AmbiguousSwitch - projectName - (ProjectAndBranch currentProject.name branchName) + ProjectAndBranchNames'Ambiguous projectName branchName -> do + ProjectAndBranch currentProject _currentBranch <- Cli.getCurrentProjectAndBranch + (projectExists, branchExists) <- + Cli.runTransaction do + (,) + <$> Queries.projectExistsByName projectName + <*> Queries.projectBranchExistsByName currentProject.projectId branchName + case (projectExists, branchExists) of + (False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName) + (False, True) -> switchToProjectAndBranchByTheseNames (These currentProject.name branchName) + (True, False) -> switchToProjectAndBranchByTheseNames (This projectName) + (True, True) -> + Cli.respondNumbered $ + Output.AmbiguousSwitch + projectName + (ProjectAndBranch currentProject.name branchName) ProjectAndBranchNames'Unambiguous projectAndBranchNames0 -> switchToProjectAndBranchByTheseNames projectAndBranchNames0 switchToProjectAndBranchByTheseNames :: These ProjectName ProjectBranchName -> Cli () switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do - branch <- - case projectAndBranchNames0 of - This projectName -> - Cli.runTransactionWithRollback \rollback -> do - project <- - Queries.loadProjectByName projectName & onNothingM do - rollback (Output.LocalProjectDoesntExist projectName) - let branchName = unsafeFrom @Text "main" - Queries.loadProjectBranchByName project.projectId branchName & onNothingM do - rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) - _ -> do - projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0 - Cli.runTransactionWithRollback \rollback -> do + branch <- case projectAndBranchNames0 of + This projectName -> + Cli.runTransactionWithRollback \rollback -> do + project <- + Queries.loadProjectByName projectName & onNothingM do + rollback (Output.LocalProjectDoesntExist projectName) + Queries.loadMostRecentBranch (project ^. #projectId) >>= \case + Nothing -> do + let branchName = unsafeFrom @Text "main" + branch <- + Queries.loadProjectBranchByName project.projectId branchName & onNothingM do + rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) + pure branch + Just branchId -> Queries.expectProjectBranch project.projectId branchId + _ -> do + projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0 + Cli.runTransactionWithRollback \rollback -> do + branch <- Queries.loadProjectBranchByNames projectName branchName & onNothingM do rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) - switchToProjectBranch (ProjectUtils.justTheIds' branch) - --- | Switch to a branch: --- --- * Record it as the most-recent branch (so it's restored when ucm starts). --- * Change the current path in the in-memory loop state. -switchToProjectBranch :: ProjectAndBranch ProjectId ProjectBranchId -> Cli () -switchToProjectBranch x = do - Cli.runTransaction (Queries.setMostRecentBranch x.project x.branch) - Cli.cd (ProjectUtils.projectBranchPath x) + pure branch + Cli.switchProject (ProjectAndBranch (branch ^. #projectId) (branch ^. #branchId)) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 6165d60bc3..3ff7012220 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -21,9 +21,9 @@ import Unison.Cli.MergeTypes (MergeSource (..)) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli +import Unison.Cli.NamesUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.Share.Projects qualified as Share -import Unison.Cli.UnisonConfigUtils (resolveConfiguredUrl) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch (..)) import Unison.Codebase.Branch qualified as Branch @@ -34,13 +34,11 @@ import Unison.Codebase.Editor.Input import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Editor.Output.PushPull qualified as PushPull import Unison.Codebase.Editor.Propagate qualified as Propagate import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), printReadRemoteNamespace) -import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Patch (Patch (..)) -import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.InputPattern qualified as InputPattern import Unison.CommandLine.InputPatterns qualified as InputPatterns import Unison.NameSegment qualified as NameSegment @@ -76,8 +74,7 @@ handlePull unresolvedSourceAndTarget pullMode = do when remoteBranchIsEmpty (Cli.respond (PulledEmptyBranch source)) - let targetAbsolutePath = - ProjectUtils.projectBranchPath (ProjectAndBranch target.project.projectId target.branch.branchId) + let targetProjectPath = PP.projectBranchRoot (ProjectAndBranch target.project target.branch) let description = Text.unwords @@ -92,22 +89,18 @@ handlePull unresolvedSourceAndTarget pullMode = do case pullMode of Input.PullWithHistory -> do - targetBranchObject <- Cli.getBranch0At targetAbsolutePath + targetBranch <- Cli.getBranchFromProjectPath targetProjectPath - if Branch.isEmpty0 targetBranchObject + if Branch.isEmpty0 $ Branch.head targetBranch then do Cli.Env {codebase} <- ask remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash) - void $ Cli.updateAtM description targetAbsolutePath (const $ pure remoteBranchObject) + void $ Cli.updateAtM description targetProjectPath (const $ pure remoteBranchObject) Cli.respond $ MergeOverEmpty target else do Cli.respond AboutToMerge - aliceCausalHash <- - Cli.runTransaction do - causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute targetAbsolutePath) - pure causal.causalHash - + let aliceCausalHash = Branch.headHash targetBranch lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash remoteCausalHash) doMerge @@ -139,7 +132,7 @@ handlePull unresolvedSourceAndTarget pullMode = do didUpdate <- Cli.updateAtM description - targetAbsolutePath + targetProjectPath (\targetBranchObject -> pure $ remoteBranchObject `Branch.consBranchSnapshot` targetBranchObject) Cli.respond @@ -167,30 +160,29 @@ resolveSourceAndTarget includeSquashed = \case pure (source, target) resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch) -resolveImplicitSource includeSquashed = - ProjectUtils.getCurrentProjectBranch >>= \case - Nothing -> RemoteRepo.writeNamespaceToRead <$> resolveConfiguredUrl PushPull.Pull Path.currentPath - Just (localProjectAndBranch, _restPath) -> do - (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <- - Cli.runTransactionWithRollback \rollback -> do - let localProjectId = localProjectAndBranch.project.projectId - let localBranchId = localProjectAndBranch.branch.branchId - Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId >>= \case - Just (remoteProjectId, Just remoteBranchId) -> do - remoteProjectName <- Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri - remoteBranchName <- - Queries.expectRemoteProjectBranchName - Share.hardCodedUri - remoteProjectId - remoteBranchId - pure (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) - _ -> rollback (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri localProjectAndBranch) - remoteBranch <- - ProjectUtils.expectRemoteProjectBranchById includeSquashed $ - ProjectAndBranch - (remoteProjectId, remoteProjectName) - (remoteBranchId, remoteBranchName) - pure (ReadShare'ProjectBranch remoteBranch) +resolveImplicitSource includeSquashed = do + pp <- Cli.getCurrentProjectPath + let localProjectAndBranch = PP.toProjectAndBranch pp + (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <- + Cli.runTransactionWithRollback \rollback -> do + let localProjectId = localProjectAndBranch.project.projectId + let localBranchId = localProjectAndBranch.branch.branchId + Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId >>= \case + Just (remoteProjectId, Just remoteBranchId) -> do + remoteProjectName <- Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri + remoteBranchName <- + Queries.expectRemoteProjectBranchName + Share.hardCodedUri + remoteProjectId + remoteBranchId + pure (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) + _ -> rollback (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri localProjectAndBranch) + remoteBranch <- + ProjectUtils.expectRemoteProjectBranchById includeSquashed $ + ProjectAndBranch + (remoteProjectId, remoteProjectName) + (remoteBranchId, remoteBranchName) + pure (ReadShare'ProjectBranch remoteBranch) resolveExplicitSource :: Share.IncludeSquashedHead -> @@ -208,7 +200,7 @@ resolveExplicitSource includeSquashed = \case (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) pure (ReadShare'ProjectBranch remoteProjectBranch) ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do - (localProjectAndBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch + localProjectAndBranch <- PP.toProjectAndBranch <$> Cli.getCurrentProjectPath let localProjectId = localProjectAndBranch.project.projectId let localBranchId = localProjectAndBranch.branch.branchId Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case @@ -243,8 +235,7 @@ resolveExplicitSource includeSquashed = \case resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) resolveImplicitTarget = do - (projectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch - pure projectAndBranch + PP.toProjectAndBranch <$> Cli.getCurrentProjectPath -- | supply `dest0` if you want to print diff messages -- supply unchangedMessage if you want to display it if merge had no effect @@ -253,8 +244,8 @@ mergeBranchAndPropagateDefaultPatch :: Text -> Maybe Output -> Branch IO -> - Maybe (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -> - Path.Absolute -> + Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -> + PP.ProjectPath -> Cli () mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb maybeDest0 dest = ifM @@ -266,7 +257,7 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb mergeBranch = Cli.time "mergeBranch" do Cli.Env {codebase} <- ask - destb <- Cli.getBranchAt dest + destb <- Cli.getBranchFromProjectPath dest merged <- liftIO (Branch.merge'' (Codebase.lca codebase) mode srcb destb) b <- Cli.updateAtM inputDescription dest (const $ pure merged) for_ maybeDest0 \dest0 -> do @@ -276,19 +267,19 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb loadPropagateDiffDefaultPatch :: Text -> - Maybe (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -> - Path.Absolute -> + Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -> + PP.ProjectPath -> Cli () loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do Cli.respond Output.AboutToPropagatePatch Cli.time "loadPropagateDiffDefaultPatch" do - original <- Cli.getBranch0At dest + original <- Cli.getBranch0FromProjectPath dest patch <- liftIO $ Branch.getPatch NameSegment.defaultPatchSegment original patchDidChange <- propagatePatch inputDescription patch dest when patchDidChange do whenJust maybeDest0 \dest0 -> do Cli.respond Output.CalculatingDiff - patched <- Cli.getBranchAt dest + patched <- Cli.getBranchFromProjectPath dest let patchPath = Path.Path' (Right (Path.Relative (Path.fromList [NameSegment.defaultPatchSegment]))) (ppe, diff) <- diffHelper original (Branch.head patched) Cli.respondNumbered (ShowDiffAfterMergePropagate dest0 dest patchPath ppe diff) @@ -297,10 +288,11 @@ loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do propagatePatch :: Text -> Patch -> - Path.Absolute -> + PP.ProjectPath -> Cli Bool propagatePatch inputDescription patch scopePath = do Cli.time "propagatePatch" do + rootNames <- Cli.projectBranchNames scopePath.branch Cli.stepAt' (inputDescription <> " (applying patch)") - (Path.unabsolute scopePath, Propagate.propagateAndApply patch) + (scopePath, Propagate.propagateAndApply rootNames patch) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs index a9aba3224c..1bb63940d6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs @@ -9,13 +9,13 @@ import Control.Lens (_1, _2) import Data.Set.NonEmpty qualified as Set.NonEmpty import Data.Text as Text import Data.These (These (..)) -import Data.Void (absurd) import System.Console.Regions qualified as Console.Regions import Text.Builder qualified import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.Operations qualified as Operations import U.Codebase.Sqlite.Project qualified as Sqlite (Project) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) @@ -23,7 +23,6 @@ import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.Share.Projects qualified as Share -import Unison.Cli.UnisonConfigUtils qualified as UnisonConfigUtils import Unison.Codebase.Editor.HandleInput.AuthLogin qualified as AuthLogin import Unison.Codebase.Editor.Input ( PushRemoteBranchInput (..), @@ -32,13 +31,6 @@ import Unison.Codebase.Editor.Input ) import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Editor.Output.PushPull (PushPull (Push)) -import Unison.Codebase.Editor.RemoteRepo - ( WriteRemoteNamespace (..), - WriteShareRemoteNamespace (..), - ) -import Unison.Codebase.Path qualified as Path -import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.PushBehavior qualified as PushBehavior import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName)) import Unison.Hash32 (Hash32) @@ -67,49 +59,16 @@ handlePushRemoteBranch :: PushRemoteBranchInput -> Cli () handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do case sourceTarget of -- push to - PushSourceTarget0 -> - ProjectUtils.getCurrentProjectBranch >>= \case - Nothing -> do - localPath <- Cli.getCurrentPath - UnisonConfigUtils.resolveConfiguredUrl Push Path.currentPath >>= \case - WriteRemoteNamespaceShare namespace -> pushLooseCodeToShareLooseCode localPath namespace pushBehavior - WriteRemoteProjectBranch v -> absurd v - Just (localProjectAndBranch, _restPath) -> - pushProjectBranchToProjectBranch - force - localProjectAndBranch - Nothing + PushSourceTarget0 -> do + localProjectAndBranch <- Cli.getCurrentProjectAndBranch + pushProjectBranchToProjectBranch force localProjectAndBranch Nothing -- push to .some.path (share) - PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do - localPath <- Cli.getCurrentPath - pushLooseCodeToShareLooseCode localPath namespace pushBehavior -- push to @some/project - PushSourceTarget1 (WriteRemoteProjectBranch remoteProjectAndBranch0) -> - ProjectUtils.getCurrentProjectBranch >>= \case - Nothing -> do - localPath <- Cli.getCurrentPath - remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0 - pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch - Just (localProjectAndBranch, _restPath) -> - pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0) - -- push .some.path to .some.path (share) - PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do - localPath <- Cli.resolvePath' localPath0 - pushLooseCodeToShareLooseCode localPath namespace pushBehavior - -- push .some.path to @some/project - PushSourceTarget2 (PathySource localPath0) (WriteRemoteProjectBranch remoteProjectAndBranch0) -> do - localPath <- Cli.resolvePath' localPath0 - remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0 - pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch - -- push @some/project to .some.path (share) - PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceShare namespace) -> do - ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0 - pushLooseCodeToShareLooseCode - (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))) - namespace - pushBehavior + PushSourceTarget1 remoteProjectAndBranch0 -> do + localProjectAndBranch <- Cli.getCurrentProjectAndBranch + pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0) -- push @some/project to @some/project - PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteProjectBranch remoteProjectAndBranch) -> do + PushSourceTarget2 (ProjySource localProjectAndBranch0) remoteProjectAndBranch -> do localProjectAndBranch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0 pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch) where @@ -119,24 +78,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do PushBehavior.RequireEmpty -> False PushBehavior.RequireNonEmpty -> False --- Push a local namespace ("loose code") to a Share-hosted remote namespace ("loose code"). -pushLooseCodeToShareLooseCode :: Path.Absolute -> WriteShareRemoteNamespace -> PushBehavior -> Cli () -pushLooseCodeToShareLooseCode _ _ _ = do - Cli.returnEarly LooseCodePushDeprecated - --- Push a local namespace ("loose code") to a remote project branch. -pushLooseCodeToProjectBranch :: Bool -> Path.Absolute -> ProjectAndBranch ProjectName ProjectBranchName -> Cli () -pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch = do - _ <- AuthLogin.ensureAuthenticatedWithCodeserver Codeserver.defaultCodeserver - localBranchHead <- - Cli.runTransactionWithRollback \rollback -> do - loadCausalHashToPush localPath >>= \case - Nothing -> rollback (EmptyLooseCodePush (Path.absoluteToPath' localPath)) - Just hash -> pure hash - - uploadPlan <- pushToProjectBranch0 force PushingLooseCode localBranchHead remoteProjectAndBranch - executeUploadPlan uploadPlan - -- | Push a local project branch to a remote project branch. If the remote project branch is left unspecified, we either -- use a pre-existing mapping for the local branch, or else infer what remote branch to push to (possibly creating it). pushProjectBranchToProjectBranch :: @@ -147,14 +88,11 @@ pushProjectBranchToProjectBranch :: pushProjectBranchToProjectBranch force localProjectAndBranch maybeRemoteProjectAndBranchNames = do _ <- AuthLogin.ensureAuthenticatedWithCodeserver Codeserver.defaultCodeserver let localProjectAndBranchIds = localProjectAndBranch & over #project (view #projectId) & over #branch (view #branchId) - let localProjectAndBranchNames = localProjectAndBranch & over #project (view #name) & over #branch (view #name) -- Load local project and branch from database and get the causal hash to push (localProjectAndBranch, localBranchHead) <- - Cli.runTransactionWithRollback \rollback -> do - hash <- - loadCausalHashToPush (ProjectUtils.projectBranchPath localProjectAndBranchIds) & onNothingM do - rollback (EmptyProjectBranchPush localProjectAndBranchNames) + Cli.runTransaction do + hash <- expectCausalHashToPush (localProjectAndBranch ^. #branch) localProjectAndBranch <- expectProjectAndBranch localProjectAndBranchIds pure (localProjectAndBranch, hash) @@ -471,7 +409,7 @@ executeUploadPlan UploadPlan {remoteBranch, causalHash, afterUploadAction} = do Share.TransportError err -> ShareErrorTransport err afterUploadAction let ProjectAndBranch projectName branchName = remoteBranch - Cli.respond (ViewOnShare (Right (Share.hardCodedUri, projectName, branchName))) + Cli.respond (ViewOnShare (Share.hardCodedUri, projectName, branchName)) ------------------------------------------------------------------------------------------------------------------------ -- After upload actions @@ -563,7 +501,7 @@ makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do when (localBranchHead == Share.API.hashJWTHash remoteBranch.branchHead) do Cli.respond (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames) - Cli.returnEarly (ViewOnShare (Right (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName))) + Cli.returnEarly (ViewOnShare (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName)) when (not force) do whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do @@ -633,14 +571,11 @@ expectProjectAndBranch (ProjectAndBranch projectId branchId) = <$> Queries.expectProject projectId <*> Queries.expectProjectBranch projectId branchId --- Get the causal hash to push at the given path. Return Nothing if there's no history. -loadCausalHashToPush :: Path.Absolute -> Sqlite.Transaction (Maybe Hash32) -loadCausalHashToPush path = - Operations.loadCausalHashAtPath Nothing segments <&> \case - Nothing -> Nothing - Just (CausalHash hash) -> Just (Hash32.fromHash hash) - where - segments = Path.toList (Path.unabsolute path) +-- Get the causal hash for the given project branch. +expectCausalHashToPush :: ProjectBranch -> Sqlite.Transaction Hash32 +expectCausalHashToPush pb = do + CausalHash causalHash <- Operations.expectProjectBranchHead (pb ^. #projectId) (pb ^. #branchId) + pure (Hash32.fromHash causalHash) -- Were we to try to advance `remoteBranchHead` to `localBranchHead`, would it *not* be a fast-forward? wouldNotBeFastForward :: Hash32 -> Hash32 -> Sqlite.Transaction Bool diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Reflogs.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Reflogs.hs new file mode 100644 index 0000000000..f2006dca7e --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Reflogs.hs @@ -0,0 +1,60 @@ +-- | Helpers for working with various kinds of reflogs. +module Unison.Codebase.Editor.HandleInput.Reflogs + ( showProjectBranchReflog, + showProjectReflog, + showGlobalReflog, + ) +where + +import Control.Monad.Reader +import Data.Time (getCurrentTime) +import U.Codebase.HashTags (CausalHash) +import U.Codebase.Sqlite.Project (Project) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch) +import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Cli.ProjectUtils qualified as ProjectUtils +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Editor.Output qualified as Output +import Unison.Codebase.ShortCausalHash qualified as SCH +import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) +import Unison.Prelude +import Unison.Sqlite qualified as Sqlite + +showProjectBranchReflog :: Maybe (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) -> Cli () +showProjectBranchReflog mayProjectAndBranch = do + ProjectAndBranch _project branch <- case mayProjectAndBranch of + Nothing -> Cli.getCurrentProjectAndBranch + Just pab -> ProjectUtils.resolveProjectBranch (second Just pab) + reflogHelper (\n -> Codebase.getProjectBranchReflog n (branch ^. #branchId)) + +showProjectReflog :: Maybe ProjectName -> Cli () +showProjectReflog mayProject = do + ProjectAndBranch project _ <- ProjectUtils.resolveProjectBranch (ProjectAndBranch mayProject Nothing) + reflogHelper (\n -> Codebase.getProjectReflog n (project ^. #projectId)) + +showGlobalReflog :: Cli () +showGlobalReflog = do + reflogHelper Codebase.getGlobalReflog + +reflogHelper :: (Int -> Sqlite.Transaction [ProjectReflog.Entry Project ProjectBranch CausalHash]) -> Cli () +reflogHelper getEntries = do + let numEntriesToShow = 500 + entries <- + Cli.runTransaction $ do + schLength <- Codebase.branchHashLength + entries <- getEntries numEntriesToShow + entries + & (fmap . fmap) (\ch -> (ch, SCH.fromHash schLength ch)) + & pure + let moreEntriesToLoad = + if length entries == numEntriesToShow + then Output.MoreEntriesThanShown + else Output.AllEntriesShown + mayNow <- + asks Cli.isTranscriptTest >>= \case + True -> pure Nothing + False -> Just <$> liftIO getCurrentTime + Cli.respondNumbered $ Output.ShowProjectBranchReflog mayNow moreEntriesToLoad entries diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ReleaseDraft.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ReleaseDraft.hs index 13caf9b1ac..e6cdbffc7e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ReleaseDraft.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ReleaseDraft.hs @@ -6,8 +6,8 @@ where import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli -import Unison.Cli.ProjectUtils qualified as ProjectUtils -import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..), doCreateBranch) +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..), createBranch) import Unison.Codebase.Editor.Output qualified as Output import Unison.Prelude import Unison.Project (Semver) @@ -16,15 +16,15 @@ import Witch (unsafeFrom) -- | Handle a @release.draft@ command. handleReleaseDraft :: Semver -> Cli () handleReleaseDraft ver = do - currentProjectAndBranch <- fst <$> ProjectUtils.expectCurrentProjectBranch + currentProjectAndBranch <- Cli.getCurrentProjectAndBranch let branchName = unsafeFrom @Text ("releases/drafts/" <> into @Text ver) _ <- - doCreateBranch - (CreateFrom'Branch currentProjectAndBranch) - (currentProjectAndBranch ^. #project) - branchName + createBranch ("release.draft " <> into @Text ver) + (CreateFrom'ParentBranch (currentProjectAndBranch ^. #branch)) + (currentProjectAndBranch ^. #project) + (pure branchName) Cli.respond (Output.DraftingRelease branchName ver) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs index dcb684b168..91d0329c6c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs @@ -13,7 +13,6 @@ import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.NamesUtils qualified as Cli -import Unison.Cli.PrettyPrintUtils qualified as Cli import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.HandleInput.Load (EvalMode (Native, Permissive), evalUnisonFile) import Unison.Codebase.Editor.Output qualified as Output @@ -25,7 +24,9 @@ import Unison.Name (Name) import Unison.Parser.Ann (Ann (External)) import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE +import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED +import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Reference qualified as Reference import Unison.Result qualified as Result import Unison.Symbol (Symbol) @@ -40,6 +41,9 @@ import Unison.Typechecker.TypeLookup qualified as TypeLookup import Unison.UnisonFile (TypecheckedUnisonFile) import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UF +import Unison.Util.Defns (Defns (..)) +import Unison.Util.Monoid qualified as Monoid +import Unison.Util.Recursion import Unison.Var qualified as Var handleRun :: Bool -> HQ.HashQualified Name -> [String] -> Cli () @@ -50,10 +54,12 @@ handleRun native main args = do pure (uf, otyp) names <- Cli.currentNames let namesWithFileDefinitions = UF.addNamesFromTypeCheckedUnisonFile unisonFile names - pped <- Cli.prettyPrintEnvDeclFromNames namesWithFileDefinitions + let pped = PPED.makePPED (PPE.hqNamer 10 namesWithFileDefinitions) (PPE.suffixifyByHash namesWithFileDefinitions) let suffixifiedPPE = PPED.suffixifiedPPE pped let mode | native = Native | otherwise = Permissive - (_, xs) <- evalUnisonFile mode suffixifiedPPE unisonFile args + (_, xs) <- + evalUnisonFile mode suffixifiedPPE unisonFile args & onLeftM \err -> + Cli.returnEarly (Output.EvaluationFailure err) mainRes :: Term Symbol () <- case lookup magicMainWatcherString (map bonk (Map.toList xs)) of Nothing -> @@ -82,12 +88,14 @@ getTerm main = getTerm' main >>= \case NoTermWithThatName -> do mainType <- Runtime.mainType <$> view #runtime - pped <- Cli.currentPrettyPrintEnvDecl + names <- Cli.currentNames + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) let suffixifiedPPE = PPED.suffixifiedPPE pped Cli.returnEarly $ Output.NoMainFunction main suffixifiedPPE [mainType] TermHasBadType ty -> do mainType <- Runtime.mainType <$> view #runtime - pped <- Cli.currentPrettyPrintEnvDecl + names <- Cli.currentNames + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) let suffixifiedPPE = PPED.suffixifiedPPE pped Cli.returnEarly $ Output.BadMainFunction "run" main ty suffixifiedPPE [mainType] GetTermSuccess x -> pure x @@ -105,7 +113,7 @@ getTerm' mainName = mainToFile (MainTerm.BadType _ ty) = pure $ maybe NoTermWithThatName TermHasBadType ty mainToFile (MainTerm.Success hq tm typ) = let v = Var.named (HQ.toText hq) - in checkType typ \otyp -> + in checkType Nothing typ \otyp -> pure (GetTermSuccess (v, tm, typ, otyp)) getFromFile uf = do let components = join $ UF.topLevelComponents uf @@ -113,19 +121,22 @@ getTerm' mainName = let mainComponent = filter ((\v -> Var.name v == HQ.toText mainName) . view _1) components case mainComponent of [(v, _, tm, ty)] -> - checkType ty \otyp -> + checkType (Just uf) ty \otyp -> let runMain = DD.forceTerm a a (Term.var a v) v2 = Var.freshIn (Set.fromList [v]) v a = ABT.annotation tm in pure (GetTermSuccess (v2, runMain, ty, otyp)) _ -> getFromCodebase - checkType :: Type Symbol Ann -> (Type Symbol Ann -> Cli GetTermResult) -> Cli GetTermResult - checkType ty f = do + checkType :: Maybe (TypecheckedUnisonFile Symbol Ann) -> Type Symbol Ann -> (Type Symbol Ann -> Cli GetTermResult) -> Cli GetTermResult + checkType mayTuf ty f = do Cli.Env {codebase, runtime} <- ask case Typechecker.fitsScheme ty (Runtime.mainType runtime) of True -> do - typeLookup <- Cli.runTransaction (Codebase.typeLookupForDependencies codebase (Type.dependencies ty)) - f $! synthesizeForce typeLookup ty + tlCodebase <- + Cli.runTransaction $ + Codebase.typeLookupForDependencies codebase Defns {terms = Set.empty, types = Type.dependencies ty} + let tlTuf = Monoid.fromMaybe (fmap UF.typecheckedToTypeLookup mayTuf) + f $! synthesizeForce (tlTuf <> tlCodebase) ty False -> pure (TermHasBadType ty) in Cli.getLatestTypecheckedFile >>= \case Nothing -> getFromCodebase @@ -159,7 +170,8 @@ synthesizeForce tl typeOfFunc = do Typechecker.Env { ambientAbilities = [DD.exceptionType External, Type.builtinIO External], typeLookup = mempty {TypeLookup.typeOfTerms = Map.singleton ref typeOfFunc} <> tl, - termsByShortname = Map.empty + termsByShortname = Map.empty, + topLevelComponents = Map.empty } case Result.runResultT ( Typechecker.synthesize @@ -194,7 +206,7 @@ stripUnisonFileReferences :: TypecheckedUnisonFile Symbol a -> Term Symbol () -> stripUnisonFileReferences unisonFile term = let refMap :: Map Reference.Id Symbol refMap = Map.fromList . map (\(sym, (_, refId, _, _, _)) -> (refId, sym)) . Map.toList . UF.hashTermsId $ unisonFile - alg () = \case + alg (ABT.Term' _ () abt) = case abt of ABT.Var x -> ABT.var x ABT.Cycle x -> ABT.cycle x ABT.Abs v x -> ABT.abs v x @@ -202,7 +214,7 @@ stripUnisonFileReferences unisonFile term = Term.Ref ref | Just var <- (\k -> Map.lookup k refMap) =<< Reference.toId ref -> ABT.var var x -> ABT.tm x - in ABT.cata alg term + in cata alg term magicMainWatcherString :: String magicMainWatcherString = "main" diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/RuntimeUtils.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/RuntimeUtils.hs index df86793ff4..96f2b098fa 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/RuntimeUtils.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/RuntimeUtils.hs @@ -3,6 +3,8 @@ module Unison.Codebase.Editor.HandleInput.RuntimeUtils evalUnisonTermE, evalPureUnison, displayDecompileErrors, + selectRuntime, + EvalMode (..), ) where @@ -13,6 +15,7 @@ import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Output +import Unison.Codebase.Execute qualified as Codebase import Unison.Codebase.Runtime qualified as Runtime import Unison.Hashing.V2.Convert qualified as Hashing import Unison.Parser.Ann (Ann (..)) @@ -27,6 +30,15 @@ import Unison.Term qualified as Term import Unison.Util.Pretty qualified as P import Unison.WatchKind qualified as WK +data EvalMode = Sandboxed | Permissive | Native + +selectRuntime :: EvalMode -> Cli (Runtime.Runtime Symbol) +selectRuntime mode = + ask <&> \Cli.Env {runtime, sandboxedRuntime, nativeRuntime} -> case mode of + Permissive -> runtime + Sandboxed -> sandboxedRuntime + Native -> nativeRuntime + displayDecompileErrors :: [Runtime.Error] -> Cli () displayDecompileErrors errs = Cli.respond (PrintMessage msg) where @@ -40,14 +52,14 @@ displayDecompileErrors errs = Cli.respond (PrintMessage msg) -- | Evaluate a single closed definition. evalUnisonTermE :: - Bool -> + EvalMode -> PPE.PrettyPrintEnv -> Bool -> Term Symbol Ann -> Cli (Either Runtime.Error (Term Symbol Ann)) -evalUnisonTermE sandbox ppe useCache tm = do - Cli.Env {codebase, runtime, sandboxedRuntime} <- ask - let theRuntime = if sandbox then sandboxedRuntime else runtime +evalUnisonTermE mode ppe useCache tm = do + Cli.Env {codebase} <- ask + theRuntime <- selectRuntime mode let watchCache :: Reference.Id -> IO (Maybe (Term Symbol ())) watchCache ref = do @@ -55,7 +67,7 @@ evalUnisonTermE sandbox ppe useCache tm = do pure (Term.amap (\(_ :: Ann) -> ()) <$> maybeTerm) let cache = if useCache then watchCache else Runtime.noCache - r <- liftIO (Runtime.evaluateTerm' (Codebase.toCodeLookup codebase) cache ppe theRuntime tm) + r <- liftIO (Runtime.evaluateTerm' (Codebase.codebaseToCodeLookup codebase) cache ppe theRuntime tm) when useCache do case r of Right (errs, tmr) @@ -72,22 +84,25 @@ evalUnisonTermE sandbox ppe useCache tm = do -- | Evaluate a single closed definition. evalUnisonTerm :: - Bool -> + EvalMode -> PPE.PrettyPrintEnv -> Bool -> Term Symbol Ann -> Cli (Term Symbol Ann) -evalUnisonTerm sandbox ppe useCache tm = - evalUnisonTermE sandbox ppe useCache tm & onLeftM \err -> +evalUnisonTerm mode ppe useCache tm = + evalUnisonTermE mode ppe useCache tm & onLeftM \err -> Cli.returnEarly (EvaluationFailure err) evalPureUnison :: + Bool -> PPE.PrettyPrintEnv -> Bool -> Term Symbol Ann -> Cli (Either Runtime.Error (Term Symbol Ann)) -evalPureUnison ppe useCache tm = evalUnisonTermE False ppe useCache tm' +evalPureUnison native ppe useCache tm = + evalUnisonTermE mode ppe useCache tm' where + mode = if native then Native else Permissive tm' = Term.iff a diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ShowDefinition.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ShowDefinition.hs index 0c4cfada13..2d451150ea 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ShowDefinition.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ShowDefinition.hs @@ -1,31 +1,104 @@ -module Unison.Codebase.Editor.HandleInput.ShowDefinition (showDefinitions) where +module Unison.Codebase.Editor.HandleInput.ShowDefinition + ( handleShowDefinition, + showDefinitions, + ) +where import Control.Lens import Control.Monad.Reader (ask) import Control.Monad.State qualified as State +import Data.List qualified as List +import Data.List.NonEmpty qualified as List (NonEmpty) +import Data.List.NonEmpty qualified as List.NonEmpty import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text import Unison.Builtin.Decls qualified as DD import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Cli.NamesUtils qualified as Cli import Unison.Cli.Pretty qualified as Pretty import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Branch.Names qualified as Branch import Unison.Codebase.Editor.DisplayObject (DisplayObject) -import Unison.Codebase.Editor.Input +import Unison.Codebase.Editor.Input (OutputLocation (..), RelativeToFold (..), ShowDefinitionScope (..)) import Unison.Codebase.Editor.Output import Unison.DataDeclaration (Decl) +import Unison.DataDeclaration qualified as DD import Unison.HashQualified qualified as HQ import Unison.Name (Name) +import Unison.Name qualified as Name +import Unison.Names qualified as Names +import Unison.NamesWithHistory qualified as Names import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.PrettyPrintEnv qualified as PPE +import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED +import Unison.PrettyPrintEnvDecl.Names qualified as PPED +import Unison.Reference (Reference, TermReferenceId) import Unison.Reference qualified as Reference +import Unison.Referent qualified as Referent +import Unison.Server.Backend qualified as Backend +import Unison.Server.NameSearch.FromNames qualified as NameSearch import Unison.Symbol (Symbol) +import Unison.Syntax.Name qualified as Name (toVar) +import Unison.Syntax.NamePrinter (SyntaxText) import Unison.Term (Term) import Unison.Type (Type) +import Unison.UnisonFile (TypecheckedUnisonFile (..), UnisonFile (..)) +import Unison.UnisonFile qualified as UnisonFile +import Unison.Util.Defns (Defns (..)) +import Unison.Util.Pretty (Pretty) import Unison.Util.Pretty qualified as Pretty import Unison.Util.Set qualified as Set +import Unison.WatchKind qualified as WatchKind + +-- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. +handleShowDefinition :: OutputLocation -> ShowDefinitionScope -> List.NonEmpty (HQ.HashQualified Name) -> Cli () +handleShowDefinition outputLoc showDefinitionScope query = do + env <- ask + + let hasAbsoluteQuery = any (any Name.isAbsolute) query + (names, unbiasedPPED) <- case (hasAbsoluteQuery, showDefinitionScope) of + -- TODO: We should instead print each definition using the names from its project-branch root. + (True, _) -> do + root <- Cli.getCurrentProjectRoot + let root0 = Branch.head root + let names = Names.makeAbsolute (Branch.toNames root0) + let pped = PPED.makePPED (PPE.hqNamer 10 names) (suffixify names) + pure (names, pped) + (_, ShowDefinitionGlobal) -> do + -- TODO: Maybe rewrite to be properly global + root <- Cli.getCurrentProjectRoot + let root0 = Branch.head root + let names = Names.makeAbsolute $ Branch.toNames root0 + let pped = PPED.makePPED (PPE.hqNamer 10 names) (suffixify names) + pure (names, pped) + (_, ShowDefinitionLocal) -> do + currentNames <- Cli.currentNames + let pped = PPED.makePPED (PPE.hqNamer 10 currentNames) (suffixify currentNames) + pure (currentNames, pped) + let pped = PPED.biasTo (mapMaybe HQ.toName (List.NonEmpty.toList query)) unbiasedPPED + Backend.DefinitionResults terms types misses <- do + let nameSearch = NameSearch.makeNameSearch 10 names + Cli.runTransaction (Backend.definitionsByName env.codebase nameSearch includeCycles Names.IncludeSuffixes (toList query)) + showDefinitions outputLoc pped terms types misses + where + suffixify = + case outputLoc of + ConsoleLocation -> PPE.suffixifyByHash + FileLocation _ _ -> PPE.suffixifyByHashName + LatestFileLocation _ -> PPE.suffixifyByHashName + + -- `view`: don't include cycles; `edit`: include cycles + includeCycles = + case outputLoc of + ConsoleLocation -> Backend.DontIncludeCycles + FileLocation _ _ -> Backend.IncludeCycles + LatestFileLocation _ -> Backend.IncludeCycles -- | Show the provided definitions to console or scratch file. -- The caller is responsible for ensuring that the definitions include cycles if that's @@ -41,7 +114,7 @@ showDefinitions :: [HQ.HashQualified Name] -> Cli () showDefinitions outputLoc pped terms types misses = do - Cli.Env {codebase, writeSource} <- ask + env <- ask outputPath <- getOutputPath case outputPath of _ | null terms && null types -> pure () @@ -50,37 +123,130 @@ showDefinitions outputLoc pped terms types misses = do let isTest _ = False let isSourceFile = False -- No filepath, render code to console. - let renderedCodePretty = renderCodePretty pped isSourceFile isTest terms types + let (renderedCodePretty, _numRendered) = + renderCodePretty + pped + isSourceFile + isTest + terms + types + (Defns Set.empty Set.empty) Cli.respond $ DisplayDefinitions renderedCodePretty - Just fp -> do + Just (fp, relToFold) -> do + -- Of all the names we were asked to show, if this is a `WithinFold` showing, then exclude the ones that are + -- already bound in the file + excludeNames <- + case relToFold of + AboveFold -> pure (Defns Set.empty Set.empty) + WithinFold -> + use #latestTypecheckedFile <&> \case + Nothing -> Defns Set.empty Set.empty + Just (Left unisonFile) -> + let boundTermNames = Map.keysSet unisonFile.terms + boundTestWatchNames = + Map.toList unisonFile.watches + & foldMap \case + (WatchKind.TestWatch, watches) -> Set.fromList (map (view _1) watches) + _ -> Set.empty + boundDataDeclNames = Map.keysSet unisonFile.dataDeclarationsId + boundEffectDeclNames = Map.keysSet unisonFile.effectDeclarationsId + in Defns + { terms = boundTermNames <> boundTestWatchNames, + types = boundDataDeclNames <> boundEffectDeclNames + } + Just (Right typecheckedUnisonFile) -> + let boundTermNames = foldMap (Set.fromList . map (view _1)) typecheckedUnisonFile.topLevelComponents' + boundTestWatchNames = + typecheckedUnisonFile.watchComponents & foldMap \case + (WatchKind.TestWatch, watches) -> Set.fromList (map (view _1) watches) + _ -> Set.empty + in Defns + { terms = boundTermNames <> boundTestWatchNames, + types = UnisonFile.typeNamespaceBindings typecheckedUnisonFile + } + -- We build an 'isTest' check to prepend "test>" to tests in a scratch file. - testRefs <- Cli.runTransaction (Codebase.filterTermsByReferenceIdHavingType codebase (DD.testResultListType mempty) (Map.keysSet terms & Set.mapMaybe Reference.toId)) + testRefs <- + Cli.runTransaction do + Codebase.filterTermsByReferenceIdHavingType + env.codebase + (DD.testResultListType mempty) + (Map.keysSet terms & Set.mapMaybe Reference.toId) let isTest r = Set.member r testRefs let isSourceFile = True - let renderedCodePretty = renderCodePretty pped isSourceFile isTest terms types - let renderedCodeText = Text.pack $ Pretty.toPlain 80 renderedCodePretty + let (renderedCodePretty, numRendered) = renderCodePretty pped isSourceFile isTest terms types excludeNames + when (numRendered > 0) do + let renderedCodeText = Text.pack $ Pretty.toPlain 80 renderedCodePretty + + -- We set latestFile to be programmatically generated, if we + -- are viewing these definitions to a file - this will skip the + -- next update for that file (which will happen immediately) + #latestFile ?= (fp, True) + liftIO $ + env.writeSource (Text.pack fp) renderedCodeText case relToFold of + AboveFold -> True + WithinFold -> False + Cli.respond $ LoadedDefinitionsToSourceFile fp numRendered - -- We set latestFile to be programmatically generated, if we - -- are viewing these definitions to a file - this will skip the - -- next update for that file (which will happen immediately) - #latestFile ?= (fp, True) - liftIO $ writeSource (Text.pack fp) renderedCodeText - let numDefinitions = Map.size terms + Map.size types - Cli.respond $ LoadedDefinitionsToSourceFile fp numDefinitions when (not (null misses)) (Cli.respond (SearchTermsNotFound misses)) where -- Get the file path to send the definition(s) to. `Nothing` means the terminal. - getOutputPath :: Cli (Maybe FilePath) + getOutputPath :: Cli (Maybe (FilePath, RelativeToFold)) getOutputPath = case outputLoc of ConsoleLocation -> pure Nothing - FileLocation path -> pure (Just path) - LatestFileLocation -> do + FileLocation path relToFold -> pure (Just (path, relToFold)) + LatestFileLocation relToFold -> do loopState <- State.get pure case loopState ^. #latestFile of - Nothing -> Just "scratch.u" - Just (path, _) -> Just path + Nothing -> Just ("scratch.u", relToFold) + Just (path, _) -> Just (path, relToFold) + + renderCodePretty pped isSourceFile isTest terms types excludeNames = + let prettyTypes = prettyTypeDisplayObjects pped types excludeNames.types + prettyTerms = prettyTermDisplayObjects pped isSourceFile isTest terms excludeNames.terms + in ( Pretty.syntaxToColor (Pretty.sep "\n\n" (prettyTypes ++ prettyTerms)), + length prettyTerms + length prettyTypes + ) - renderCodePretty pped isSourceFile isTest terms types = - Pretty.syntaxToColor . Pretty.sep "\n\n" $ - Pretty.prettyTypeDisplayObjects pped types <> Pretty.prettyTermDisplayObjects pped isSourceFile isTest terms +prettyTypeDisplayObjects :: + PPED.PrettyPrintEnvDecl -> + (Map Reference (DisplayObject () (DD.Decl Symbol Ann))) -> + Set Symbol -> + [Pretty SyntaxText] +prettyTypeDisplayObjects pped types excludeNames = + types + & Map.toList + & mapMaybe + ( \(ref, dt) -> do + let hqName = PPE.typeName unsuffixifiedPPE ref + whenJust (HQ.toName hqName) \name -> + guard (Set.notMember (Name.toVar name) excludeNames) + Just (hqName, ref, dt) + ) + & List.sortBy (\(n0, _, _) (n1, _, _) -> Name.compareAlphabetical n0 n1) + & map (Pretty.prettyType pped) + where + unsuffixifiedPPE = PPED.unsuffixifiedPPE pped + +prettyTermDisplayObjects :: + PPED.PrettyPrintEnvDecl -> + Bool -> + (TermReferenceId -> Bool) -> + (Map Reference.TermReference (DisplayObject (Type Symbol Ann) (Term Symbol Ann))) -> + Set Symbol -> + [Pretty SyntaxText] +prettyTermDisplayObjects pped isSourceFile isTest terms excludeNames = + terms + & Map.toList + & mapMaybe + ( \(ref, dt) -> do + let hqName = PPE.termName unsuffixifiedPPE (Referent.Ref ref) + whenJust (HQ.toName hqName) \name -> + guard (Set.notMember (Name.toVar name) excludeNames) + Just (hqName, ref, dt) + ) + & List.sortBy (\(n0, _, _) (n1, _, _) -> Name.compareAlphabetical n0 n1) + & map (\t -> Pretty.prettyTerm pped isSourceFile (fromMaybe False . fmap isTest . Reference.toId $ (t ^. _2)) t) + where + unsuffixifiedPPE = PPED.unsuffixifiedPPE pped diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs index a63ab11a0b..ddc2fe39d2 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs @@ -15,7 +15,6 @@ import Data.Set (fromList, toList) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.NamesUtils qualified as Cli -import Unison.Cli.PrettyPrintUtils qualified as Cli import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Output (Output (..)) import Unison.Codebase.Path (hqSplitFromName') @@ -27,7 +26,9 @@ import Unison.Names (Names) import Unison.NamesWithHistory qualified as Names import Unison.Parser.Ann (Ann) import Unison.PrettyPrintEnv (PrettyPrintEnv) +import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED +import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Reference (Reference) import Unison.Referent (Referent, pattern Con, pattern Ref) import Unison.Symbol (Symbol) @@ -74,7 +75,7 @@ lookupTermRefWithType codebase name = do resolveTerm :: HQ.HashQualified Name -> Cli Referent resolveTerm name = do names <- Cli.currentNames - pped <- Cli.prettyPrintEnvDeclFromNames names + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) let suffixifiedPPE = PPED.suffixifiedPPE pped case lookupTerm name names of [] -> Cli.returnEarly (TermNotFound $ fromJust parsed) @@ -87,7 +88,7 @@ resolveTerm name = do resolveCon :: HQ.HashQualified Name -> Cli ConstructorReference resolveCon name = do names <- Cli.currentNames - pped <- Cli.prettyPrintEnvDeclFromNames names + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) let suffixifiedPPE = PPED.suffixifiedPPE pped case lookupCon name names of ([], _) -> Cli.returnEarly (TermNotFound $ fromJust parsed) @@ -100,7 +101,7 @@ resolveCon name = do resolveTermRef :: HQ.HashQualified Name -> Cli Reference resolveTermRef name = do names <- Cli.currentNames - pped <- Cli.prettyPrintEnvDeclFromNames names + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) let suffixifiedPPE = PPED.suffixifiedPPE pped case lookupTermRefs name names of ([], _) -> Cli.returnEarly (TermNotFound $ fromJust parsed) @@ -114,7 +115,7 @@ resolveMainRef :: HQ.HashQualified Name -> Cli (Reference, PrettyPrintEnv) resolveMainRef main = do Cli.Env {codebase, runtime} <- ask names <- Cli.currentNames - pped <- Cli.prettyPrintEnvDeclFromNames names + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) let suffixifiedPPE = PPED.suffixifiedPPE pped let mainType = Runtime.mainType runtime lookupTermRefWithType codebase main >>= \case diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs index 3eb3658004..867fed7704 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs @@ -14,16 +14,15 @@ import Data.Map qualified as Map import Data.Set qualified as Set import Data.Set.NonEmpty (NESet) import Data.Set.NonEmpty qualified as NESet -import Data.Tuple qualified as Tuple import Unison.ABT qualified as ABT import Unison.Builtin.Decls qualified as DD import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.NamesUtils qualified as Cli -import Unison.Cli.PrettyPrintUtils qualified as Cli import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Editor.HandleInput.RuntimeUtils (EvalMode (..)) import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils import Unison.Codebase.Editor.Input (TestInput (..)) import Unison.Codebase.Editor.Output @@ -39,7 +38,9 @@ import Unison.NamesWithHistory qualified as Names import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE +import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED +import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Reference (TermReferenceId) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent @@ -59,8 +60,8 @@ import Unison.WatchKind qualified as WK -- | Handle a @test@ command. -- Run pure tests in the current subnamespace. -handleTest :: TestInput -> Cli () -handleTest TestInput {includeLibNamespace, path, showFailures, showSuccesses} = do +handleTest :: Bool -> TestInput -> Cli () +handleTest native TestInput {includeLibNamespace, path, showFailures, showSuccesses} = do Cli.Env {codebase} <- ask testRefs <- findTermsOfTypes codebase includeLibNamespace path (NESet.singleton (DD.testResultListType mempty)) @@ -69,29 +70,32 @@ handleTest TestInput {includeLibNamespace, path, showFailures, showSuccesses} = Map.fromList <$> Cli.runTransaction do Set.toList testRefs & wither \case rid -> fmap (rid,) <$> Codebase.getWatch codebase WK.TestWatch rid - let (oks, fails) = passFails cachedTests - passFails :: (Ord r) => Map r (Term v a) -> ([(r, Text)], [(r, Text)]) - passFails = Tuple.swap . partitionEithers . concat . map p . Map.toList + let (fails, oks) = passFails cachedTests + passFails :: (Ord r) => Map r (Term v a) -> (Map r [Text], Map r [Text]) + passFails = + Map.foldrWithKey + (\r v (f, o) -> bimap (\ts -> if null ts then f else Map.insert r ts f) (\ts -> if null ts then o else Map.insert r ts o) . partitionEithers $ p v) + (Map.empty, Map.empty) where - p :: (r, Term v a) -> [Either (r, Text) (r, Text)] - p (r, tm) = case tm of - Term.List' ts -> mapMaybe (q r) (toList ts) + p :: Term v a -> [Either Text Text] + p = \case + Term.List' ts -> mapMaybe q $ toList ts _ -> [] - q r = \case + q = \case Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) -> if - | ref == DD.testResultRef -> - if - | cid == DD.okConstructorId -> Just (Right (r, msg)) - | cid == DD.failConstructorId -> Just (Left (r, msg)) - | otherwise -> Nothing - | otherwise -> Nothing + | ref == DD.testResultRef -> + if + | cid == DD.okConstructorId -> Just (Right msg) + | cid == DD.failConstructorId -> Just (Left msg) + | otherwise -> Nothing + | otherwise -> Nothing _ -> Nothing let stats = Output.CachedTests (Set.size testRefs) (Map.size cachedTests) names <- Cli.currentNames - pped <- Cli.prettyPrintEnvDeclFromNames names + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) let fqnPPE = PPED.unsuffixifiedPPE pped - Cli.respond $ + Cli.respondNumbered $ TestResults stats fqnPPE @@ -111,7 +115,7 @@ handleTest TestInput {includeLibNamespace, path, showFailures, showSuccesses} = Just tm -> do Cli.respond $ TestIncrementalOutputStart fqnPPE (n, total) r -- v don't cache; test cache populated below - tm' <- RuntimeUtils.evalPureUnison fqnPPE False tm + tm' <- RuntimeUtils.evalPureUnison native fqnPPE False tm case tm' of Left e -> do Cli.respond (EvaluationFailure e) @@ -123,23 +127,28 @@ handleTest TestInput {includeLibNamespace, path, showFailures, showSuccesses} = pure [(r, tm')] let m = Map.fromList computedTests - (mOks, mFails) = passFails m - Cli.respond $ TestResults Output.NewlyComputed fqnPPE showSuccesses showFailures mOks mFails + (mFails, mOks) = passFails m + Cli.respondNumbered $ TestResults Output.NewlyComputed fqnPPE showSuccesses showFailures mOks mFails -handleIOTest :: HQ.HashQualified Name -> Cli () -handleIOTest main = do - Cli.Env {runtime} <- ask +handleIOTest :: Bool -> HQ.HashQualified Name -> Cli () +handleIOTest native main = do + let mode = if native then Native else Permissive + runtime <- RuntimeUtils.selectRuntime mode names <- Cli.currentNames - pped <- Cli.prettyPrintEnvDeclFromNames names + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) let suffixifiedPPE = PPED.suffixifiedPPE pped let isIOTest typ = Foldable.any (Typechecker.isSubtype typ) $ Runtime.ioTestTypes runtime refs <- resolveHQNames names (Set.singleton main) (fails, oks) <- - refs & foldMapM \(ref, typ) -> do - when (not $ isIOTest typ) do - Cli.returnEarly (BadMainFunction "io.test" main typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime)) - runIOTest suffixifiedPPE ref - Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails + Foldable.foldrM + ( \(ref, typ) (f, o) -> do + when (not $ isIOTest typ) $ + Cli.returnEarly (BadMainFunction "io.test" main typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime)) + bimap (\ts -> if null ts then f else Map.insert ref ts f) (\ts -> if null ts then o else Map.insert ref ts o) <$> runIOTest suffixifiedPPE ref + ) + (Map.empty, Map.empty) + refs + Cli.respondNumbered $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails findTermsOfTypes :: Codebase.Codebase m Symbol Ann -> Bool -> Path -> NESet (Type.Type Symbol Ann) -> Cli (Set TermReferenceId) findTermsOfTypes codebase includeLib path filterTypes = do @@ -155,24 +164,31 @@ findTermsOfTypes codebase includeLib path filterTypes = do filterTypes & foldMapM \matchTyp -> do Codebase.filterTermsByReferenceIdHavingType codebase matchTyp possibleTests -handleAllIOTests :: Cli () -handleAllIOTests = do - Cli.Env {codebase, runtime} <- ask +handleAllIOTests :: Bool -> Cli () +handleAllIOTests native = do + Cli.Env {codebase} <- ask + let mode = if native then Native else Permissive + runtime <- RuntimeUtils.selectRuntime mode names <- Cli.currentNames - pped <- Cli.prettyPrintEnvDeclFromNames names + let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) let suffixifiedPPE = PPED.suffixifiedPPE pped ioTestRefs <- findTermsOfTypes codebase False Path.empty (Runtime.ioTestTypes runtime) case NESet.nonEmptySet ioTestRefs of - Nothing -> Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True [] [] + Nothing -> Cli.respondNumbered $ TestResults Output.NewlyComputed suffixifiedPPE True True Map.empty Map.empty Just neTestRefs -> do let total = NESet.size neTestRefs (fails, oks) <- - toList neTestRefs & zip [1 :: Int ..] & foldMapM \(n, r) -> do - Cli.respond $ TestIncrementalOutputStart suffixifiedPPE (n, total) r - (fails, oks) <- runIOTest suffixifiedPPE r - Cli.respond $ TestIncrementalOutputEnd suffixifiedPPE (n, total) r (null fails) - pure (fails, oks) - Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails + toList neTestRefs + & zip [1 :: Int ..] + & Foldable.foldrM + ( \(n, r) (f, o) -> do + Cli.respond $ TestIncrementalOutputStart suffixifiedPPE (n, total) r + (fails, oks) <- runIOTest suffixifiedPPE r + Cli.respond $ TestIncrementalOutputEnd suffixifiedPPE (n, total) r (null fails) + pure (if null fails then f else Map.insert r fails f, if null oks then o else Map.insert r oks o) + ) + (Map.empty, Map.empty) + Cli.respondNumbered $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails resolveHQNames :: Names -> Set (HQ.HashQualified Name) -> Cli (Set (Reference.Id, Type.Type Symbol Ann)) resolveHQNames parseNames hqNames = @@ -197,19 +213,16 @@ resolveHQNames parseNames hqNames = typ <- MaybeT (Codebase.getTypeOfReferent codebase (Referent.fromTermReferenceId ref)) pure (ref, typ) -runIOTest :: PPE.PrettyPrintEnv -> Reference.Id -> Cli ([(Reference.Id, Text)], [(Reference.Id, Text)]) +runIOTest :: PPE.PrettyPrintEnv -> Reference.Id -> Cli ([Text], [Text]) runIOTest ppe ref = do let a = ABT.annotation tm tm = DD.forceTerm a a (Term.refId a ref) -- Don't cache IO tests - tm' <- RuntimeUtils.evalUnisonTerm False ppe False tm - pure $ partitionTestResults [(ref, tm')] + tm' <- RuntimeUtils.evalUnisonTerm Permissive ppe False tm + pure $ partitionTestResults tm' -partitionTestResults :: - [(Reference.Id, Term Symbol Ann)] -> - ([(Reference.Id, Text {- fails -})], [(Reference.Id, Text {- oks -})]) -partitionTestResults results = fold $ do - (ref, tm) <- results +partitionTestResults :: Term Symbol Ann -> ([Text {- fails -}], [Text {- oks -}]) +partitionTestResults tm = fold $ do element <- case tm of Term.List' ts -> toList ts _ -> empty @@ -217,9 +230,9 @@ partitionTestResults results = fold $ do Term.App' (Term.Constructor' (ConstructorReference conRef cid)) (Term.Text' msg) -> do guard (conRef == DD.testResultRef) if - | cid == DD.okConstructorId -> pure (mempty, [(ref, msg)]) - | cid == DD.failConstructorId -> pure ([(ref, msg)], mempty) - | otherwise -> empty + | cid == DD.okConstructorId -> pure (mempty, [msg]) + | cid == DD.failConstructorId -> pure ([msg], mempty) + | otherwise -> empty _ -> empty isTestOk :: Term v Ann -> Bool diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Todo.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Todo.hs new file mode 100644 index 0000000000..2f08a72a6d --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Todo.hs @@ -0,0 +1,97 @@ +-- | @todo@ input handler +module Unison.Codebase.Editor.HandleInput.Todo + ( handleTodo, + ) +where + +import Data.Either qualified as Either +import Data.Set qualified as Set +import U.Codebase.HashTags (BranchHash (..)) +import U.Codebase.Sqlite.Operations qualified as Operations +import Unison.Builtin qualified as Builtin +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Branch.Names qualified as Branch +import Unison.Codebase.Causal qualified as Causal +import Unison.Codebase.Editor.HandleInput.Merge2 (hasDefnsInLib) +import Unison.Codebase.Editor.Output +import Unison.Hash (HashFor (..)) +import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReasons (..), checkAllDeclCoherency) +import Unison.Names qualified as Names +import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE +import Unison.PrettyPrintEnvDecl.Names qualified as PPED +import Unison.Reference (TermReference) +import Unison.Syntax.Name qualified as Name +import Unison.Util.Defns (Defns (..)) +import Unison.Util.Set qualified as Set + +handleTodo :: Cli () +handleTodo = do + -- For now, we don't go through any great trouble to seek out the root of the project branch. Just assume the current + -- namespace is the root, which will be the case unless the user uses `deprecated.cd`. + currentCausal <- Cli.getCurrentBranch + let currentNamespace = Branch.head currentCausal + let currentNamespaceWithoutLibdeps = Branch.deleteLibdeps currentNamespace + + (defnsInLib, dependentsOfTodo, directDependencies, hashLen, incoherentDeclReasons) <- + Cli.runTransaction do + -- We call a shared `hasDefnsLib` helper even though we could easily duplicate the logic with the branch in hand + defnsInLib <- do + branch <- + currentCausal + & Branch._history + & Causal.valueHash + & coerce @_ @BranchHash + & Operations.expectBranchByBranchHash + hasDefnsInLib branch + + let todoReference :: TermReference + todoReference = + Set.asSingleton (Names.refTermsNamed Builtin.names (Name.unsafeParseText "todo")) + & fromMaybe (error (reportBug "E260496" "No reference for builtin named 'todo'")) + + -- All type-and-term dependents of the `todo` builtin, but we know they're all terms. + dependentsOfTodo <- + Operations.directDependentsWithinScope + (Branch.deepTermReferenceIds currentNamespaceWithoutLibdeps) + (Set.singleton todoReference) + + directDependencies <- + Operations.directDependenciesOfScope + Defns + { terms = Branch.deepTermReferenceIds currentNamespaceWithoutLibdeps, + types = Branch.deepTypeReferenceIds currentNamespaceWithoutLibdeps + } + + hashLen <- Codebase.hashLength + + incoherentDeclReasons <- + fmap (Either.fromLeft (IncoherentDeclReasons [] [] [] [])) $ + checkAllDeclCoherency + Operations.expectDeclNumConstructors + (Names.lenientToNametree (Branch.toNames currentNamespaceWithoutLibdeps)) + + pure (defnsInLib, dependentsOfTodo.terms, directDependencies, hashLen, incoherentDeclReasons) + + let currentNames = Branch.toNames currentNamespace + let ppe = PPED.makePPED (PPE.hqNamer 10 currentNames) (PPE.suffixifyByHash currentNames) + + Cli.respondNumbered $ + Output'Todo + TodoOutput + { defnsInLib, + dependentsOfTodo, + directDependenciesWithoutNames = + Defns + { terms = Set.difference directDependencies.terms (Branch.deepTermReferences currentNamespace), + types = Set.difference directDependencies.types (Branch.deepTypeReferences currentNamespace) + }, + hashLen, + incoherentDeclReasons, + nameConflicts = Names.conflicts (Branch.toNames currentNamespaceWithoutLibdeps), + ppe + } diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs index 85ce5922f5..b80d161674 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs @@ -11,16 +11,14 @@ import U.Codebase.Reference qualified as V2 (Reference) import U.Codebase.Referent qualified as V2 (Referent) import U.Codebase.Referent qualified as V2.Referent import U.Codebase.Sqlite.Project qualified as Project -import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch -import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli -import Unison.Cli.ProjectUtils qualified as Project import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions import Unison.ConstructorType qualified as ConstructorType import Unison.HashQualified qualified as HQ @@ -28,8 +26,7 @@ import Unison.Name (Name) import Unison.Name qualified as Name import Unison.Parser.Ann (Ann (..)) import Unison.Prelude -import Unison.Project (ProjectAndBranch) -import Unison.Project.Util (projectBranchPath) +import Unison.Project (ProjectAndBranch (ProjectAndBranch)) import Unison.Referent qualified as Referent import Unison.Server.CodebaseServer qualified as Server import Unison.Sqlite qualified as Sqlite @@ -39,39 +36,27 @@ import Web.Browser (openBrowser) openUI :: Path.Path' -> Cli () openUI path' = do Cli.Env {serverBaseUrl} <- ask - currentPath <- Cli.getCurrentPath - let absPath = Path.resolve currentPath path' + defnPath <- Cli.resolvePath' path' + pp <- Cli.getCurrentProjectPath whenJust serverBaseUrl \url -> do - Project.getProjectBranchForPath absPath >>= \case - Nothing -> openUIForLooseCode url path' - Just (projectBranch, pathWithinBranch) -> openUIForProject url projectBranch pathWithinBranch + openUIForProject url pp (defnPath ^. PP.absPath_) -openUIForProject :: Server.BaseUrl -> ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Path.Path -> Cli () -openUIForProject url projectAndBranch pathFromProjectRoot = do - currentPath <- Cli.getCurrentPath - perspective <- - Project.getProjectBranchForPath currentPath <&> \case - Nothing -> - -- The current path is outside the project the argument was in. Use the project root - -- as the perspective. - Path.empty - Just (_projectBranch, pathWithinBranch) -> pathWithinBranch +openUIForProject :: Server.BaseUrl -> PP.ProjectPath -> Path.Absolute -> Cli () +openUIForProject url pp@(PP.ProjectPath project projectBranch perspective) defnPath = do mayDefinitionRef <- getDefinitionRef perspective - let projectBranchNames = bimap Project.name ProjectBranch.name projectAndBranch + let projectBranchNames = bimap Project.name ProjectBranch.name (ProjectAndBranch project projectBranch) _success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.ProjectBranchUI projectBranchNames perspective mayDefinitionRef) url pure () where - pathToBranchFromCodebaseRoot :: Path.Absolute - pathToBranchFromCodebaseRoot = projectBranchPath (bimap Project.projectId ProjectBranch.branchId projectAndBranch) -- If the provided ui path matches a definition, find it. - getDefinitionRef :: Path.Path -> Cli (Maybe (Server.DefinitionReference)) + getDefinitionRef :: Path.Absolute -> Cli (Maybe (Server.DefinitionReference)) getDefinitionRef perspective = runMaybeT $ do Cli.Env {codebase} <- lift ask - let absPathToDefinition = Path.unabsolute $ Path.resolve pathToBranchFromCodebaseRoot (Path.Relative pathFromProjectRoot) - (pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc absPathToDefinition - namespaceBranch <- lift $ Cli.runTransaction (Codebase.getShallowBranchAtPath pathToDefinitionNamespace Nothing) + (pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc defnPath + let defnNamespaceProjectPath = pp & PP.absPath_ .~ pathToDefinitionNamespace + namespaceBranch <- lift . Cli.runTransaction $ Codebase.getShallowBranchAtProjectPath defnNamespaceProjectPath fqn <- hoistMaybe $ do - pathFromPerspective <- List.stripPrefix (Path.toList perspective) (Path.toList pathFromProjectRoot) + pathFromPerspective <- List.stripPrefix (Path.toList (Path.unabsolute perspective)) (Path.toList $ Path.unabsolute defnPath) Path.toName . Path.fromList $ pathFromPerspective def <- MaybeT $ getTermOrTypeRef codebase namespaceBranch fqn pure def @@ -89,35 +74,6 @@ getTermOrTypeRef codebase namespaceBranch fqn = runMaybeT $ do pure (toTypeReference fqn oneType) terms <|> types -openUIForLooseCode :: Server.BaseUrl -> Path.Path' -> Cli () -openUIForLooseCode url path' = do - Cli.Env {codebase} <- ask - currentPath <- Cli.getCurrentPath - (perspective, definitionRef) <- getUIUrlParts currentPath path' codebase - _success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.LooseCodeUI perspective definitionRef) url - pure () - -getUIUrlParts :: Path.Absolute -> Path.Path' -> Codebase m Symbol Ann -> Cli (Path.Absolute, Maybe (Server.DefinitionReference)) -getUIUrlParts startPath definitionPath' codebase = do - let absPath = Path.resolve startPath definitionPath' - let perspective = - if Path.isAbsolute definitionPath' - then Path.absoluteEmpty - else startPath - case Lens.unsnoc absPath of - Just (abs, _nameSeg) -> do - namespaceBranch <- - Cli.runTransaction - (Codebase.getShallowBranchAtPath (Path.unabsolute abs) Nothing) - mayDefRef <- runMaybeT do - name <- hoistMaybe $ Path.toName $ Path.fromPath' definitionPath' - MaybeT $ getTermOrTypeRef codebase namespaceBranch name - case mayDefRef of - Nothing -> pure (absPath, Nothing) - Just defRef -> pure (perspective, Just defRef) - Nothing -> - pure (absPath, Nothing) - toTypeReference :: Name -> V2.Reference -> Server.DefinitionReference toTypeReference name reference = Server.TypeReference $ diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs index b6bb301056..84ccff1901 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs @@ -17,11 +17,11 @@ import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.NamesUtils qualified as Cli -import Unison.Cli.PrettyPrintUtils qualified as Cli import Unison.Cli.TypeCheck (computeTypecheckingEnvironment) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Branch.Names as Branch import Unison.Codebase.BranchUtil qualified as BranchUtil import Unison.Codebase.Editor.Input import Unison.Codebase.Editor.Output @@ -35,6 +35,7 @@ import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.TermEdit qualified as TermEdit import Unison.Codebase.TypeEdit qualified as TypeEdit import Unison.DataDeclaration (Decl) @@ -45,7 +46,9 @@ import Unison.Names (Names) import Unison.Names qualified as Names import Unison.Parser.Ann (Ann (..)) import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo) +import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Reference (Reference, TermReference, TermReferenceId, TypeReference, TypeReferenceId) import Unison.Reference qualified as Reference import Unison.Referent (Referent) @@ -73,7 +76,8 @@ import Unison.WatchKind (WatchKind) handleUpdate :: Input -> OptionalPatch -> Set Name -> Cli () handleUpdate input optionalPatch requestedNames = do Cli.Env {codebase} <- ask - currentPath' <- Cli.getCurrentPath + ppRoot <- PP.toRoot <$> Cli.getCurrentProjectPath + currentPathAbs <- Cli.getCurrentPath let patchPath = case optionalPatch of NoPatch -> Nothing @@ -165,43 +169,56 @@ handleUpdate input optionalPatch requestedNames = do p' = foldl' step1 p typeEdits step1 p (_, r, r') = Patch.updateType r (TypeEdit.Replace r') p step2 p (_, r, r') = Patch.updateTerm typing r (TermEdit.Replace r' (typing r r')) p - (p, seg) = Path.toAbsoluteSplit currentPath' patchPath + (p, seg) = Path.toAbsoluteSplit currentPathAbs patchPath updatePatches :: (Monad m) => Branch0 m -> m (Branch0 m) updatePatches = Branch.modifyPatches seg updatePatch pure (updatePatch ye'ol'Patch, updatePatches, p) - when (Slurp.hasAddsOrUpdates sr) $ do - -- take a look at the `updates` from the SlurpResult - -- and make a patch diff to record a replacement from the old to new references - Cli.stepManyAtMNoSync - ( [ ( Path.unabsolute currentPath', - pure . doSlurpUpdates typeEdits termEdits termDeprecations - ), - ( Path.unabsolute currentPath', - pure . doSlurpAdds addsAndUpdates (Slurp.originalFile sr) - ) - ] - ++ case patchOps of - Nothing -> [] - Just (_, update, p) -> [(Path.unabsolute p, update)] - ) - Cli.runTransaction - . Codebase.addDefsToCodebase codebase - . Slurp.filterUnisonFile sr - $ Slurp.originalFile sr - let codebaseAndFileNames = UF.addNamesFromTypeCheckedUnisonFile (Slurp.originalFile sr) currentCodebaseNames - pped <- Cli.prettyPrintEnvDeclFromNames codebaseAndFileNames + updatedProjectRootBranch <- + if Slurp.hasAddsOrUpdates sr + then do + -- First add the new definitions to the codebase + Cli.runTransaction + . Codebase.addDefsToCodebase codebase + . Slurp.filterUnisonFile sr + $ Slurp.originalFile sr + projectRootBranch <- Cli.getCurrentProjectRoot + -- take a look at the `updates` from the SlurpResult + -- and make a patch diff to record a replacement from the old to new references + projectRootBranch + & Branch.stepManyAtM + ( [ ( Path.unabsolute currentPathAbs, + pure . doSlurpUpdates typeEdits termEdits termDeprecations + ), + ( Path.unabsolute currentPathAbs, + pure . doSlurpAdds addsAndUpdates (Slurp.originalFile sr) + ) + ] + ++ case patchOps of + Nothing -> [] + Just (_, update, p) -> [(Path.unabsolute p, update)] + ) + & liftIO + else Cli.getCurrentProjectRoot + + projectRootBranchWithPropagatedPatch <- case patchOps of + Nothing -> pure updatedProjectRootBranch + Just (updatedPatch, _, _) -> do + -- Propagate the patch to the whole project. + let scopePath = Path.empty + propagatePatch updatedPatch scopePath updatedProjectRootBranch + let description = case patchPath of + Nothing -> "update.nopatch" + Just p -> + p + & Path.unsplit' + & Path.resolve @_ @_ @Path.Absolute currentPathAbs + & tShow + void $ Cli.updateAt description ppRoot (const projectRootBranchWithPropagatedPatch) + let codebaseAndFileNames = UF.addNamesFromTypeCheckedUnisonFile (Slurp.originalFile sr) (Branch.toNames $ Branch.head projectRootBranchWithPropagatedPatch) + let pped = PPED.makePPED (PPE.hqNamer 10 codebaseAndFileNames) (PPE.suffixifyByHash codebaseAndFileNames) let suffixifiedPPE = PPE.suffixifiedPPE pped Cli.respond $ SlurpOutput input suffixifiedPPE sr - whenJust patchOps \(updatedPatch, _, _) -> - void $ propagatePatchNoSync updatedPatch currentPath' - Cli.syncRoot case patchPath of - Nothing -> "update.nopatch" - Just p -> - p - & Path.unsplit' - & Path.resolve @_ @_ @Path.Absolute currentPath' - & tShow getSlurpResultForUpdate :: Set Name -> Names -> Cli SlurpResult getSlurpResultForUpdate requestedNames slurpCheckNames = do @@ -646,10 +663,11 @@ doSlurpUpdates typeEdits termEdits deprecated b0 = split = Path.splitFromName n -- Returns True if the operation changed the namespace, False otherwise. -propagatePatchNoSync :: Patch -> Path.Absolute -> Cli Bool -propagatePatchNoSync patch scopePath = +propagatePatch :: Patch -> Path.Path -> Branch.Branch IO -> Cli (Branch.Branch IO) +propagatePatch patch scopePath b = do Cli.time "propagatePatchNoSync" do - Cli.stepAtNoSync' (Path.unabsolute scopePath, Propagate.propagateAndApply patch) + let names = Branch.toNames $ Branch.head b + Branch.stepManyAtM [(scopePath, Propagate.propagateAndApply names patch)] b recomponentize :: [(Reference.Id, a)] -> [(Hash, [a])] recomponentize = diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs index 1fb4e5eda4..83a0dbaafd 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs @@ -1,45 +1,27 @@ +-- | @update@ input handler. module Unison.Codebase.Editor.HandleInput.Update2 ( handleUpdate2, -- * Misc helpers to be organized later - addDefinitionsToUnisonFile, - makeUnisonFile, - findCtorNames, - findCtorNamesMaybe, - forwardCtorNames, - makeParsingEnv, - prettyParseTypecheck, - prettyParseTypecheck2, typecheckedUnisonFileToBranchUpdates, - typecheckedUnisonFileToBranchAdds, - getNamespaceDependentsOf, - getNamespaceDependentsOf2, - makeComplicatedPPE, ) where -import Control.Lens qualified as Lens -import Control.Monad.RWS (ask) +import Control.Lens (mapped, (.=)) +import Control.Monad.Reader.Class (ask) import Data.Bifoldable (bifoldMap) import Data.Foldable qualified as Foldable -import Data.List.NonEmpty qualified as NonEmpty -import Data.List.NonEmpty.Extra ((|>)) +import Data.List qualified as List import Data.Map qualified as Map -import Data.Maybe (fromJust) import Data.Set qualified as Set import Data.Text qualified as Text -import Data.Text.Lazy qualified as Lazy.Text -import Text.Pretty.Simple (pShow) -import U.Codebase.Reference (Reference, TermReferenceId) -import U.Codebase.Reference qualified as Reference -import U.Codebase.Sqlite.Operations qualified as Ops -import Unison.Builtin.Decls qualified as Decls -import Unison.Cli.Monad (Cli) +import U.Codebase.Reference (Reference, Reference' (..), TermReferenceId) +import U.Codebase.Sqlite.Operations qualified as Operations +import Unison.Cli.Monad (Cli, Env (..)) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.Pretty qualified as Pretty -import Unison.Cli.TypeCheck (computeTypecheckingEnvironment) -import Unison.Cli.UniqueTypeGuidLookup qualified as Cli +import Unison.Cli.UpdateUtils (getNamespaceDependentsOf2, hydrateDefns, narrowDefns, parseAndTypecheck) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch @@ -49,25 +31,15 @@ import Unison.Codebase.Editor.Output (Output) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path -import Unison.Codebase.Type (Codebase) -import Unison.ConstructorReference (GConstructorReference (ConstructorReference)) -import Unison.DataDeclaration (DataDeclaration, Decl) +import Unison.Codebase.SqliteCodebase.Operations qualified as Operations +import Unison.DataDeclaration (Decl) import Unison.DataDeclaration qualified as Decl -import Unison.DataDeclaration.ConstructorId (ConstructorId) -import Unison.Debug qualified as Debug -import Unison.FileParsers qualified as FileParsers -import Unison.Hash (Hash) +import Unison.DeclNameLookup (DeclNameLookup (..)) +import Unison.Merge qualified as Merge import Unison.Name (Name) -import Unison.Name qualified as Name -import Unison.Name.Forward (ForwardName (..)) -import Unison.Name.Forward qualified as ForwardName -import Unison.NameSegment qualified as NameSegment -import Unison.NameSegment.Internal (NameSegment (NameSegment)) -import Unison.Names (Names (Names)) +import Unison.Names (Names) import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) -import Unison.Parser.Ann qualified as Ann -import Unison.Parsers qualified as Parsers import Unison.Prelude import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl) @@ -77,135 +49,153 @@ import Unison.Reference (TypeReference, TypeReferenceId) import Unison.Reference qualified as Reference (fromId) import Unison.Referent (Referent) import Unison.Referent qualified as Referent -import Unison.Result qualified as Result import Unison.Sqlite (Transaction) import Unison.Symbol (Symbol) +import Unison.Syntax.FilePrinter (renderDefnsForUnisonFile) import Unison.Syntax.Name qualified as Name -import Unison.Syntax.Parser qualified as Parser -import Unison.Term (Term) -import Unison.Type (Type) -import Unison.Typechecker qualified as Typechecker -import Unison.UnisonFile (UnisonFile) import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UF import Unison.UnisonFile.Type (TypecheckedUnisonFile) import Unison.Util.BiMultimap (BiMultimap) import Unison.Util.BiMultimap qualified as BiMultimap -import Unison.Util.Defns (Defns (..), DefnsF) +import Unison.Util.Defns (Defns (..), DefnsF, defnsAreEmpty) import Unison.Util.Monoid qualified as Monoid -import Unison.Util.Pretty (Pretty) +import Unison.Util.Nametree (flattenNametrees) +import Unison.Util.Pretty (ColorText, Pretty) import Unison.Util.Pretty qualified as Pretty -import Unison.Util.Relation (Relation) import Unison.Util.Relation qualified as Relation -import Unison.Util.Set qualified as Set import Unison.Var (Var) import Unison.WatchKind qualified as WK handleUpdate2 :: Cli () handleUpdate2 = do - Cli.Env {codebase, writeSource} <- ask + env <- ask tuf <- Cli.expectLatestTypecheckedFile let termAndDeclNames = getTermAndDeclNames tuf - currentPath <- Cli.getCurrentPath - currentBranch0 <- Cli.getBranch0At currentPath + pp <- Cli.getCurrentProjectPath + currentBranch0 <- Cli.getCurrentBranch0 + let currentBranch0ExcludingLibdeps = Branch.deleteLibdeps currentBranch0 let namesIncludingLibdeps = Branch.toNames currentBranch0 - let namesExcludingLibdeps = Branch.toNames (currentBranch0 & over Branch.children (Map.delete NameSegment.libSegment)) - let ctorNames = forwardCtorNames namesExcludingLibdeps - Cli.respond Output.UpdateLookingForDependents - (pped, bigUf) <- Cli.runTransactionWithRollback \abort -> do - dependents <- - getNamespaceDependentsOf namesExcludingLibdeps (getExistingReferencesNamed termAndDeclNames namesExcludingLibdeps) - hashLen <- Codebase.hashLength - bigUf <- - addDefinitionsToUnisonFile - abort - codebase - (findCtorNames Output.UOUUpdate namesExcludingLibdeps ctorNames) - dependents - (UF.discardTypes tuf) - pure (makeComplicatedPPE hashLen namesIncludingLibdeps (UF.typecheckedToNames tuf) dependents, bigUf) - - -- If the new-unison-file-to-typecheck is the same as old-unison-file-that-we-already-typechecked, then don't bother - -- typechecking again. - secondTuf <- do - let smallUf = UF.discardTypes tuf - let noChanges = - and - [ Map.size (UF.dataDeclarationsId smallUf) == Map.size (UF.dataDeclarationsId bigUf), - Map.size (UF.effectDeclarationsId smallUf) == Map.size (UF.effectDeclarationsId bigUf), - Map.size (UF.terms smallUf) == Map.size (UF.terms bigUf), - Map.size (UF.watches smallUf) == Map.size (UF.watches bigUf) - ] - if noChanges - then pure tuf - else do - Cli.respond Output.UpdateStartTypechecking - parsingEnv <- makeParsingEnv currentPath namesIncludingLibdeps - secondTuf <- - prettyParseTypecheck bigUf pped parsingEnv & onLeftM \prettyUf -> do - scratchFilePath <- fst <$> Cli.expectLatestFile - liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUf) - Cli.returnEarly Output.UpdateTypecheckingFailure - Cli.respond Output.UpdateTypecheckingSuccess - pure secondTuf - - saveTuf (findCtorNamesMaybe Output.UOUUpdate namesExcludingLibdeps ctorNames Nothing) secondTuf - Cli.respond Output.Success - --- TODO: find a better module for this function, as it's used in a couple places -prettyParseTypecheck :: - UnisonFile Symbol Ann -> - PrettyPrintEnvDecl -> - Parser.ParsingEnv Transaction -> - Cli (Either (Pretty Pretty.ColorText) (TypecheckedUnisonFile Symbol Ann)) -prettyParseTypecheck bigUf pped = - prettyParseTypecheck2 (Pretty.prettyUnisonFile pped bigUf) - --- TODO: find a better module for this function, as it's used in a couple places -prettyParseTypecheck2 :: - Pretty Pretty.ColorText -> - Parser.ParsingEnv Transaction -> - Cli (Either (Pretty Pretty.ColorText) (TypecheckedUnisonFile Symbol Ann)) -prettyParseTypecheck2 prettyUf parsingEnv = do - Cli.Env {codebase} <- ask - let stringUf = Pretty.toPlain 80 prettyUf - Debug.whenDebug Debug.Update do - liftIO do - putStrLn "--- Scratch ---" - putStrLn stringUf - Cli.runTransaction do - Parsers.parseFile "" stringUf parsingEnv >>= \case - Left {} -> pure $ Left prettyUf - Right reparsedUf -> do - typecheckingEnv <- - computeTypecheckingEnvironment (FileParsers.ShouldUseTndr'Yes parsingEnv) codebase [] reparsedUf - pure case FileParsers.synthesizeFile typecheckingEnv reparsedUf of - Result.Result _notes (Just reparsedTuf) -> Right reparsedTuf - Result.Result _notes Nothing -> Left prettyUf - --- @makeParsingEnv path names@ makes a parsing environment with @names@ in scope, which are all relative to @path@. -makeParsingEnv :: Path.Absolute -> Names -> Cli (Parser.ParsingEnv Transaction) -makeParsingEnv path names = do - Cli.Env {generateUniqueName} <- ask - uniqueName <- liftIO generateUniqueName - pure do - Parser.ParsingEnv - { uniqueNames = uniqueName, - uniqueTypeGuid = Cli.loadUniqueTypeGuid path, - names - } - --- save definitions and namespace -saveTuf :: (Name -> Either Output (Maybe [Name])) -> TypecheckedUnisonFile Symbol Ann -> Cli () -saveTuf getConstructors tuf = do - Cli.Env {codebase} <- ask - currentPath <- Cli.getCurrentPath - branchUpdates <- - Cli.runTransactionWithRollback \abort -> do - Codebase.addDefsToCodebase codebase tuf - typecheckedUnisonFileToBranchUpdates abort getConstructors tuf - Cli.stepAt "update" (Path.unabsolute currentPath, Branch.batchUpdates branchUpdates) + -- Assert that the namespace doesn't have any conflicted names + nametree <- + narrowDefns (Branch.deepDefns currentBranch0ExcludingLibdeps) + & onLeft (Cli.returnEarly . Output.ConflictedDefn "update") + + let defns :: Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) + defns = + flattenNametrees nametree + + -- Get the number of constructors for every type declaration + numConstructors <- + Cli.runTransaction do + defns.types + & BiMultimap.dom + & Set.toList + & Foldable.foldlM + ( \acc -> \case + ReferenceBuiltin _ -> pure acc + ReferenceDerived ref -> do + num <- Operations.expectDeclNumConstructors ref + pure $! Map.insert ref num acc + ) + Map.empty + + -- Assert that the namespace doesn't have any incoherent decls + declNameLookup <- + Merge.checkDeclCoherency nametree numConstructors + & onLeft (Cli.returnEarly . Output.IncoherentDeclDuringUpdate) + + finalOutput <- + Cli.label \done -> + Cli.withRespondRegion \respondRegion -> do + respondRegion $ + Output.Literal (Pretty.wrap "Okay, I'm searching the branch for code that needs to be updated...") + + (dependents, hydratedDependents) <- + Cli.runTransaction do + -- Get all dependents of things being updated + dependents0 <- + getNamespaceDependentsOf2 + (flattenNametrees nametree) + (getExistingReferencesNamed termAndDeclNames (Branch.toNames currentBranch0ExcludingLibdeps)) + + -- Throw away the dependents that are shadowed by the file itself + let dependents1 :: DefnsF (Map Name) TermReferenceId TypeReferenceId + dependents1 = + bimap + (`Map.withoutKeys` (Set.map Name.unsafeParseVar (UF.termNamespaceBindings tuf))) + (`Map.withoutKeys` (Set.map Name.unsafeParseVar (UF.typeNamespaceBindings tuf))) + dependents0 + + -- Hydrate the dependents for rendering + hydratedDependents <- + hydrateDefns + (Codebase.unsafeGetTermComponent env.codebase) + Operations.expectDeclComponent + dependents1 + + pure (dependents1, hydratedDependents) + + secondTuf <- do + case defnsAreEmpty dependents of + -- If there are no dependents of the updates, then just use the already-typechecked file. + True -> pure tuf + False -> do + respondRegion (Output.Literal (Pretty.wrap "That's done. Now I'm making sure everything typechecks...")) + + let prettyUnisonFile = + let ppe = makePPE 10 namesIncludingLibdeps (UF.typecheckedToNames tuf) dependents + in makePrettyUnisonFile + (Pretty.prettyUnisonFile ppe (UF.discardTypes tuf)) + (renderDefnsForUnisonFile declNameLookup ppe (over (#terms . mapped) snd hydratedDependents)) + + parsingEnv <- Cli.makeParsingEnv pp namesIncludingLibdeps + + secondTuf <- + parseAndTypecheck prettyUnisonFile parsingEnv & onNothingM do + scratchFilePath <- fst <$> Cli.expectLatestFile + liftIO $ env.writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) True + done Output.UpdateTypecheckingFailure + + respondRegion (Output.Literal (Pretty.wrap "Everything typechecks, so I'm saving the results...")) + + pure secondTuf + + path <- Cli.getCurrentProjectPath + branchUpdates <- + Cli.runTransactionWithRollback \abort -> do + Codebase.addDefsToCodebase env.codebase secondTuf + typecheckedUnisonFileToBranchUpdates + abort + (\typeName -> Right (Map.lookup typeName declNameLookup.declToConstructors)) + secondTuf + Cli.stepAt "update" (path, Branch.batchUpdates branchUpdates) + #latestTypecheckedFile .= Nothing + pure Output.Success + + Cli.respond finalOutput + +makePrettyUnisonFile :: Pretty ColorText -> DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText) -> Pretty ColorText +makePrettyUnisonFile originalFile dependents = + originalFile + <> Pretty.newline + <> Pretty.newline + <> "-- The definitions below no longer typecheck with the changes above." + <> Pretty.newline + <> "-- Please fix the errors and try `update` again." + <> Pretty.newline + <> Pretty.newline + <> ( dependents + & inAlphabeticalOrder + & let f = foldMap (\defn -> defn <> Pretty.newline <> Pretty.newline) in bifoldMap f f + ) + where + inAlphabeticalOrder :: DefnsF (Map Name) a b -> DefnsF [] a b + inAlphabeticalOrder = + bimap f f + where + f = map snd . List.sortOn (Name.toText . fst) . Map.toList -- @typecheckedUnisonFileToBranchUpdates getConstructors file@ returns a list of branch updates (suitable for passing -- along to `batchUpdates` or some "step at" combinator) that corresponds to using all of the contents of @file@. @@ -244,7 +234,10 @@ typecheckedUnisonFileToBranchUpdates abort getConstructors tuf = do -- some decls will be deleted, we want to delete their -- constructors as well deleteConstructorActions <- - (maybe [] (map (BranchUtil.makeAnnihilateTermName . Path.splitFromName)) <$> getConstructors (Name.unsafeParseVar symbol)) & onLeft abort + ( maybe [] (map (BranchUtil.makeAnnihilateTermName . Path.splitFromName)) + <$> getConstructors (Name.unsafeParseVar symbol) + ) + & onLeft abort let deleteTypeAction = BranchUtil.makeAnnihilateTypeName split split = splitVar symbol insertTypeAction = BranchUtil.makeAddTypeName split (Reference.fromId typeRefId) @@ -277,40 +270,6 @@ typecheckedUnisonFileToBranchUpdates abort getConstructors tuf = do splitVar :: Symbol -> Path.Split splitVar = Path.splitFromName . Name.unsafeParseVar -typecheckedUnisonFileToBranchAdds :: TypecheckedUnisonFile Symbol Ann -> [(Path, Branch0 m -> Branch0 m)] -typecheckedUnisonFileToBranchAdds tuf = do - declAdds ++ termAdds - where - declAdds :: [(Path, Branch0 m -> Branch0 m)] - declAdds = do - foldMap makeDataDeclAdds (Map.toList $ UF.dataDeclarationsId' tuf) - ++ foldMap makeEffectDeclUpdates (Map.toList $ UF.effectDeclarationsId' tuf) - where - makeDataDeclAdds (symbol, (typeRefId, dataDecl)) = makeDeclAdds (symbol, (typeRefId, Right dataDecl)) - makeEffectDeclUpdates (symbol, (typeRefId, effectDecl)) = makeDeclAdds (symbol, (typeRefId, Left effectDecl)) - - makeDeclAdds :: (Symbol, (TypeReferenceId, Decl Symbol Ann)) -> [(Path, Branch0 m -> Branch0 m)] - makeDeclAdds (symbol, (typeRefId, decl)) = - let insertTypeAction = BranchUtil.makeAddTypeName (splitVar symbol) (Reference.fromId typeRefId) - insertTypeConstructorActions = - zipWith - (\sym rid -> BranchUtil.makeAddTermName (splitVar sym) (Reference.fromId <$> rid)) - (Decl.constructorVars (Decl.asDataDecl decl)) - (Decl.declConstructorReferents typeRefId decl) - in insertTypeAction : insertTypeConstructorActions - - termAdds :: [(Path, Branch0 m -> Branch0 m)] - termAdds = - tuf - & UF.hashTermsId - & Map.toList - & mapMaybe \(var, (_, ref, wk, _, _)) -> do - guard (WK.watchKindShouldBeStoredInDatabase wk) - Just (BranchUtil.makeAddTermName (splitVar var) (Referent.fromTermReferenceId ref)) - - splitVar :: Symbol -> Path.Split - splitVar = Path.splitFromName . Name.unsafeParseVar - -- | get references from `names` that have the same names as in `defns` -- For constructors, we get the type reference. getExistingReferencesNamed :: DefnsF Set Name Name -> Names -> Set Reference @@ -327,165 +286,6 @@ getExistingReferencesNamed defns names = foldMap \name -> Relation.lookupDom name (Names.types names) -makeUnisonFile :: - (forall void. Output -> Transaction void) -> - Codebase IO Symbol Ann -> - (Maybe Int -> Name -> Either Output.Output [Name]) -> - DefnsF (Relation Name) TermReferenceId TypeReferenceId -> - Transaction (UnisonFile Symbol Ann) -makeUnisonFile abort codebase doFindCtorNames defns = do - file <- foldM addTermComponent UF.emptyUnisonFile (Set.map Reference.idToHash (Relation.ran defns.terms)) - foldM addDeclComponent file (Set.map Reference.idToHash (Relation.ran defns.types)) - where - addTermComponent :: UnisonFile Symbol Ann -> Hash -> Transaction (UnisonFile Symbol Ann) - addTermComponent uf h = do - termComponent <- Codebase.unsafeGetTermComponent codebase h - pure $ foldl' addTermElement uf (zip termComponent [0 ..]) - where - addTermElement :: UnisonFile Symbol Ann -> ((Term Symbol Ann, Type Symbol Ann), Reference.Pos) -> UnisonFile Symbol Ann - addTermElement uf ((tm, tp), i) = do - let termNames = Relation.lookupRan (Reference.Id h i) defns.terms - foldl' (addDefinition tm tp) uf termNames - addDefinition :: Term Symbol Ann -> Type Symbol Ann -> UnisonFile Symbol Ann -> Name -> UnisonFile Symbol Ann - addDefinition tm tp uf (Name.toVar -> v) = - let prependTerm to = (v, Ann.External, tm) : to - in if isTest tp - then uf & #watches . Lens.at WK.TestWatch . Lens.non [] Lens.%~ prependTerm - else uf & #terms Lens.%~ Map.insert v (Ann.External, tm) - - isTest = Typechecker.isEqual (Decls.testResultListType mempty) - - -- given a dependent hash, include that component in the scratch file - -- todo: wundefined: cut off constructor name prefixes - addDeclComponent :: UnisonFile Symbol Ann -> Hash -> Transaction (UnisonFile Symbol Ann) - addDeclComponent uf h = do - declComponent <- fromJust <$> Codebase.getDeclComponent h - foldM addDeclElement uf (zip declComponent [0 ..]) - where - -- for each name a decl has, update its constructor names according to what exists in the namespace - addDeclElement :: UnisonFile Symbol Ann -> (Decl Symbol Ann, Reference.Pos) -> Transaction (UnisonFile Symbol Ann) - addDeclElement uf (decl, i) = do - let declNames = Relation.lookupRan (Reference.Id h i) defns.types - -- look up names for this decl's constructor based on the decl's name, and embed them in the decl definition. - foldM (addRebuiltDefinition decl) uf declNames - where - -- skip any definitions that already have names, we don't want to overwrite what the user has supplied - addRebuiltDefinition :: Decl Symbol Ann -> UnisonFile Symbol Ann -> Name -> Transaction (UnisonFile Symbol Ann) - addRebuiltDefinition decl uf name = case decl of - Left ed -> - overwriteConstructorNames name ed.toDataDecl <&> \ed' -> - uf - & #effectDeclarationsId - %~ Map.insertWith (\_new old -> old) (Name.toVar name) (Reference.Id h i, Decl.EffectDeclaration ed') - Right dd -> - overwriteConstructorNames name dd <&> \dd' -> - uf - & #dataDeclarationsId - %~ Map.insertWith (\_new old -> old) (Name.toVar name) (Reference.Id h i, dd') - - -- Constructor names are bogus when pulled from the database, so we set them to what they should be here - overwriteConstructorNames :: Name -> DataDeclaration Symbol Ann -> Transaction (DataDeclaration Symbol Ann) - overwriteConstructorNames name dd = - let constructorNames :: Transaction [Symbol] - constructorNames = - case doFindCtorNames (Just $ Decl.constructorCount dd) name of - Left err -> abort err - Right array | all (isJust . Name.stripNamePrefix name) array -> pure (map Name.toVar array) - Right array -> do - traceM "I ran into a situation where a type's constructors didn't match its name," - traceM "in a spot where I didn't expect to be discovering that.\n\n" - traceM "Type Name:" - traceM . Lazy.Text.unpack $ pShow name - traceM "Constructor Names:" - traceM . Lazy.Text.unpack $ pShow array - error "Sorry for crashing." - - swapConstructorNames oldCtors = - let (annotations, _vars, types) = unzip3 oldCtors - in zip3 annotations <$> constructorNames <*> pure types - in Lens.traverseOf Decl.constructors_ swapConstructorNames dd - --- | @addDefinitionsToUnisonFile abort codebase doFindCtorNames definitions file@ adds all @definitions@ to @file@, --- avoiding overwriting anything already in @file@. Every definition is put into the file with every naming it has in --- @names@ "on the left-hand-side of the equals" (but yes type decls don't really have a LHS). --- --- TODO: find a better module for this function, as it's used in a couple places -addDefinitionsToUnisonFile :: - (forall void. Output -> Transaction void) -> - Codebase IO Symbol Ann -> - (Maybe Int -> Name -> Either Output.Output [Name]) -> - DefnsF (Relation Name) TermReferenceId TypeReferenceId -> - UnisonFile Symbol Ann -> - Transaction (UnisonFile Symbol Ann) -addDefinitionsToUnisonFile abort codebase doFindCtorNames newDefns oldUF = do - newUF <- makeUnisonFile abort codebase doFindCtorNames newDefns - pure (oldUF `UF.leftBiasedMerge` newUF) - --- | O(r + c * d) touches all the referents (r), and all the NameSegments (d) of all of the Con referents (c) -forwardCtorNames :: Names -> Map ForwardName (Referent, Name) -forwardCtorNames names = - Map.fromList $ - [ (ForwardName.fromName name, (r, name)) - | (r@Referent.Con {}, rNames) <- Map.toList $ Relation.range names.terms, - name <- Foldable.toList rNames - ] - --- | given a decl name, find names for all of its constructors, in order. --- --- Precondition: 'n' is an element of 'names' -findCtorNames :: Output.UpdateOrUpgrade -> Names -> Map ForwardName (Referent, Name) -> Maybe Int -> Name -> Either Output.Output [Name] -findCtorNames operation names forwardCtorNames ctorCount n = - let declRef = case Set.lookupMin (Relation.lookupDom n names.types) of - Nothing -> error "[findCtorNames] precondition violation: n is not an element of names" - Just x -> x - f = ForwardName.fromName n - (_, centerRight) = Map.split f forwardCtorNames - (center, _) = Map.split (incrementLastSegmentChar f) centerRight - - insertShortest :: Map ConstructorId Name -> (Referent, Name) -> Map ConstructorId Name - insertShortest m (Referent.Con (ConstructorReference r cid) _ct, newName) | r == declRef = - case Map.lookup cid m of - Just existingName - | length (Name.segments existingName) > length (Name.segments newName) -> - Map.insert cid newName m - Just {} -> m - Nothing -> Map.insert cid newName m - insertShortest m _ = m - m = foldl' insertShortest mempty (Foldable.toList center) - ctorCountGuess = fromMaybe (Map.size m) ctorCount - in if Map.size m == ctorCountGuess && all (isJust . flip Map.lookup m . fromIntegral) [0 .. ctorCountGuess - 1] - then Right $ Map.elems m - else Left $ Output.UpdateIncompleteConstructorSet operation n m ctorCount - -findCtorNamesMaybe :: - Output.UpdateOrUpgrade -> - Names -> - Map ForwardName (Referent, Name) -> - Maybe Int -> - Name -> - Either Output.Output (Maybe [Name]) -findCtorNamesMaybe operation names forwardCtorNames ctorCount name = - case Relation.memberDom name (Names.types names) of - True -> Just <$> findCtorNames operation names forwardCtorNames ctorCount name - False -> Right Nothing - --- Used by `findCtorNames` to filter `forwardCtorNames` to a narrow range which will be searched linearly. --- >>> incrementLastSegmentChar $ ForwardName.fromName $ Name.unsafeFromText "foo.bar.quux" --- ForwardName {toList = "foo" :| ["bar","quuy"]} -incrementLastSegmentChar :: ForwardName -> ForwardName -incrementLastSegmentChar (ForwardName segments) = - let (initSegments, lastSegment) = (NonEmpty.init segments, NonEmpty.last segments) - incrementedLastSegment = incrementLastCharInSegment lastSegment - in ForwardName $ maybe (NonEmpty.singleton incrementedLastSegment) (|> incrementedLastSegment) (NonEmpty.nonEmpty initSegments) - where - incrementLastCharInSegment :: NameSegment -> NameSegment - incrementLastCharInSegment (NameSegment text) = - let incrementedText = - if Text.null text - then text - else Text.init text `Text.append` Text.singleton (succ $ Text.last text) - in NameSegment incrementedText - -- @getTermAndDeclNames file@ returns the names of the terms and decls defined in a typechecked Unison file. getTermAndDeclNames :: (Var v) => TypecheckedUnisonFile v a -> DefnsF Set Name Name getTermAndDeclNames tuf = @@ -504,67 +304,6 @@ getTermAndDeclNames tuf = keysToNames = Set.map Name.unsafeParseVar . Map.keysSet ctorsToNames = Set.fromList . map Name.unsafeParseVar . Decl.constructorVars --- | Given a namespace and a set of dependencies, return the subset of the namespace that consists of only the --- (transitive) dependents of the dependencies. -getNamespaceDependentsOf :: - Names -> - Set Reference -> - Transaction (DefnsF (Relation Name) TermReferenceId TypeReferenceId) -getNamespaceDependentsOf names dependencies = do - dependents <- Ops.dependentsWithinScope (Names.referenceIds names) dependencies - let dependents1 :: DefnsF Set TermReferenceId TypeReferenceId - dependents1 = - Map.foldlWithKey' - ( \defns refId -> \case - Reference.RtTerm -> let !terms1 = Set.insert refId defns.terms in defns & #terms .~ terms1 - Reference.RtType -> let !types1 = Set.insert refId defns.types in defns & #types .~ types1 - ) - (Defns Set.empty Set.empty) - dependents - pure (bimap (foldMap nameTerm) (foldMap nameType) dependents1) - where - nameTerm :: TermReferenceId -> Relation Name TermReferenceId - nameTerm ref = - Relation.fromManyDom (Relation.lookupRan (Referent.fromTermReferenceId ref) (Names.terms names)) ref - - nameType :: TypeReferenceId -> Relation Name TypeReferenceId - nameType ref = - Relation.fromManyDom (Relation.lookupRan (Reference.fromId ref) (Names.types names)) ref - --- | A better version of the above that operates on BiMultimaps rather than Relations. -getNamespaceDependentsOf2 :: - Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> - Set Reference -> - Transaction (DefnsF (Map Name) TermReferenceId TypeReferenceId) -getNamespaceDependentsOf2 defns dependencies = do - let toTermScope = Set.mapMaybe Referent.toReferenceId . BiMultimap.dom - let toTypeScope = Set.mapMaybe Reference.toId . BiMultimap.dom - let scope = bifoldMap toTermScope toTypeScope defns - - dependents <- - Ops.dependentsWithinScope scope dependencies - - let (termDependentRefs, typeDependentRefs) = - dependents & Map.partition \case - Reference.RtTerm -> True - Reference.RtType -> False - - pure - Defns - { terms = Map.foldlWithKey' addTerms Map.empty termDependentRefs, - types = Map.foldlWithKey' addTypes Map.empty typeDependentRefs - } - where - addTerms :: Map Name TermReferenceId -> TermReferenceId -> ignored -> Map Name TermReferenceId - addTerms acc0 ref _ = - let names = BiMultimap.lookupDom (Referent.fromTermReferenceId ref) defns.terms - in Set.foldl' (\acc name -> Map.insert name ref acc) acc0 names - - addTypes :: Map Name TypeReferenceId -> TypeReferenceId -> ignored -> Map Name TypeReferenceId - addTypes acc0 ref _ = - let names = BiMultimap.lookupDom (Reference.fromId ref) defns.types - in Set.foldl' (\acc name -> Map.insert name ref acc) acc0 names - -- The big picture behind PPE building, though there are many details: -- -- * We are updating old references to new references by rendering old references as names that are then parsed @@ -585,19 +324,24 @@ getNamespaceDependentsOf2 defns dependencies = do -- However, the following file will not fail to parse, if `one.foo` and `two.foo` are aliases in the codebase: -- -- hey = foo + foo -makeComplicatedPPE :: +makePPE :: Int -> Names -> Names -> - DefnsF (Relation Name) TermReferenceId TypeReferenceId -> + DefnsF (Map Name) TermReferenceId TypeReferenceId -> PrettyPrintEnvDecl -makeComplicatedPPE hashLen names initialFileNames dependents = - PPED.makePPED (PPE.namer namesInTheFile) (PPE.suffixifyByName namesInTheFile) - `PPED.addFallback` PPED.makePPED (PPE.hqNamer hashLen namesInTheNamespace) (PPE.suffixifyByHash namesInTheNamespace) - where - namesInTheFile = - initialFileNames - <> Names - (Relation.mapRan Referent.fromTermReferenceId dependents.terms) - (Relation.mapRan Reference.fromId dependents.types) - namesInTheNamespace = Names.unionLeftName names initialFileNames +makePPE hashLen namespaceNames initialFileNames dependents = + PPED.addFallback + ( let names = initialFileNames <> Names.fromUnconflictedReferenceIds dependents + in PPED.makePPED (PPE.namer names) (PPE.suffixifyByName (Names.shadowing names namespaceNames)) + ) + ( PPED.makePPED + (PPE.hqNamer hashLen namespaceNames) + -- We don't want to over-suffixify for a reference in the namespace. For example, say we have "foo.bar" in the + -- namespace and "oink.bar" in the file. "bar" may be a unique suffix among the namespace names, but would be + -- ambiguous in the context of namespace + file names. + -- + -- So, we use `shadowing`, which starts with the LHS names (the namespace), and adds to it names from the + -- RHS (the initial file names, i.e. what was originally saved) that don't already exist in the LHS. + (PPE.suffixifyByHash (Names.shadowing namespaceNames initialFileNames)) + ) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs index 7785e386d4..c4331b99f6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs @@ -1,62 +1,85 @@ +-- | @upgrade@ input handler. module Unison.Codebase.Editor.HandleInput.Upgrade ( handleUpgrade, ) where +import Control.Lens qualified as Lens import Control.Monad.Reader (ask) import Data.Char qualified as Char +import Data.Foldable qualified as Foldable import Data.List.NonEmpty (pattern (:|)) +import Data.List.NonEmpty qualified as List.NonEmpty +import Data.List.NonEmpty.Extra ((|>)) import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust) import Data.Set qualified as Set import Data.Text qualified as Text +import Data.Text.Lazy qualified as Text.Lazy import Text.Builder qualified +import Text.Pretty.Simple (pShow) import U.Codebase.Sqlite.DbId (ProjectId) -import U.Codebase.Sqlite.Project qualified -import U.Codebase.Sqlite.ProjectBranch qualified +import Unison.Builtin.Decls qualified as Decls import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli +import Unison.Cli.Pretty qualified as Pretty import Unison.Cli.ProjectUtils qualified as Cli +import Unison.Cli.UpdateUtils (getNamespaceDependentsOf, parseAndTypecheck) +import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Names qualified as Branch +import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..)) import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch -import Unison.Codebase.Editor.HandleInput.Update2 - ( addDefinitionsToUnisonFile, - findCtorNames, - findCtorNamesMaybe, - forwardCtorNames, - getNamespaceDependentsOf, - makeComplicatedPPE, - makeParsingEnv, - prettyParseTypecheck, - typecheckedUnisonFileToBranchUpdates, - ) +import Unison.Codebase.Editor.HandleInput.Update2 (typecheckedUnisonFileToBranchUpdates) +import Unison.Codebase.Editor.Output (Output) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path -import Unison.HashQualified' qualified as HQ' +import Unison.Codebase.ProjectPath qualified as PP +import Unison.ConstructorReference (GConstructorReference (..)) +import Unison.DataDeclaration (DataDeclaration, Decl) +import Unison.DataDeclaration qualified as Decl +import Unison.DataDeclaration.ConstructorId (ConstructorId) +import Unison.Hash (Hash) +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name +import Unison.Name.Forward (ForwardName (..)) +import Unison.Name.Forward qualified as ForwardName import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment +import Unison.NameSegment.Internal (NameSegment (NameSegment)) import Unison.Names (Names (..)) import Unison.Names qualified as Names +import Unison.Parser.Ann (Ann) +import Unison.Parser.Ann qualified as Ann import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..)) import Unison.PrettyPrintEnvDecl qualified as PPED (addFallback) -import Unison.Project (ProjectAndBranch (..), ProjectBranchName) -import Unison.Reference (TermReference, TypeReference) +import Unison.PrettyPrintEnvDecl.Names qualified as PPED (makePPED) +import Unison.Project (ProjectBranchName) +import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId) +import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Sqlite (Transaction) +import Unison.Symbol (Symbol) +import Unison.Syntax.Name qualified as Name import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) +import Unison.Term (Term) +import Unison.Type (Type) +import Unison.Typechecker qualified as Typechecker +import Unison.UnisonFile (UnisonFile) import Unison.UnisonFile qualified as UnisonFile +import Unison.Util.Defns (Defns (..), DefnsF) import Unison.Util.Pretty qualified as Pretty import Unison.Util.Relation (Relation) import Unison.Util.Relation qualified as Relation import Unison.Util.Set qualified as Set +import Unison.WatchKind qualified as WK import Witch (unsafeFrom) handleUpgrade :: NameSegment -> NameSegment -> Cli () @@ -64,23 +87,21 @@ handleUpgrade oldName newName = do when (oldName == newName) do Cli.returnEarlyWithoutOutput - Cli.Env {codebase, writeSource} <- ask + env <- ask - (projectAndBranch, _path) <- Cli.expectCurrentProjectBranch - let projectId = projectAndBranch.project.projectId - let projectPath = Cli.projectBranchPath (ProjectAndBranch projectId projectAndBranch.branch.branchId) - let oldPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, oldName])) - let newPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, newName])) + let oldPath = Path.Absolute (Path.fromList [NameSegment.libSegment, oldName]) + let newPath = Path.Absolute (Path.fromList [NameSegment.libSegment, newName]) - currentNamespace <- Cli.getBranch0At projectPath - let currentNamespaceSansOld = Branch.deleteLibdep oldName currentNamespace - let currentDeepTermsSansOld = Branch.deepTerms currentNamespaceSansOld - let currentDeepTypesSansOld = Branch.deepTypes currentNamespaceSansOld - let currentLocalNames = Branch.toNames (Branch.deleteLibdeps currentNamespace) + currentNamespace <- Cli.getCurrentProjectRoot + let currentNamespaceSansOld = currentNamespace & Branch.step (Branch.deleteLibdep oldName) + let currentNamespaceSansOld0 = Branch.head currentNamespaceSansOld + let currentDeepTermsSansOld = Branch.deepTerms currentNamespaceSansOld0 + let currentDeepTypesSansOld = Branch.deepTypes currentNamespaceSansOld0 + let currentLocalNames = Branch.toNames (Branch.deleteLibdeps $ Branch.head currentNamespace) let currentLocalConstructorNames = forwardCtorNames currentLocalNames - let currentDeepNamesSansOld = Branch.toNames currentNamespaceSansOld + let currentDeepNamesSansOld = Branch.toNames currentNamespaceSansOld0 - oldNamespace <- Cli.expectBranch0AtPath' oldPath + oldNamespace <- Cli.expectBranch0AtPath' (Path.AbsolutePath' oldPath) let oldLocalNamespace = Branch.deleteLibdeps oldNamespace let oldLocalTerms = Branch.deepTerms oldLocalNamespace let oldLocalTypes = Branch.deepTypes oldLocalNamespace @@ -88,7 +109,7 @@ handleUpgrade oldName newName = do let oldDeepMinusLocalTerms = Branch.deepTerms oldNamespaceMinusLocal let oldDeepMinusLocalTypes = Branch.deepTypes oldNamespaceMinusLocal - newNamespace <- Cli.expectBranch0AtPath' newPath + newNamespace <- Cli.expectBranch0AtPath' (Path.AbsolutePath' newPath) let newLocalNamespace = Branch.deleteLibdeps newNamespace let newLocalTerms = Branch.deepTerms newLocalNamespace let newLocalTypes = Branch.deepTypes newLocalNamespace @@ -135,55 +156,61 @@ handleUpgrade oldName newName = do unisonFile <- do addDefinitionsToUnisonFile abort - codebase + env.codebase (findCtorNames Output.UOUUpgrade currentLocalNames currentLocalConstructorNames) dependents UnisonFile.emptyUnisonFile - hashLength <- Codebase.hashLength pure ( unisonFile, - makeOldDepPPE - oldName - newName - currentDeepNamesSansOld - (Branch.toNames oldNamespace) - (Branch.toNames oldLocalNamespace) - (Branch.toNames newLocalNamespace) - `PPED.addFallback` makeComplicatedPPE hashLength currentDeepNamesSansOld mempty dependents + let ppe1 = + makeOldDepPPE + oldName + newName + currentDeepNamesSansOld + (Branch.toNames oldNamespace) + (Branch.toNames oldLocalNamespace) + (Branch.toNames newLocalNamespace) + ppe2 = + PPED.makePPED + (PPE.namer (Names.fromReferenceIds dependents)) + (PPE.suffixifyByName currentDeepNamesSansOld) + ppe3 = + PPED.makePPED + (PPE.hqNamer 10 currentDeepNamesSansOld) + (PPE.suffixifyByHash currentDeepNamesSansOld) + in ppe1 `PPED.addFallback` ppe2 `PPED.addFallback` ppe3 ) - parsingEnv <- makeParsingEnv projectPath currentDeepNamesSansOld - typecheckedUnisonFile <- - prettyParseTypecheck unisonFile printPPE parsingEnv & onLeftM \prettyUnisonFile -> do - -- Small race condition: since picking a branch name and creating the branch happen in different - -- transactions, creating could fail. - temporaryBranchName <- Cli.runTransaction (findTemporaryBranchName projectId oldName newName) - temporaryBranchId <- - HandleInput.Branch.doCreateBranch - (HandleInput.Branch.CreateFrom'Branch projectAndBranch) - projectAndBranch.project - temporaryBranchName + pp@(PP.ProjectPath project projectBranch _path) <- Cli.getCurrentProjectPath + parsingEnv <- Cli.makeParsingEnv pp currentDeepNamesSansOld + typecheckedUnisonFile <- do + let prettyUnisonFile = Pretty.prettyUnisonFile printPPE unisonFile + parseAndTypecheck prettyUnisonFile parsingEnv & onNothingM do + let getTemporaryBranchName = findTemporaryBranchName (project ^. #projectId) oldName newName + (_temporaryBranchId, temporaryBranchName) <- + HandleInput.Branch.createBranch textualDescriptionOfUpgrade - let temporaryBranchPath = Path.unabsolute (Cli.projectBranchPath (ProjectAndBranch projectId temporaryBranchId)) - Cli.stepAt textualDescriptionOfUpgrade (temporaryBranchPath, \_ -> currentNamespaceSansOld) + (CreateFrom'NamespaceWithParent projectBranch currentNamespaceSansOld) + project + getTemporaryBranchName scratchFilePath <- Cli.getLatestFile <&> \case Nothing -> "scratch.u" Just (file, _) -> file - liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) + liftIO $ env.writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) True Cli.returnEarly $ - Output.UpgradeFailure projectAndBranch.branch.name temporaryBranchName scratchFilePath oldName newName + Output.UpgradeFailure (projectBranch ^. #name) temporaryBranchName scratchFilePath oldName newName branchUpdates <- Cli.runTransactionWithRollback \abort -> do - Codebase.addDefsToCodebase codebase typecheckedUnisonFile + Codebase.addDefsToCodebase env.codebase typecheckedUnisonFile typecheckedUnisonFileToBranchUpdates abort (findCtorNamesMaybe Output.UOUUpgrade currentLocalNames currentLocalConstructorNames Nothing) typecheckedUnisonFile Cli.stepAt textualDescriptionOfUpgrade - ( Path.unabsolute projectPath, + ( PP.toRoot pp, Branch.deleteLibdep oldName . Branch.batchUpdates branchUpdates ) Cli.respond (Output.UpgradeSuccess oldName newName) @@ -216,6 +243,100 @@ keepOldDeepTypesStillInUse oldDeepMinusLocalTypes currentDeepTypesSansOld = Relation.dom oldDeepMinusLocalTypes & Set.filter \typ -> not (Relation.memberDom typ currentDeepTypesSansOld) +-- | @addDefinitionsToUnisonFile abort codebase doFindCtorNames definitions file@ adds all @definitions@ to @file@, +-- avoiding overwriting anything already in @file@. Every definition is put into the file with every naming it has in +-- @names@ "on the left-hand-side of the equals" (but yes type decls don't really have a LHS). +-- +-- TODO: find a better module for this function, as it's used in a couple places +addDefinitionsToUnisonFile :: + (forall void. Output -> Transaction void) -> + Codebase IO Symbol Ann -> + (Maybe Int -> Name -> Either Output.Output [Name]) -> + DefnsF (Relation Name) TermReferenceId TypeReferenceId -> + UnisonFile Symbol Ann -> + Transaction (UnisonFile Symbol Ann) +addDefinitionsToUnisonFile abort codebase doFindCtorNames newDefns oldUF = do + newUF <- makeUnisonFile abort codebase doFindCtorNames newDefns + pure (oldUF `UnisonFile.leftBiasedMerge` newUF) + +makeUnisonFile :: + (forall void. Output -> Transaction void) -> + Codebase IO Symbol Ann -> + (Maybe Int -> Name -> Either Output.Output [Name]) -> + DefnsF (Relation Name) TermReferenceId TypeReferenceId -> + Transaction (UnisonFile Symbol Ann) +makeUnisonFile abort codebase doFindCtorNames defns = do + file <- foldM addTermComponent UnisonFile.emptyUnisonFile (Set.map Reference.idToHash (Relation.ran defns.terms)) + foldM addDeclComponent file (Set.map Reference.idToHash (Relation.ran defns.types)) + where + addTermComponent :: UnisonFile Symbol Ann -> Hash -> Transaction (UnisonFile Symbol Ann) + addTermComponent uf h = do + termComponent <- Codebase.unsafeGetTermComponent codebase h + pure $ foldl' addTermElement uf (zip termComponent [0 ..]) + where + addTermElement :: UnisonFile Symbol Ann -> ((Term Symbol Ann, Type Symbol Ann), Reference.Pos) -> UnisonFile Symbol Ann + addTermElement uf ((tm, tp), i) = do + let termNames = Relation.lookupRan (Reference.Id h i) defns.terms + foldl' (addDefinition tm tp) uf termNames + addDefinition :: Term Symbol Ann -> Type Symbol Ann -> UnisonFile Symbol Ann -> Name -> UnisonFile Symbol Ann + addDefinition tm tp uf (Name.toVar -> v) = + let prependTerm to = (v, Ann.External, tm) : to + in if isTest tp + then uf & #watches . Lens.at WK.TestWatch . Lens.non [] Lens.%~ prependTerm + else uf & #terms Lens.%~ Map.insert v (Ann.External, tm) + + isTest = Typechecker.isEqual (Decls.testResultListType mempty) + + -- given a dependent hash, include that component in the scratch file + -- todo: wundefined: cut off constructor name prefixes + addDeclComponent :: UnisonFile Symbol Ann -> Hash -> Transaction (UnisonFile Symbol Ann) + addDeclComponent uf h = do + declComponent <- fromJust <$> Codebase.getDeclComponent h + foldM addDeclElement uf (zip declComponent [0 ..]) + where + -- for each name a decl has, update its constructor names according to what exists in the namespace + addDeclElement :: UnisonFile Symbol Ann -> (Decl Symbol Ann, Reference.Pos) -> Transaction (UnisonFile Symbol Ann) + addDeclElement uf (decl, i) = do + let declNames = Relation.lookupRan (Reference.Id h i) defns.types + -- look up names for this decl's constructor based on the decl's name, and embed them in the decl definition. + foldM (addRebuiltDefinition decl) uf declNames + where + -- skip any definitions that already have names, we don't want to overwrite what the user has supplied + addRebuiltDefinition :: Decl Symbol Ann -> UnisonFile Symbol Ann -> Name -> Transaction (UnisonFile Symbol Ann) + addRebuiltDefinition decl uf name = case decl of + Left ed -> + overwriteConstructorNames name ed.toDataDecl <&> \ed' -> + uf + & #effectDeclarationsId + %~ Map.insertWith (\_new old -> old) (Name.toVar name) (Reference.Id h i, Decl.EffectDeclaration ed') + Right dd -> + overwriteConstructorNames name dd <&> \dd' -> + uf + & #dataDeclarationsId + %~ Map.insertWith (\_new old -> old) (Name.toVar name) (Reference.Id h i, dd') + + -- Constructor names are bogus when pulled from the database, so we set them to what they should be here + overwriteConstructorNames :: Name -> DataDeclaration Symbol Ann -> Transaction (DataDeclaration Symbol Ann) + overwriteConstructorNames name dd = + let constructorNames :: Transaction [Symbol] + constructorNames = + case doFindCtorNames (Just $ Decl.constructorCount dd) name of + Left err -> abort err + Right array | all (isJust . Name.stripNamePrefix name) array -> pure (map Name.toVar array) + Right array -> do + traceM "I ran into a situation where a type's constructors didn't match its name," + traceM "in a spot where I didn't expect to be discovering that.\n\n" + traceM "Type Name:" + traceM . Text.Lazy.unpack $ pShow name + traceM "Constructor Names:" + traceM . Text.Lazy.unpack $ pShow array + error "Sorry for crashing." + + swapConstructorNames oldCtors = + let (annotations, _vars, types) = unzip3 oldCtors + in zip3 annotations <$> constructorNames <*> pure types + in Lens.traverseOf Decl.constructors_ swapConstructorNames dd + makeOldDepPPE :: NameSegment -> NameSegment -> @@ -291,3 +412,72 @@ findTemporaryBranchName projectId oldDepName newDepName = do oldDepText = NameSegment.toEscapedText oldDepName newDepText = NameSegment.toEscapedText newDepName + +-- | O(r + c * d) touches all the referents (r), and all the NameSegments (d) of all of the Con referents (c) +forwardCtorNames :: Names -> Map ForwardName (Referent, Name) +forwardCtorNames names = + Map.fromList $ + [ (ForwardName.fromName name, (r, name)) + | (r@Referent.Con {}, rNames) <- Map.toList $ Relation.range names.terms, + name <- Foldable.toList rNames + ] + +-- | given a decl name, find names for all of its constructors, in order. +-- +-- Precondition: 'n' is an element of 'names' +findCtorNames :: Output.UpdateOrUpgrade -> Names -> Map ForwardName (Referent, Name) -> Maybe Int -> Name -> Either Output.Output [Name] +findCtorNames operation names forwardCtorNames ctorCount n = + let declRef = case Set.lookupMin (Relation.lookupDom n names.types) of + Nothing -> error "[findCtorNames] precondition violation: n is not an element of names" + Just x -> x + f = ForwardName.fromName n + (_, centerRight) = Map.split f forwardCtorNames + (center, _) = Map.split (incrementLastSegmentChar f) centerRight + + insertShortest :: Map ConstructorId Name -> (Referent, Name) -> Map ConstructorId Name + insertShortest m (Referent.Con (ConstructorReference r cid) _ct, newName) | r == declRef = + case Map.lookup cid m of + Just existingName + | length (Name.segments existingName) > length (Name.segments newName) -> + Map.insert cid newName m + Just {} -> m + Nothing -> Map.insert cid newName m + insertShortest m _ = m + m = foldl' insertShortest mempty (Foldable.toList center) + ctorCountGuess = fromMaybe (Map.size m) ctorCount + in if Map.size m == ctorCountGuess && all (isJust . flip Map.lookup m . fromIntegral) [0 .. ctorCountGuess - 1] + then Right $ Map.elems m + else Left $ Output.UpdateIncompleteConstructorSet operation n m ctorCount + +findCtorNamesMaybe :: + Output.UpdateOrUpgrade -> + Names -> + Map ForwardName (Referent, Name) -> + Maybe Int -> + Name -> + Either Output.Output (Maybe [Name]) +findCtorNamesMaybe operation names forwardCtorNames ctorCount name = + case Relation.memberDom name (Names.types names) of + True -> Just <$> findCtorNames operation names forwardCtorNames ctorCount name + False -> Right Nothing + +-- Used by `findCtorNames` to filter `forwardCtorNames` to a narrow range which will be searched linearly. +-- >>> incrementLastSegmentChar $ ForwardName.fromName $ Name.unsafeFromText "foo.bar.quux" +-- ForwardName {toList = "foo" :| ["bar","quuy"]} +incrementLastSegmentChar :: ForwardName -> ForwardName +incrementLastSegmentChar (ForwardName segments) = + let (initSegments, lastSegment) = (List.NonEmpty.init segments, List.NonEmpty.last segments) + incrementedLastSegment = incrementLastCharInSegment lastSegment + in ForwardName $ + maybe + (List.NonEmpty.singleton incrementedLastSegment) + (|> incrementedLastSegment) + (List.NonEmpty.nonEmpty initSegments) + where + incrementLastCharInSegment :: NameSegment -> NameSegment + incrementLastCharInSegment (NameSegment text) = + let incrementedText = + if Text.null text + then text + else Text.init text `Text.append` Text.singleton (succ $ Text.last text) + in NameSegment incrementedText diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index efcc2be7e6..da06a5fb8e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -8,10 +8,13 @@ module Unison.Codebase.Editor.Input TestInput (..), Event (..), OutputLocation (..), + RelativeToFold (..), PatchPath, + BranchIdG (..), BranchId, + BranchId2, AbsBranchId, - LooseCodeOrProject, + UnresolvedProjectBranch, parseBranchId, parseBranchId2, parseShortCausalHash, @@ -31,10 +34,11 @@ import Data.List.NonEmpty (NonEmpty) import Data.Text qualified as Text import Data.These (These) import Unison.Codebase.Branch.Merge qualified as Branch -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import Unison.Codebase.Path (Path, Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath) import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH @@ -60,15 +64,26 @@ type PatchPath = Path.Split' data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath deriving (Eq, Ord, Show) -type BranchId = Either ShortCausalHash Path' +data BranchIdG p + = BranchAtSCH ShortCausalHash + | BranchAtPath p + | BranchAtProjectPath ProjectPath + deriving stock (Eq, Show, Functor, Foldable, Traversable) --- | A lot of commands can take either a loose code path or a project branch in the same argument slot. Usually, those --- have distinct syntaxes, but sometimes it's ambiguous, in which case we'd parse a `These`. The command itself can --- decide what to do with the ambiguity. -type LooseCodeOrProject = - These Path' (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) +instance (From p Text) => From (BranchIdG p) Text where + from = \case + BranchAtSCH h -> "#" <> SCH.toText h + BranchAtPath p -> from p + BranchAtProjectPath pp -> from pp -type AbsBranchId = Either ShortCausalHash Path.Absolute +type BranchId = BranchIdG Path' + +type BranchId2 = Either ShortCausalHash BranchRelativePath + +type AbsBranchId = BranchIdG Path.Absolute + +-- | An unambiguous project branch name, use the current project name if not provided. +type UnresolvedProjectBranch = ProjectAndBranch (Maybe ProjectName) ProjectBranchName type HashOrHQSplit' = Either ShortHash Path.HQSplit' @@ -79,8 +94,8 @@ data Insistence = Force | Try parseBranchId :: String -> Either Text BranchId parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of Nothing -> Left "Invalid hash, expected a base32hex string." - Just h -> pure $ Left h -parseBranchId s = Right <$> Path.parsePath' s + Just h -> pure $ BranchAtSCH h +parseBranchId s = BranchAtPath <$> Path.parsePath' s parseBranchId2 :: String -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath) parseBranchId2 ('#' : s) = case SCH.fromText (Text.pack s) of @@ -106,21 +121,16 @@ data Input -- clone w/o merge, error if would clobber ForkLocalBranchI (Either ShortCausalHash BranchRelativePath) BranchRelativePath | -- merge first causal into destination - MergeLocalBranchI LooseCodeOrProject LooseCodeOrProject Branch.MergeMode - | PreviewMergeLocalBranchI LooseCodeOrProject LooseCodeOrProject - | DiffNamespaceI BranchId BranchId -- old new + MergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) Branch.MergeMode + | PreviewMergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) + | DiffNamespaceI BranchId2 BranchId2 -- old new | PullI !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput - | ResetRootI (Either ShortCausalHash Path') - | ResetI - ( These - (Either ShortCausalHash Path') - (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - ) - (Maybe LooseCodeOrProject) - | -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? + | ResetI (BranchId2 {- namespace to reset it to -}) (Maybe UnresolvedProjectBranch {- ProjectBranch to reset -}) + | -- | used in Welcome module to give directions to user + -- + -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? -- Does it make sense to fork from not-the-root of a Github repo? - -- used in Welcome module to give directions to user CreateMessage (P.Pretty P.ColorText) | -- Change directory. SwitchBranchI Path' @@ -132,8 +142,8 @@ data Input -- > names .foo.bar#asdflkjsdf -- > names #sdflkjsdfhsdf NamesI IsGlobal (HQ.HashQualified Name) - | AliasTermI HashOrHQSplit' Path.Split' - | AliasTypeI HashOrHQSplit' Path.Split' + | AliasTermI !Bool HashOrHQSplit' Path.Split' -- bool = force? + | AliasTypeI !Bool HashOrHQSplit' Path.Split' -- bool = force? | AliasManyI [Path.HQSplit] Path' | MoveAllI Path.Path' Path.Path' | -- Move = Rename; It's an HQSplit' not an HQSplit', meaning the arg has to have a name. @@ -150,7 +160,7 @@ data Input | UpdateI OptionalPatch (Set Name) | Update2I | PreviewUpdateI (Set Name) - | TodoI (Maybe PatchPath) Path' + | TodoI | UndoI | -- First `Maybe Int` is cap on number of results, if any -- Second `Maybe Int` is cap on diff elements shown, if any @@ -159,17 +169,17 @@ data Input ExecuteI (HQ.HashQualified Name) [String] | -- save the result of a previous Execute SaveExecuteResultI Name - | -- execute an IO [Result] - IOTestI (HQ.HashQualified Name) - | -- execute all in-scope IO tests - IOTestAllI + | -- execute an IO [Result], bool selects runtime + IOTestI Bool (HQ.HashQualified Name) + | -- execute all in-scope IO tests, interpreter or native + IOTestAllI Bool | -- make a standalone binary file MakeStandaloneI String (HQ.HashQualified Name) | -- execute an IO thunk using scheme ExecuteSchemeI (HQ.HashQualified Name) [String] - | -- compile to a scheme file - CompileSchemeI Text (HQ.HashQualified Name) - | TestI TestInput + | -- compile to a scheme file; profiling flag + CompileSchemeI Bool Text (HQ.HashQualified Name) + | TestI Bool TestInput | CreateAuthorI NameSegment {- identifier -} Text {- name -} | -- Display provided definitions. DisplayI OutputLocation (NonEmpty (HQ.HashQualified Name)) @@ -180,9 +190,13 @@ data Input | FindShallowI Path' | StructuredFindI FindScope (HQ.HashQualified Name) -- sfind findScope query | StructuredFindReplaceI (HQ.HashQualified Name) -- sfind.replace rewriteQuery + | TextFindI Bool [String] -- TextFindI allowLib tokens | -- Show provided definitions. ShowDefinitionI OutputLocation ShowDefinitionScope (NonEmpty (HQ.HashQualified Name)) - | ShowReflogI + | ShowRootReflogI {- Deprecated -} + | ShowGlobalReflogI + | ShowProjectReflogI (Maybe ProjectName) + | ShowProjectBranchReflogI (Maybe (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)) | UpdateBuiltinsI | MergeBuiltinsI (Maybe Path) | MergeIOBuiltinsI (Maybe Path) @@ -192,6 +206,7 @@ data Input -- no path is provided. NamespaceDependenciesI (Maybe Path') | DebugTabCompletionI [String] -- The raw arguments provided + | DebugLSPNameCompletionI Text -- The raw arguments provided | DebugFuzzyOptionsI String [String] -- cmd and arguments | DebugFormatI | DebugNumberedArgsI @@ -208,7 +223,7 @@ data Input | ApiI | UiI Path' | DocToMarkdownI Name - | DocsToHtmlI Path' FilePath + | DocsToHtmlI BranchRelativePath FilePath | AuthLoginI | VersionI | ProjectCreateI Bool {- try downloading base? -} (Maybe ProjectName) @@ -229,6 +244,8 @@ data Input !(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) | UpgradeCommitI | MergeCommitI + | DebugSynhashTermI !Name + | EditDependentsI !(HQ.HashQualified Name) deriving (Eq, Show) -- | The source of a `branch` command: what to make the new branch from. @@ -237,8 +254,8 @@ data BranchSourceI BranchSourceI'CurrentContext | -- | Create an empty branch BranchSourceI'Empty - | -- | Create a branch from this loose-code-or-project - BranchSourceI'LooseCodeOrProject LooseCodeOrProject + | -- | Create a branch from this other branch + BranchSourceI'UnresolvedProjectBranch UnresolvedProjectBranch deriving stock (Eq, Show) -- | Pull source and target: either neither is specified, or only a source, or both. @@ -249,15 +266,14 @@ data PullSourceTarget deriving stock (Eq, Show) data PushSource - = PathySource Path' - | ProjySource (These ProjectName ProjectBranchName) + = ProjySource (These ProjectName ProjectBranchName) deriving stock (Eq, Show) -- | Push source and target: either neither is specified, or only a target, or both. data PushSourceTarget = PushSourceTarget0 - | PushSourceTarget1 (WriteRemoteNamespace (These ProjectName ProjectBranchName)) - | PushSourceTarget2 PushSource (WriteRemoteNamespace (These ProjectName ProjectBranchName)) + | PushSourceTarget1 (These ProjectName ProjectBranchName) + | PushSourceTarget2 PushSource (These ProjectName ProjectBranchName) deriving stock (Eq, Show) data PushRemoteBranchInput = PushRemoteBranchInput @@ -279,11 +295,17 @@ data TestInput = TestInput -- Some commands, like `view`, can dump output to either console or a file. data OutputLocation = ConsoleLocation - | LatestFileLocation - | FileLocation FilePath + | LatestFileLocation RelativeToFold + | FileLocation FilePath RelativeToFold -- ClipboardLocation deriving (Eq, Show) +-- | Above a new fold, or within the topmost fold? +data RelativeToFold + = AboveFold + | WithinFold + deriving stock (Eq, Show) + data FindScope = FindLocal Path' | FindLocalAndDeps Path' diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 6e16b4d1a9..7ebf9ad299 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -8,6 +8,9 @@ module Unison.Codebase.Editor.Output ListDetailed, HistoryTail (..), TestReportStats (..), + TodoOutput (..), + todoOutputIsEmpty, + MoreEntriesThanShown (..), UndoFailureReason (..), ShareError (..), UpdateOrUpgrade (..), @@ -17,15 +20,18 @@ module Unison.Codebase.Editor.Output where import Data.List.NonEmpty (NonEmpty) +import Data.Set qualified as Set import Data.Set.NonEmpty (NESet) import Data.Time (UTCTime) import Network.URI (URI) import Servant.Client qualified as Servant (ClientError) import System.Console.Haskeline qualified as Completion +import System.Exit (ExitCode) import U.Codebase.Branch.Diff (NameChanges) import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite +import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog import Unison.Auth.Types (CredentialFailure) import Unison.Cli.MergeTypes (MergeSourceAndTarget, MergeSourceOrTarget) import Unison.Cli.Share.Projects.Types qualified as Share @@ -37,35 +43,39 @@ import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.SlurpResult (SlurpResult (..)) import Unison.Codebase.Editor.SlurpResult qualified as SR import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) -import Unison.Codebase.Editor.TodoOutput qualified as TO import Unison.Codebase.IntegrityCheck (IntegrityResult (..)) import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path -import Unison.Codebase.PushBehavior (PushBehavior) +import Unison.Codebase.ProjectPath (Project, ProjectBranch, ProjectPath) import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH +import Unison.CommandLine.BranchRelativePath (BranchRelativePath) import Unison.CommandLine.InputPattern qualified as Input import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration.ConstructorId (ConstructorId) +import Unison.Hash (Hash) import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.LabeledDependency (LabeledDependency) +import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason, IncoherentDeclReasons (..)) import Unison.Name (Name) import Unison.NameSegment (NameSegment) import Unison.Names (Names) +import Unison.Names qualified as Names import Unison.Names.ResolutionResult qualified as Names import Unison.NamesWithHistory qualified as Names import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl) import Unison.PrettyPrintEnvDecl qualified as PPE import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName, Semver) -import Unison.Reference (Reference, TermReferenceId, TypeReference) +import Unison.Reference (Reference, TermReference, TermReferenceId, TypeReference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Server.Backend (ShallowListEntry (..)) -import Unison.Server.SearchResult' (SearchResult') +import Unison.Server.SearchResultPrime (SearchResult') import Unison.Share.Sync.Types qualified as Sync import Unison.ShortHash (ShortHash) import Unison.Symbol (Symbol) @@ -75,6 +85,9 @@ import Unison.Term (Term) import Unison.Type (Type) import Unison.Typechecker.Context qualified as Context import Unison.UnisonFile qualified as UF +import Unison.Util.Conflicted (Conflicted) +import Unison.Util.Defn (Defn) +import Unison.Util.Defns (DefnsF, defnsAreEmpty) import Unison.Util.Pretty qualified as P import Unison.Util.Relation (Relation) import Unison.WatchKind qualified as WK @@ -93,32 +106,38 @@ type NumberedArgs = [StructuredArgument] type HashLength = Int data NumberedOutput - = ShowDiffNamespace AbsBranchId AbsBranchId PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) + = ShowDiffNamespace (Either ShortCausalHash ProjectPath) (Either ShortCausalHash ProjectPath) PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterMerge - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - Path.Absolute + (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + ProjectPath PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterMergePropagate - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - Path.Absolute + (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + ProjectPath Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterMergePreview - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - Path.Absolute + (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + ProjectPath PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | -- ShowDiffAfterCreateAuthor NameSegment Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) - | -- | Invariant: there's at least one conflict or edit in the TodoOutput. - TodoOutput PPE.PrettyPrintEnvDecl (TO.TodoOutput Symbol Ann) + | TestResults + TestReportStats + PPE.PrettyPrintEnv + ShowSuccesses + ShowFailures + (Map TermReferenceId [Text]) -- oks + (Map TermReferenceId [Text]) -- fails + | Output'Todo !TodoOutput | -- | CantDeleteDefinitions ppe couldntDelete becauseTheseStillReferenceThem CantDeleteDefinitions PPE.PrettyPrintEnvDecl (Map LabeledDependency (NESet LabeledDependency)) | -- | CantDeleteNamespace ppe couldntDelete becauseTheseStillReferenceThem @@ -138,8 +157,30 @@ data NumberedOutput | -- | List all direct dependencies which don't have any names in the current branch ListNamespaceDependencies PPE.PrettyPrintEnv -- PPE containing names for everything from the root namespace. - Path.Absolute -- The namespace we're checking dependencies for. + ProjectPath -- The namespace we're checking dependencies for. (Map LabeledDependency (Set Name)) -- Mapping of external dependencies to their local dependents. + | ShowProjectBranchReflog + (Maybe UTCTime {- current time, omitted in transcript tests to be more deterministic -}) + MoreEntriesThanShown + [ProjectReflog.Entry Project ProjectBranch (CausalHash, SCH.ShortCausalHash)] + +data TodoOutput = TodoOutput + { defnsInLib :: !Bool, + dependentsOfTodo :: !(Set TermReferenceId), + directDependenciesWithoutNames :: !(DefnsF Set TermReference TypeReference), + hashLen :: !Int, + incoherentDeclReasons :: !IncoherentDeclReasons, + nameConflicts :: !Names, + ppe :: !PrettyPrintEnvDecl + } + +todoOutputIsEmpty :: TodoOutput -> Bool +todoOutputIsEmpty todo = + Set.null todo.dependentsOfTodo + && defnsAreEmpty todo.directDependenciesWithoutNames + && Names.isEmpty todo.nameConflicts + && not todo.defnsInLib + && todo.incoherentDeclReasons == IncoherentDeclReasons [] [] [] [] data AmbiguousReset'Argument = AmbiguousReset'Hash @@ -161,15 +202,15 @@ data Output | -- | Function found, but has improper type -- Note: the constructor name is misleading here; we weren't necessarily looking for a "main". BadMainFunction + -- | what we were trying to do (e.g. "run", "io.test") Text - -- ^ what we were trying to do (e.g. "run", "io.test") + -- | name of function (HQ.HashQualified Name) - -- ^ name of function + -- | bad type of function (Type Symbol Ann) - -- ^ bad type of function PPE.PrettyPrintEnv + -- | acceptable type(s) of function [Type Symbol Ann] - -- ^ acceptable type(s) of function | BranchEmpty WhichBranchEmpty | LoadPullRequest (ReadRemoteNamespace Void) (ReadRemoteNamespace Void) Path' Path' Path' Path' | CreatedNewBranch Path.Absolute @@ -178,7 +219,7 @@ data Output | NoExactTypeMatches | TypeAlreadyExists Path.Split' (Set Reference) | TypeParseError String (Parser.Err Symbol) - | ParseResolutionFailures String [Names.ResolutionFailure Symbol Ann] + | ParseResolutionFailures String [Names.ResolutionFailure Ann] | TypeHasFreeVars (Type Symbol Ann) | TermAlreadyExists Path.Split' (Set Referent) | LabeledReferenceAmbiguous Int (HQ.HashQualified Name) (Set LabeledDependency) @@ -206,12 +247,12 @@ data Output -- for terms. This additional info is used to provide an enhanced -- error message. SearchTermsNotFoundDetailed + -- | @True@ if we are searching for a term, @False@ if we are searching for a type Bool - -- ^ @True@ if we are searching for a term, @False@ if we are searching for a type + -- | Misses (search terms that returned no hits for terms or types) [HQ.HashQualified Name] - -- ^ Misses (search terms that returned no hits for terms or types) + -- | Hits for types if we are searching for terms or terms if we are searching for types [HQ.HashQualified Name] - -- ^ Hits for types if we are searching for terms or terms if we are searching for types | -- ask confirmation before deleting the last branch that contains some defns -- `Path` is one of the paths the user has requested to delete, and is paired -- with whatever named definitions would not have any remaining names if @@ -223,7 +264,11 @@ data Output | MovedOverExistingBranch Path' | DeletedEverything | ListNames - IsGlobal + Int -- hq length to print References + [(Reference, [HQ'.HashQualified Name])] -- type match, type names + [(Referent, [HQ'.HashQualified Name])] -- term match, term names + | GlobalListNames + (ProjectAndBranch ProjectName ProjectBranchName) Int -- hq length to print References [(Reference, [HQ'.HashQualified Name])] -- type match, type names [(Referent, [HQ'.HashQualified Name])] -- term match, term names @@ -231,6 +276,8 @@ data Output | ListOfDefinitions FindScope PPE.PrettyPrintEnv ListDetailed [SearchResult' Symbol Ann] | ListShallow (IO PPE.PrettyPrintEnv) [ShallowListEntry Symbol Ann] | ListStructuredFind [HQ.HashQualified Name] + | ListTextFind Bool [HQ.HashQualified Name] -- whether lib was included in the search + | GlobalFindBranchResults (ProjectAndBranch ProjectName ProjectBranchName) PPE.PrettyPrintEnv ListDetailed [SearchResult' Symbol Ann] | -- ListStructuredFind patternMatchingUsages termBodyUsages -- show the result of add/update SlurpOutput Input PPE.PrettyPrintEnv SlurpResult @@ -254,20 +301,13 @@ data Output | LoadedDefinitionsToSourceFile FilePath Int | TestIncrementalOutputStart PPE.PrettyPrintEnv (Int, Int) TermReferenceId | TestIncrementalOutputEnd PPE.PrettyPrintEnv (Int, Int) TermReferenceId Bool {- True if success, False for Failure -} - | TestResults - TestReportStats - PPE.PrettyPrintEnv - ShowSuccesses - ShowFailures - [(TermReferenceId, Text)] -- oks - [(TermReferenceId, Text)] -- fails | CantUndo UndoFailureReason | -- new/unrepresented references followed by old/removed -- todo: eventually replace these sets with [SearchResult' v Ann] -- and a nicer render. BustedBuiltins (Set Reference) (Set Reference) | ShareError ShareError - | ViewOnShare (Either WriteShareRemoteNamespace (URI, ProjectName, ProjectBranchName)) + | ViewOnShare (URI, ProjectName, ProjectBranchName) | NoConfiguredRemoteMapping PushPull Path.Absolute | ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String | TermMissingType Reference @@ -285,16 +325,10 @@ data Output | AboutToMerge | -- | Indicates a trivial merge where the destination was empty and was just replaced. MergeOverEmpty (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) - | MergeAlreadyUpToDate - (Either Path' (ProjectAndBranch ProjectName ProjectBranchName)) - (Either Path' (ProjectAndBranch ProjectName ProjectBranchName)) + | MergeAlreadyUpToDate BranchRelativePath BranchRelativePath | -- This will replace the above once `merge.old` is deleted MergeAlreadyUpToDate2 !MergeSourceAndTarget - | PreviewMergeAlreadyUpToDate - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - | -- | No conflicts or edits remain for the current patch. - NoConflictsOrEdits + | PreviewMergeAlreadyUpToDate ProjectPath ProjectPath | NotImplemented | NoBranchWithHash ShortCausalHash | ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms @@ -306,10 +340,8 @@ data Output | BadName Text | CouldntLoadBranch CausalHash | HelpMessage Input.InputPattern - | NamespaceEmpty (NonEmpty AbsBranchId) + | NamespaceEmpty (NonEmpty (Either ShortCausalHash ProjectPath)) | NoOp - | -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace. - RefusedToPush PushBehavior (WriteRemoteNamespace Void) | -- | @GistCreated repo@ means a causal was just published to @repo@. GistCreated (ReadRemoteNamespace Void) | -- | Directs the user to URI to begin an authorization flow. @@ -320,6 +352,7 @@ data Output | IntegrityCheck IntegrityResult | DisplayDebugNameDiff NameChanges | DisplayDebugCompletions [Completion.Completion] + | DisplayDebugLSPNameCompletions [(Text, Name, LabeledDependency)] | DebugDisplayFuzzyOptions Text [String {- arg description, options -}] | DebugFuzzyOptionsNoResolver | DebugTerm (Bool {- verbose mode -}) (Either (Text {- A builtin hash -}) (Term Symbol Ann)) @@ -368,8 +401,8 @@ data Output | CalculatingDiff | -- | The `local` in a `clone remote local` is ambiguous AmbiguousCloneLocal + -- | Treating `local` as a project. We may know the branch name, if it was provided in `remote`. (ProjectAndBranch ProjectName ProjectBranchName) - -- ^ Treating `local` as a project. We may know the branch name, if it was provided in `remote`. (ProjectAndBranch ProjectName ProjectBranchName) | -- | The `remote` in a `clone remote local` is ambiguous AmbiguousCloneRemote ProjectName (ProjectAndBranch ProjectName ProjectBranchName) @@ -384,31 +417,32 @@ data Output | FailedToFetchLatestReleaseOfBase | HappyCoding | ProjectHasNoReleases ProjectName - | UpdateLookingForDependents - | UpdateStartTypechecking | UpdateTypecheckingFailure - | UpdateTypecheckingSuccess | UpdateIncompleteConstructorSet UpdateOrUpgrade Name (Map ConstructorId Name) (Maybe Int) | UpgradeFailure !ProjectBranchName !ProjectBranchName !FilePath !NameSegment !NameSegment | UpgradeSuccess !NameSegment !NameSegment - | LooseCodePushDeprecated | MergeFailure !FilePath !MergeSourceAndTarget !ProjectBranchName + | MergeFailureWithMergetool !MergeSourceAndTarget !ProjectBranchName !Text !ExitCode | MergeSuccess !MergeSourceAndTarget | MergeSuccessFastForward !MergeSourceAndTarget - | MergeConflictedAliases !MergeSourceOrTarget !Name !Name - | MergeConflictedTermName !Name !(NESet Referent) - | MergeConflictedTypeName !Name !(NESet TypeReference) - | MergeConflictInvolvingBuiltin !Name - | MergeConstructorAlias !MergeSourceOrTarget !Name !Name !Name + | MergeConflictedAliases !MergeSourceOrTarget !(Defn (Name, Name) (Name, Name)) + | MergeConflictInvolvingBuiltin !(Defn Name Name) | MergeDefnsInLib !MergeSourceOrTarget - | MergeMissingConstructorName !MergeSourceOrTarget !Name - | MergeNestedDeclAlias !MergeSourceOrTarget !Name !Name - | MergeStrayConstructor !MergeSourceOrTarget !Name | InstalledLibdep !(ProjectAndBranch ProjectName ProjectBranchName) !NameSegment | NoUpgradeInProgress | UseLibInstallNotPull !(ProjectAndBranch ProjectName ProjectBranchName) | PullIntoMissingBranch !(ReadRemoteNamespace Share.RemoteProjectBranch) !(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) | NoMergeInProgress + | Output'DebugSynhashTerm !TermReference !Hash !Text + | ConflictedDefn !Text {- what operation? -} !(Defn (Conflicted Name Referent) (Conflicted Name TypeReference)) + | IncoherentDeclDuringMerge !MergeSourceOrTarget !IncoherentDeclReason + | IncoherentDeclDuringUpdate !IncoherentDeclReason + | -- | A literal output message. Use this if it's too cumbersome to create a new Output constructor, e.g. for + -- ephemeral progress messages that are just simple strings like "Loading branch..." + Literal !(P.Pretty P.ColorText) + +data MoreEntriesThanShown = MoreEntriesThanShown | AllEntriesShown + deriving (Eq, Show) data UpdateOrUpgrade = UOUUpdate | UOUUpgrade @@ -427,12 +461,10 @@ data CreatedProjectBranchFrom -- | A branch was empty. But how do we refer to that branch? data WhichBranchEmpty = WhichBranchEmptyHash ShortCausalHash - | WhichBranchEmptyPath Path' + | WhichBranchEmptyPath ProjectPath data ShareError - = ShareErrorCheckAndSetPush Sync.CheckAndSetPushError - | ShareErrorDownloadEntities Share.DownloadEntitiesError - | ShareErrorFastForwardPush Sync.FastForwardPushError + = ShareErrorDownloadEntities Share.DownloadEntitiesError | ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError | ShareErrorPull Sync.PullError | ShareErrorTransport Sync.CodeserverTransportError @@ -464,10 +496,7 @@ type SourceFileContents = Text isFailure :: Output -> Bool isFailure o = case o of - UpdateLookingForDependents -> False - UpdateStartTypechecking -> False UpdateTypecheckingFailure {} -> True - UpdateTypecheckingSuccess {} -> False UpdateIncompleteConstructorSet {} -> True AmbiguousCloneLocal {} -> True AmbiguousCloneRemote {} -> True @@ -518,9 +547,12 @@ isFailure o = case o of MoveRootBranchConfirmation -> False MovedOverExistingBranch {} -> False DeletedEverything -> False - ListNames _ _ tys tms -> null tms && null tys + ListNames _ tys tms -> null tms && null tys + GlobalListNames {} -> False ListOfDefinitions _ _ _ ds -> null ds + GlobalFindBranchResults _ _ _ _ -> False ListStructuredFind tms -> null tms + ListTextFind _ tms -> null tms SlurpOutput _ _ sr -> not $ SR.isOk sr ParseErrors {} -> True TypeErrors {} -> True @@ -535,7 +567,6 @@ isFailure o = case o of DisplayRendered {} -> False TestIncrementalOutputStart {} -> False TestIncrementalOutputEnd {} -> False - TestResults _ _ _ _ _ fails -> not (null fails) CantUndo {} -> True BustedBuiltins {} -> True NoConfiguredRemoteMapping {} -> True @@ -555,7 +586,6 @@ isFailure o = case o of MergeAlreadyUpToDate {} -> False MergeAlreadyUpToDate2 {} -> False PreviewMergeAlreadyUpToDate {} -> False - NoConflictsOrEdits {} -> False ListShallow _ es -> null es HashAmbiguous {} -> True ShowReflog {} -> False @@ -567,7 +597,6 @@ isFailure o = case o of TermMissingType {} -> True DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty NamespaceEmpty {} -> True - RefusedToPush {} -> True GistCreated {} -> False InitiateAuthFlow {} -> False UnknownCodeServer {} -> True @@ -580,6 +609,7 @@ isFailure o = case o of ShareError {} -> True ViewOnShare {} -> False DisplayDebugCompletions {} -> False + DisplayDebugLSPNameCompletions {} -> False DebugDisplayFuzzyOptions {} -> False DebugFuzzyOptionsNoResolver {} -> True DebugTerm {} -> False @@ -631,24 +661,23 @@ isFailure o = case o of ProjectHasNoReleases {} -> True UpgradeFailure {} -> True UpgradeSuccess {} -> False - LooseCodePushDeprecated -> True MergeFailure {} -> True + MergeFailureWithMergetool {} -> True MergeSuccess {} -> False MergeSuccessFastForward {} -> False MergeConflictedAliases {} -> True - MergeConflictedTermName {} -> True - MergeConflictedTypeName {} -> True MergeConflictInvolvingBuiltin {} -> True - MergeConstructorAlias {} -> True MergeDefnsInLib {} -> True - MergeMissingConstructorName {} -> True - MergeNestedDeclAlias {} -> True - MergeStrayConstructor {} -> True InstalledLibdep {} -> False NoUpgradeInProgress {} -> True UseLibInstallNotPull {} -> False PullIntoMissingBranch {} -> True NoMergeInProgress {} -> True + Output'DebugSynhashTerm {} -> False + ConflictedDefn {} -> True + IncoherentDeclDuringMerge {} -> True + IncoherentDeclDuringUpdate {} -> True + Literal _ -> False isNumberedFailure :: NumberedOutput -> Bool isNumberedFailure = \case @@ -671,4 +700,6 @@ isNumberedFailure = \case ShowDiffAfterUndo {} -> False ShowDiffNamespace _ _ _ bd -> BD.isEmpty bd ListNamespaceDependencies {} -> False - TodoOutput _ todo -> TO.todoScore todo > 0 || not (TO.noConflicts todo) + TestResults _ _ _ _ _ fails -> not (null fails) + Output'Todo {} -> False + ShowProjectBranchReflog {} -> False diff --git a/unison-cli/src/Unison/Codebase/Editor/Output/BranchDiff.hs b/unison-cli/src/Unison/Codebase/Editor/Output/BranchDiff.hs index 27fff49aea..47f5952d37 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output/BranchDiff.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output/BranchDiff.hs @@ -10,7 +10,7 @@ import Unison.Codebase.BranchDiff (BranchDiff (BranchDiff)) import Unison.Codebase.BranchDiff qualified as BranchDiff import Unison.Codebase.Patch qualified as P import Unison.DataDeclaration (DeclOrBuiltin) -import Unison.HashQualified' (HashQualified) +import Unison.HashQualifiedPrime (HashQualified) import Unison.Name (Name) import Unison.Name qualified as Name import Unison.Names (Names) diff --git a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs index f1bf65962c..5864517034 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs @@ -14,7 +14,6 @@ import U.Codebase.Reference qualified as Reference import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli -import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.TypeCheck qualified as Cli (computeTypecheckingEnvironment) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase @@ -82,11 +81,12 @@ noEdits :: Edits v noEdits = Edits mempty mempty mempty mempty mempty mempty mempty propagateAndApply :: + Names -> Patch -> Branch0 IO -> Cli (Branch0 IO) -propagateAndApply patch branch = do - edits <- propagate patch branch +propagateAndApply rootNames patch branch = do + edits <- propagate rootNames patch branch let f = applyPropagate patch edits (pure . f . applyDeprecations patch) branch @@ -234,15 +234,13 @@ debugMode = False -- -- "dirty" means in need of update -- "frontier" means updated definitions responsible for the "dirty" -propagate :: Patch -> Branch0 IO -> Cli (Edits Symbol) -propagate patch b = case validatePatch patch of +propagate :: Names -> Patch -> Branch0 IO -> Cli (Edits Symbol) +propagate rootNames patch b = case validatePatch patch of Nothing -> do Cli.respond PatchNeedsToBeConflictFree pure noEdits Just (initialTermEdits, initialTypeEdits) -> do -- TODO: this can be removed once patches have term replacement of type `Referent -> Referent` - rootNames <- Branch.toNames <$> Cli.getRootBranch0 - let -- TODO: these are just used for tracing, could be deleted if we don't care -- about printing meaningful names for definitions during propagation, or if -- we want to just remove the tracing. diff --git a/unison-cli/src/Unison/Codebase/Editor/Slurp.hs b/unison-cli/src/Unison/Codebase/Editor/Slurp.hs index 3c7e9e5239..df5f4beb60 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Slurp.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Slurp.hs @@ -21,7 +21,7 @@ import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Referent (Referent) import Unison.Referent qualified as Referent -import Unison.Referent' qualified as Referent +import Unison.ReferentPrime qualified as Referent import Unison.Symbol (Symbol) import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar) import Unison.UnisonFile qualified as UF diff --git a/unison-cli/src/Unison/Codebase/Editor/SlurpComponent.hs b/unison-cli/src/Unison/Codebase/Editor/SlurpComponent.hs index 82cc4a862a..3e51fb9aa2 100644 --- a/unison-cli/src/Unison/Codebase/Editor/SlurpComponent.hs +++ b/unison-cli/src/Unison/Codebase/Editor/SlurpComponent.hs @@ -25,21 +25,22 @@ import Data.Set qualified as Set import Data.Tuple (swap) import Unison.DataDeclaration qualified as DD import Unison.Prelude hiding (empty) -import Unison.Reference (Reference) +import Unison.Reference (TypeReference) import Unison.Symbol (Symbol) import Unison.Term qualified as Term import Unison.UnisonFile (TypecheckedUnisonFile) import Unison.UnisonFile qualified as UF +import Unison.Util.Defns (Defns (..)) data SlurpComponent = SlurpComponent { types :: Set Symbol, terms :: Set Symbol, ctors :: Set Symbol } - deriving (Eq, Ord, Show) + deriving (Eq, Generic, Ord, Show) isEmpty :: SlurpComponent -> Bool -isEmpty sc = Set.null (types sc) && Set.null (terms sc) && Set.null (ctors sc) +isEmpty sc = Set.null sc.types && Set.null sc.terms && Set.null sc.ctors empty :: SlurpComponent empty = SlurpComponent {types = Set.empty, terms = Set.empty, ctors = Set.empty} @@ -47,23 +48,23 @@ empty = SlurpComponent {types = Set.empty, terms = Set.empty, ctors = Set.empty} difference :: SlurpComponent -> SlurpComponent -> SlurpComponent difference c1 c2 = SlurpComponent {types = types', terms = terms', ctors = ctors'} where - types' = types c1 `Set.difference` types c2 - terms' = terms c1 `Set.difference` terms c2 - ctors' = ctors c1 `Set.difference` ctors c2 + types' = c1.types `Set.difference` c2.types + terms' = c1.terms `Set.difference` c2.terms + ctors' = c1.ctors `Set.difference` c2.ctors intersection :: SlurpComponent -> SlurpComponent -> SlurpComponent intersection c1 c2 = SlurpComponent {types = types', terms = terms', ctors = ctors'} where - types' = types c1 `Set.intersection` types c2 - terms' = terms c1 `Set.intersection` terms c2 - ctors' = ctors c1 `Set.intersection` ctors c2 + types' = c1.types `Set.intersection` c2.types + terms' = c1.terms `Set.intersection` c2.terms + ctors' = c1.ctors `Set.intersection` c2.ctors instance Semigroup SlurpComponent where c1 <> c2 = SlurpComponent - { types = types c1 <> types c2, - terms = terms c1 <> terms c2, - ctors = ctors c1 <> ctors c2 + { types = c1.types <> c2.types, + terms = c1.terms <> c2.terms, + ctors = c1.ctors <> c2.ctors } instance Monoid SlurpComponent where @@ -79,31 +80,30 @@ closeWithDependencies :: SlurpComponent closeWithDependencies uf inputs = seenDefns {ctors = constructorDeps} where - seenDefns = foldl' termDeps (SlurpComponent {terms = mempty, types = seenTypes, ctors = mempty}) (terms inputs) - seenTypes = foldl' typeDeps mempty (types inputs) + seenDefns = foldl' termDeps (SlurpComponent {terms = mempty, types = seenTypes, ctors = mempty}) inputs.terms + seenTypes = foldl' typeDeps mempty inputs.types constructorDeps :: Set Symbol constructorDeps = UF.constructorsForDecls seenTypes uf termDeps :: SlurpComponent -> Symbol -> SlurpComponent - termDeps seen v | Set.member v (terms seen) = seen - termDeps seen v = fromMaybe seen $ do + termDeps seen v | Set.member v seen.terms = seen + termDeps seen v = fromMaybe seen do term <- findTerm v let -- get the `v`s for the transitive dependency types -- (the ones for terms are just the `freeVars below`) -- although this isn't how you'd do it for a term that's already in codebase tdeps :: [Symbol] - tdeps = resolveTypes $ Term.dependencies term + tdeps = resolveTypes (Term.dependencies term).types seenTypes :: Set Symbol - seenTypes = foldl' typeDeps (types seen) tdeps - seenTerms = Set.insert v (terms seen) + seenTypes = foldl' typeDeps seen.types tdeps + seenTerms = Set.insert v seen.terms pure $ foldl' termDeps ( seen - { types = seenTypes, - terms = seenTerms - } + & #types .~ seenTypes + & #terms .~ seenTerms ) (Term.freeVars term) @@ -115,7 +115,7 @@ closeWithDependencies uf inputs = seenDefns {ctors = constructorDeps} <|> fmap (DD.toDataDecl . snd) (Map.lookup v (UF.effectDeclarations' uf)) pure $ foldl' typeDeps (Set.insert v seen) (resolveTypes $ DD.typeDependencies dd) - resolveTypes :: Set Reference -> [Symbol] + resolveTypes :: Set TypeReference -> [Symbol] resolveTypes rs = [v | r <- Set.toList rs, Just v <- [Map.lookup r typeNames]] findTerm :: Symbol -> Maybe (Term.Term Symbol a) @@ -123,17 +123,17 @@ closeWithDependencies uf inputs = seenDefns {ctors = constructorDeps} allTerms = UF.allTerms uf - typeNames :: Map Reference Symbol + typeNames :: Map TypeReference Symbol typeNames = invert (fst <$> UF.dataDeclarations' uf) <> invert (fst <$> UF.effectDeclarations' uf) invert :: forall k v. (Ord k) => (Ord v) => Map k v -> Map v k invert m = Map.fromList (swap <$> Map.toList m) fromTypes :: Set Symbol -> SlurpComponent -fromTypes vs = mempty {types = vs} +fromTypes vs = SlurpComponent {terms = Set.empty, types = vs, ctors = Set.empty} fromTerms :: Set Symbol -> SlurpComponent -fromTerms vs = mempty {terms = vs} +fromTerms vs = SlurpComponent {terms = vs, types = Set.empty, ctors = Set.empty} fromCtors :: Set Symbol -> SlurpComponent -fromCtors vs = mempty {ctors = vs} +fromCtors vs = SlurpComponent {terms = Set.empty, types = Set.empty, ctors = vs} diff --git a/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs b/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs index 33dbddf9b8..21ee27c637 100644 --- a/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs +++ b/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs @@ -6,7 +6,7 @@ import Unison.Codebase.Editor.Input import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Parser.Ann (Ann) import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) diff --git a/unison-cli/src/Unison/Codebase/Editor/TodoOutput.hs b/unison-cli/src/Unison/Codebase/Editor/TodoOutput.hs deleted file mode 100644 index f6458ca57b..0000000000 --- a/unison-cli/src/Unison/Codebase/Editor/TodoOutput.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module Unison.Codebase.Editor.TodoOutput where - -import Data.Set qualified as Set -import Unison.Codebase.Editor.DisplayObject (DisplayObject (UserObject)) -import Unison.Codebase.Patch (Patch) -import Unison.Codebase.Patch qualified as Patch -import Unison.DataDeclaration (Decl) -import Unison.DataDeclaration qualified as DD -import Unison.LabeledDependency (LabeledDependency) -import Unison.LabeledDependency qualified as LD -import Unison.Names (Names) -import Unison.Names qualified as Names -import Unison.Prelude -import Unison.Reference (Reference) -import Unison.Type (Type) -import Unison.Type qualified as Type -import Unison.Util.Relation qualified as R - -type Score = Int - -data TodoOutput v a = TodoOutput - { todoScore :: Score, - todoFrontier :: - ( [(Reference, Maybe (Type v a))], - [(Reference, DisplayObject () (Decl v a))] - ), - todoFrontierDependents :: - ( [(Score, Reference, Maybe (Type v a))], - [(Score, Reference, DisplayObject () (Decl v a))] - ), - nameConflicts :: Names, - editConflicts :: Patch - } - -labeledDependencies :: (Ord v) => TodoOutput v a -> Set LabeledDependency -labeledDependencies TodoOutput {..} = - Set.fromList - ( -- term refs - [LD.termRef r | (r, _) <- fst todoFrontier] - <> [LD.termRef r | (_, r, _) <- fst todoFrontierDependents] - <> [LD.typeRef r | (r, _) <- snd todoFrontier] - <> [LD.typeRef r | (_, r, _) <- snd todoFrontierDependents] - <> - -- types of term refs - [ LD.typeRef r | (_, Just t) <- fst todoFrontier, r <- toList (Type.dependencies t) - ] - <> [ LD.typeRef r | (_, _, Just t) <- fst todoFrontierDependents, r <- toList (Type.dependencies t) - ] - <> - -- and decls of type refs - [ labeledDep | (declRef, UserObject d) <- snd todoFrontier, labeledDep <- toList (DD.labeledDeclDependenciesIncludingSelf declRef d) - ] - <> [ labeledDep | (_, declRef, UserObject d) <- snd todoFrontierDependents, labeledDep <- toList (DD.labeledDeclDependenciesIncludingSelf declRef d) - ] - ) - <> - -- name conflicts - Set.map LD.referent (R.ran (Names.terms nameConflicts)) - <> Set.map LD.typeRef (R.ran (Names.types nameConflicts)) - <> Patch.labeledDependencies editConflicts - -noConflicts :: TodoOutput v a -> Bool -noConflicts todo = - nameConflicts todo == mempty && editConflicts todo == Patch.empty - -noEdits :: TodoOutput v a -> Bool -noEdits todo = - todoScore todo == 0 diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index cf7a99a8f9..14e7412c4e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -1,8 +1,7 @@ module Unison.Codebase.Editor.UriParser ( readRemoteNamespaceParser, - writeRemoteNamespace, - writeRemoteNamespaceWith, parseReadShareLooseCode, + writeRemoteNamespace, ) where @@ -17,8 +16,6 @@ import Unison.Codebase.Editor.RemoteRepo ReadShareLooseCode (..), ShareCodeserver (DefaultCodeserver), ShareUserHandle (..), - WriteRemoteNamespace (..), - WriteShareRemoteNamespace (..), ) import Unison.Codebase.Path qualified as Path import Unison.NameSegment (NameSegment) @@ -53,25 +50,9 @@ parseReadShareLooseCode label input = -- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4" -- Just (WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})) -writeRemoteNamespace :: P (WriteRemoteNamespace (These ProjectName ProjectBranchName)) +writeRemoteNamespace :: P (These ProjectName ProjectBranchName) writeRemoteNamespace = - writeRemoteNamespaceWith - (projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier'Name) - -writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a) -writeRemoteNamespaceWith projectBranchParser = - WriteRemoteProjectBranch <$> projectBranchParser - <|> WriteRemoteNamespaceShare <$> writeShareRemoteNamespace - --- >>> P.parseMaybe writeShareRemoteNamespace "unisonweb.base._releases.M4" --- Just (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}) -writeShareRemoteNamespace :: P WriteShareRemoteNamespace -writeShareRemoteNamespace = - P.label "write share remote namespace" $ - WriteShareRemoteNamespace - <$> pure DefaultCodeserver - <*> shareUserHandle - <*> (Path.fromList <$> P.many (C.char '.' *> nameSegment)) + (projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier'Name) -- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4" -- >>> P.parseMaybe readShareLooseCode "unisonweb.base._releases.M4" diff --git a/unison-cli/src/Unison/Codebase/Transcript.hs b/unison-cli/src/Unison/Codebase/Transcript.hs new file mode 100644 index 0000000000..590c9f8d28 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Transcript.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | The data model for Unison transcripts. +module Unison.Codebase.Transcript + ( ExpectingError, + HasBug, + ScratchFileName, + Hidden (..), + UcmLine (..), + UcmContext (..), + APIRequest (..), + pattern CMarkCodeBlock, + Stanza, + InfoTags (..), + defaultInfoTags, + defaultInfoTags', + ProcessedBlock (..), + CMark.Node, + ) +where + +import CMark qualified +import Unison.Core.Project (ProjectBranchName, ProjectName) +import Unison.Prelude +import Unison.Project (ProjectAndBranch) + +type ExpectingError = Bool + +type HasBug = Bool + +type ScratchFileName = Text + +data Hidden = Shown | HideOutput | HideAll + deriving (Eq, Ord, Read, Show) + +data UcmLine + = UcmCommand UcmContext Text + | -- | Text does not include the '--' prefix. + UcmComment Text + | UcmOutputLine Text + deriving (Eq, Show) + +-- | Where a command is run: a project branch (myproject/mybranch>). +data UcmContext + = UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName) + deriving (Eq, Show) + +data APIRequest + = GetRequest Text + | APIComment Text + | APIResponseLine Text + deriving (Eq, Show) + +pattern CMarkCodeBlock :: (Maybe CMark.PosInfo) -> Text -> Text -> CMark.Node +pattern CMarkCodeBlock pos info body = CMark.Node pos (CMark.CODE_BLOCK info body) [] + +type Stanza = Either CMark.Node ProcessedBlock + +data InfoTags a = InfoTags + { hidden :: Hidden, + expectingError :: ExpectingError, + hasBug :: HasBug, + generated :: Bool, + additionalTags :: a + } + deriving (Eq, Ord, Read, Show) + +defaultInfoTags :: a -> InfoTags a +defaultInfoTags = InfoTags Shown False False False + +-- | If the `additionalTags` form a `Monoid`, then you don’t need to provide a default value for them. +defaultInfoTags' :: (Monoid a) => InfoTags a +defaultInfoTags' = defaultInfoTags mempty + +data ProcessedBlock + = Ucm (InfoTags ()) [UcmLine] + | Unison (InfoTags (Maybe ScratchFileName)) Text + | API (InfoTags ()) [APIRequest] + deriving (Eq, Show) diff --git a/unison-cli/src/Unison/Codebase/Transcript/Parser.hs b/unison-cli/src/Unison/Codebase/Transcript/Parser.hs new file mode 100644 index 0000000000..cc335e9f7c --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Transcript/Parser.hs @@ -0,0 +1,227 @@ +-- | Parse and print CommonMark (like Github-flavored Markdown) transcripts. +module Unison.Codebase.Transcript.Parser + ( -- * printing + formatAPIRequest, + formatUcmLine, + formatInfoString, + formatStanzas, + + -- * parsing + stanzas, + ucmLine, + apiRequest, + fenced, + hidden, + expectingError, + language, + ) +where + +import CMark qualified +import Data.Bool (bool) +import Data.Char qualified as Char +import Data.Text qualified as Text +import Text.Megaparsec qualified as P +import Text.Megaparsec.Char qualified as P +import Unison.Codebase.Transcript hiding (expectingError, generated, hasBug, hidden) +import Unison.Prelude +import Unison.Project (fullyQualifiedProjectAndBranchNamesParser) + +padIfNonEmpty :: Text -> Text +padIfNonEmpty line = if Text.null line then line else " " <> line + +formatAPIRequest :: APIRequest -> Text +formatAPIRequest = \case + GetRequest txt -> "GET " <> txt <> "\n" + APIComment txt -> "--" <> txt <> "\n" + APIResponseLine txt -> Text.unlines . fmap padIfNonEmpty $ Text.lines txt + +formatUcmLine :: UcmLine -> Text +formatUcmLine = \case + UcmCommand context txt -> formatContext context <> "> " <> txt <> "\n" + UcmComment txt -> "--" <> txt <> "\n" + UcmOutputLine txt -> Text.unlines . fmap padIfNonEmpty $ Text.lines txt + where + formatContext (UcmContextProject projectAndBranch) = into @Text projectAndBranch + +formatStanzas :: [Stanza] -> Text +formatStanzas = + CMark.nodeToCommonmark [] Nothing . CMark.Node Nothing CMark.DOCUMENT . fmap (either id processedBlockToNode) + +processedBlockToNode :: ProcessedBlock -> CMark.Node +processedBlockToNode = \case + Ucm tags cmds -> mkNode (\() -> Nothing) "ucm" tags $ foldr ((<>) . formatUcmLine) "" cmds + Unison tags txt -> mkNode id "unison" tags txt + API tags apiRequests -> mkNode (\() -> Nothing) "api" tags $ foldr ((<>) . formatAPIRequest) "" apiRequests + where + mkNode formatA lang = CMarkCodeBlock Nothing . formatInfoString formatA lang + +type P = P.Parsec Void Text + +stanzas :: FilePath -> Text -> Either (P.ParseErrorBundle Text Void) [Stanza] +stanzas srcName = + -- TODO: Internal warning if `_DOCUMENT` isn’t `CMark.DOCUMENT`. + (\(CMark.Node _ _DOCUMENT blocks) -> traverse stanzaFromNode blocks) + . CMark.commonmarkToNode [CMark.optSourcePos] + where + stanzaFromNode :: CMark.Node -> Either (P.ParseErrorBundle Text Void) Stanza + stanzaFromNode node = case node of + CMarkCodeBlock (Just CMark.PosInfo {startLine, startColumn}) info body -> + maybe (Left node) pure <$> snd (P.runParser' fenced $ fencedState srcName startLine startColumn info body) + _ -> pure $ Left node + +ucmLine :: P UcmLine +ucmLine = ucmOutputLine <|> ucmComment <|> ucmCommand + where + ucmCommand :: P UcmLine + ucmCommand = + UcmCommand + <$> fmap + UcmContextProject + (fullyQualifiedProjectAndBranchNamesParser <* lineToken (P.chunk ">") <* nonNewlineSpaces) + <*> restOfLine + + ucmComment :: P UcmLine + ucmComment = + P.label "comment (delimited with “--”)" $ + UcmComment <$> (P.chunk "--" *> restOfLine) + + ucmOutputLine :: P UcmLine + ucmOutputLine = UcmOutputLine <$> (P.chunk " " *> restOfLine <|> "" <$ P.single '\n' <|> "" <$ P.chunk " \n") + +restOfLine :: P Text +restOfLine = P.takeWhileP Nothing (/= '\n') <* P.single '\n' + +apiRequest :: P APIRequest +apiRequest = + GetRequest <$> (word "GET" *> spaces *> restOfLine) + <|> APIComment <$> (P.chunk "--" *> restOfLine) + <|> APIResponseLine <$> (P.chunk " " *> restOfLine <|> "" <$ P.single '\n' <|> "" <$ P.chunk " \n") + +formatInfoString :: (a -> Maybe Text) -> Text -> InfoTags a -> Text +formatInfoString formatA language infoTags = + let infoTagText = formatInfoTags formatA infoTags + in if Text.null infoTagText then language else language <> " " <> infoTagText + +formatInfoTags :: (a -> Maybe Text) -> InfoTags a -> Text +formatInfoTags formatA (InfoTags hidden expectingError hasBug generated additionalTags) = + Text.intercalate " " $ + catMaybes + [ formatHidden hidden, + formatExpectingError expectingError, + formatHasBug hasBug, + formatGenerated generated, + formatA additionalTags + ] + +infoTags :: P a -> P (InfoTags a) +infoTags p = + InfoTags + <$> lineToken hidden + <*> lineToken expectingError + <*> lineToken hasBug + <*> lineToken generated + <*> p + <* P.single '\n' + +-- | Parses the info string and contents of a fenced code block. +fenced :: P (Maybe ProcessedBlock) +fenced = do + fenceType <- lineToken language + case fenceType of + "ucm" -> fmap pure $ Ucm <$> infoTags (pure ()) <*> P.manyTill ucmLine P.eof + "unison" -> fmap pure $ Unison <$> infoTags (optional untilSpace1) <*> P.getInput + "api" -> fmap pure $ API <$> infoTags (pure ()) <*> P.manyTill apiRequest P.eof + _ -> pure Nothing + +word :: Text -> P Text +word text = P.chunk text <* P.notFollowedBy P.alphaNumChar + +lineToken :: P a -> P a +lineToken p = p <* nonNewlineSpaces + +nonNewlineSpaces :: P () +nonNewlineSpaces = void $ P.takeWhileP Nothing (\ch -> ch == ' ' || ch == '\t') + +formatHidden :: Hidden -> Maybe Text +formatHidden = \case + HideAll -> pure ":hide-all" + HideOutput -> pure ":hide" + Shown -> Nothing + +hidden :: P Hidden +hidden = + (HideAll <$ word ":hide-all") + <|> (HideOutput <$ word ":hide") + <|> pure Shown + +formatExpectingError :: ExpectingError -> Maybe Text +formatExpectingError = bool Nothing $ pure ":error" + +expectingError :: P ExpectingError +expectingError = isJust <$> optional (word ":error") + +formatHasBug :: HasBug -> Maybe Text +formatHasBug = bool Nothing $ pure ":bug" + +hasBug :: P HasBug +hasBug = isJust <$> optional (word ":bug") + +formatGenerated :: ExpectingError -> Maybe Text +formatGenerated = bool Nothing $ pure ":added-by-ucm" + +generated :: P Bool +generated = isJust <$> optional (word ":added-by-ucm") + +untilSpace1 :: P Text +untilSpace1 = P.takeWhile1P Nothing (not . Char.isSpace) + +language :: P Text +language = P.takeWhileP Nothing (\ch -> Char.isDigit ch || Char.isLower ch || ch == '_') + +spaces :: P () +spaces = void $ P.takeWhileP (Just "spaces") Char.isSpace + +-- | Create a parser state that has source locations that match the file (as opposed to being relative to the start of +-- the individual fenced code block). +-- +-- __NB__: If a code block has a fence longer than the minimum (three backticks), the columns for parse errors in the +-- info string will be slightly off (but the printed code excerpt will match the reported positions). +-- +-- __NB__: Creating custom states is likely simpler starting with Megaparsec 9.6.0. +fencedState :: + -- | file containing the fenced code block + FilePath -> + -- | `CMark.startLine` for the block + Int -> + -- | `CMark.startColumn` for the block` + Int -> + -- | info string from the block + Text -> + -- | contents of the code block + Text -> + P.State Text e +fencedState name startLine startColumn info body = + let -- This is the most common opening fence, so we assume it’s the right one. I don’t think there’s any way to get + -- the actual size of the fence from "CMark", so this can be wrong sometimes, but it’s probably the approach + -- that’s least likely to confuse users. + openingFence = "``` " + -- Glue the info string and body back together, as if they hadn’t been split by "CMark". This keeps the position + -- info in sync. + s = info <> "\n" <> body + in P.State + { stateInput = s, + stateOffset = 0, + statePosState = + P.PosState + { pstateInput = s, + pstateOffset = 0, + -- `CMark.startColumn` marks the beginning of the fence, not the beginning of the info string, so we + -- adjust it for the fence that precedes it. + pstateSourcePos = P.SourcePos name (P.mkPos startLine) . P.mkPos $ startColumn + length openingFence, + pstateTabWidth = P.defaultTabWidth, + -- Ensure we print the fence as part of the line if there’s a parse error in the info string. + pstateLinePrefix = openingFence + }, + stateParseErrors = [] + } diff --git a/unison-cli/src/Unison/Codebase/Transcript/Runner.hs b/unison-cli/src/Unison/Codebase/Transcript/Runner.hs new file mode 100644 index 0000000000..97082cfab5 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Transcript/Runner.hs @@ -0,0 +1,550 @@ +{-# LANGUAGE DeriveAnyClass #-} + +-- | Execute transcripts. +module Unison.Codebase.Transcript.Runner + ( Error (..), + Runner, + withRunner, + ) +where + +import CMark qualified +import Control.Lens (use, (?~)) +import Crypto.Random qualified as Random +import Data.Aeson qualified as Aeson +import Data.Aeson.Encode.Pretty qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as BL +import Data.IORef +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map qualified as Map +import Data.Sequence qualified as Seq +import Data.Text qualified as Text +import Data.These (These (..)) +import Data.UUID.V4 qualified as UUID +import Network.HTTP.Client qualified as HTTP +import System.Environment (lookupEnv) +import System.IO qualified as IO +import Text.Megaparsec qualified as P +import U.Codebase.Sqlite.DbId qualified as Db +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.Queries qualified as Q +import Unison.Auth.CredentialManager qualified as AuthN +import Unison.Auth.HTTPClient qualified as AuthN +import Unison.Auth.Tokens qualified as AuthN +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Codebase (Codebase) +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Editor.HandleInput qualified as HandleInput +import Unison.Codebase.Editor.Input (Event (UnisonFileChanged), Input (..)) +import Unison.Codebase.Editor.Output qualified as Output +import Unison.Codebase.Editor.UCMVersion (UCMVersion) +import Unison.Codebase.ProjectPath qualified as PP +import Unison.Codebase.Runtime qualified as Runtime +import Unison.Codebase.Transcript +import Unison.Codebase.Transcript.Parser qualified as Transcript +import Unison.Codebase.Verbosity (Verbosity, isSilent) +import Unison.Codebase.Verbosity qualified as Verbosity +import Unison.CommandLine +import Unison.CommandLine.InputPattern (InputPattern (aliases, patternName)) +import Unison.CommandLine.InputPatterns (validInputs) +import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser) +import Unison.CommandLine.Welcome (asciiartUnison) +import Unison.Parser.Ann (Ann) +import Unison.Prelude +import Unison.PrettyTerminal +import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (ProjectAndBranchNames'Unambiguous)) +import Unison.Runtime.Interface qualified as RTI +import Unison.Server.Backend qualified as Backend +import Unison.Server.CodebaseServer qualified as Server +import Unison.Sqlite qualified as Sqlite +import Unison.Symbol (Symbol) +import Unison.Syntax.Parser qualified as Parser +import Unison.Util.Pretty qualified as Pretty +import Unison.Util.TQueue qualified as Q +import UnliftIO qualified +import UnliftIO.STM +import Prelude hiding (readFile, writeFile) + +-- | Render transcript errors at a width of 65 chars. +terminalWidth :: Pretty.Width +terminalWidth = 65 + +-- | If provided, this access token will be used on all +-- requests which use the Authenticated HTTP Client; i.e. all codeserver interactions. +-- +-- It's useful in scripted contexts or when running transcripts against a codeserver. +accessTokenEnvVarKey :: String +accessTokenEnvVarKey = "UNISON_SHARE_ACCESS_TOKEN" + +type Runner = + String -> + Text -> + (FilePath, Codebase IO Symbol Ann) -> + IO (Either Error (Seq Stanza)) + +withRunner :: + forall m r. + (UnliftIO.MonadUnliftIO m) => + -- | Whether to treat this transcript run as a transcript test, which will try to make output deterministic + Bool -> + Verbosity -> + UCMVersion -> + FilePath -> + (Runner -> m r) -> + m r +withRunner isTest verbosity ucmVersion nrtp action = + withRuntimes nrtp \runtime sbRuntime nRuntime -> + action \transcriptName transcriptSrc (codebaseDir, codebase) -> + Server.startServer + Backend.BackendEnv {Backend.useNamesIndex = False} + Server.defaultCodebaseServerOpts + runtime + codebase + \baseUrl -> + either + (pure . Left . ParseError) + (run isTest verbosity codebaseDir codebase runtime sbRuntime nRuntime ucmVersion $ tShow baseUrl) + $ Transcript.stanzas transcriptName transcriptSrc + where + withRuntimes :: + FilePath -> (Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> m a) -> m a + withRuntimes nrtp action = + RTI.withRuntime False RTI.Persistent ucmVersion \runtime -> + RTI.withRuntime True RTI.Persistent ucmVersion \sbRuntime -> + action runtime sbRuntime =<< liftIO (RTI.startNativeRuntime ucmVersion nrtp) + +isGeneratedBlock :: ProcessedBlock -> Bool +isGeneratedBlock = \case + Ucm InfoTags {generated} _ -> generated + Unison InfoTags {generated} _ -> generated + API InfoTags {generated} _ -> generated + +run :: + -- | Whether to treat this transcript run as a transcript test, which will try to make output deterministic + Bool -> + Verbosity -> + FilePath -> + Codebase IO Symbol Ann -> + Runtime.Runtime Symbol -> + Runtime.Runtime Symbol -> + Runtime.Runtime Symbol -> + UCMVersion -> + Text -> + [Stanza] -> + IO (Either Error (Seq Stanza)) +run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL stanzas = UnliftIO.try do + httpManager <- HTTP.newManager HTTP.defaultManagerSettings + (initialPP, emptyCausalHashId) <- + Codebase.runTransaction codebase . liftA2 (,) Codebase.expectCurrentProjectPath $ snd <$> Codebase.emptyCausalHash + + unless (isSilent verbosity) . putPrettyLn $ + Pretty.lines + [ asciiartUnison, + "", + "Running the provided transcript file...", + "" + ] + mayShareAccessToken <- fmap Text.pack <$> lookupEnv accessTokenEnvVarKey + credMan <- AuthN.newCredentialManager + let tokenProvider :: AuthN.TokenProvider + tokenProvider = + maybe + (AuthN.newTokenProvider credMan) + (\accessToken _codeserverID -> pure $ Right accessToken) + mayShareAccessToken + -- Queue of Stanzas and Just index, or Nothing if the stanza was programmatically generated + -- e.g. a unison-file update by a command like 'edit' + inputQueue <- + Q.prepopulatedIO . Seq.fromList $ + filter (either (const True) (not . isGeneratedBlock)) stanzas `zip` (Just <$> [1 :: Int ..]) + -- Queue of UCM commands to run. + -- Nothing indicates the end of a ucm block. + cmdQueue <- Q.newIO @(Maybe UcmLine) + -- Queue of scratch file updates triggered by UCM itself, e.g. via `edit`, `update`, etc. + ucmScratchFileUpdatesQueue <- Q.newIO @(ScratchFileName, Text) + ucmOutput <- newIORef mempty + unisonFiles <- newIORef Map.empty + out <- newIORef mempty + currentTags <- newIORef Nothing + isHidden <- newIORef Shown + allowErrors <- newIORef False + expectFailure <- newIORef False + hasErrors <- newIORef False + mBlock <- newIORef Nothing + let patternMap = Map.fromList $ (\p -> (patternName p, p) : ((,p) <$> aliases p)) =<< validInputs + let output' :: Bool -> Stanza -> IO () + output' inputEcho msg = do + hide <- hideOutput inputEcho + unless hide $ modifyIORef' out (<> pure msg) + + hideOutput' :: Bool -> Hidden -> Bool + hideOutput' inputEcho = \case + Shown -> False + HideOutput -> not inputEcho + HideAll -> True + + hideOutput :: Bool -> IO Bool + hideOutput inputEcho = hideOutput' inputEcho <$> readIORef isHidden + + output, outputEcho :: Stanza -> IO () + output = output' False + outputEcho = output' True + + outputUcmLine :: UcmLine -> IO () + outputUcmLine line = do + prev <- readIORef ucmOutput + modifyIORef' ucmOutput (<> ((if not (null prev) then pure (UcmOutputLine "\n") else mempty) <> pure line)) + + outputUcmResult :: Pretty.Pretty Pretty.ColorText -> IO () + outputUcmResult line = do + hide <- hideOutput False + unless hide . outputUcmLine . UcmOutputLine . Text.pack $ + -- We shorten the terminal width, because "Transcript" manages a 2-space indent for output lines. + Pretty.toPlain (terminalWidth - 2) line + + maybeDieWithMsg :: Pretty.Pretty Pretty.ColorText -> IO () + maybeDieWithMsg msg = do + liftIO $ writeIORef hasErrors True + liftIO (liftA2 (,) (readIORef allowErrors) (readIORef expectFailure)) >>= \case + (False, False) -> liftIO . dieWithMsg $ Pretty.toPlain terminalWidth msg + (True, True) -> do + appendFailingStanza + fixedBug out $ + Text.unlines + [ "The stanza above marked with `:error :bug` is now failing with", + "", + "```", + Text.pack $ Pretty.toPlain terminalWidth msg, + "```", + "", + "so you can remove `:bug` and close any appropriate Github issues. If the error message is different \ + \from the expected error message, open a new issue and reference it in this transcript." + ] + (_, _) -> pure () + + apiRequest :: APIRequest -> IO [APIRequest] + apiRequest req = do + hide <- hideOutput False + case req of + -- We just discard this, because the runner will produce new output lines. + APIResponseLine {} -> pure [] + APIComment {} -> pure $ pure req + GetRequest path -> + either + (([] <$) . maybeDieWithMsg . Pretty.string . show) + ( either + ( ([] <$) + . maybeDieWithMsg + . (("Error decoding response from " <> Pretty.text path <> ": ") <>) + . Pretty.string + ) + ( \(v :: Aeson.Value) -> + pure $ + if hide + then [req] + else + [ req, + APIResponseLine . Text.pack . BL.unpack $ + Aeson.encodePretty' (Aeson.defConfig {Aeson.confCompare = compare}) v + ] + ) + . Aeson.eitherDecode + . HTTP.responseBody + <=< flip HTTP.httpLbs httpManager + ) + . HTTP.parseRequest + . Text.unpack + $ baseURL <> path + + endUcmBlock = do + liftIO $ do + tags <- readIORef currentTags + ucmOut <- readIORef ucmOutput + unless (null ucmOut && tags == Nothing) . outputEcho . pure $ + Ucm (fromMaybe defaultInfoTags' {generated = True} tags) ucmOut + writeIORef ucmOutput [] + dieUnexpectedSuccess + atomically $ void $ do + scratchFileUpdates <- Q.flush ucmScratchFileUpdatesQueue + -- Push them onto the front stanza queue in the correct order. + for (reverse scratchFileUpdates) \(fp, contents) -> + -- Output blocks for any scratch file updates the ucm block triggered. + Q.undequeue inputQueue (pure $ Unison (defaultInfoTags $ pure fp) {generated = True} contents, Nothing) + Cli.returnEarlyWithoutOutput + + processUcmLine p = + case p of + -- We just discard this, because the runner will produce new output lines. + UcmOutputLine {} -> Cli.returnEarlyWithoutOutput + UcmComment {} -> do + liftIO $ outputUcmLine p + Cli.returnEarlyWithoutOutput + UcmCommand context lineTxt -> do + curPath <- Cli.getCurrentProjectPath + -- We're either going to run the command now (because we're in the right context), else we'll switch to + -- the right context first, then run the command next. + maybeSwitchCommand <- case context of + UcmContextProject (ProjectAndBranch projectName branchName) -> Cli.runTransaction do + Project {projectId, name = projectName} <- + Q.loadProjectByName projectName + >>= \case + Nothing -> do + projectId <- Sqlite.unsafeIO (Db.ProjectId <$> UUID.nextRandom) + Q.insertProject projectId projectName + pure $ Project {projectId, name = projectName} + Just project -> pure project + projectBranch <- + Q.loadProjectBranchByName projectId branchName >>= \case + Nothing -> do + branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom) + let projectBranch = + ProjectBranch {projectId, parentBranchId = Nothing, branchId, name = branchName} + Q.insertProjectBranch "Branch Created" emptyCausalHashId projectBranch + pure projectBranch + Just projBranch -> pure projBranch + let projectAndBranchIds = ProjectAndBranch projectBranch.projectId projectBranch.branchId + pure + if (PP.toProjectAndBranch . PP.toIds $ curPath) == projectAndBranchIds + then Nothing + else Just (ProjectSwitchI (ProjectAndBranchNames'Unambiguous (These projectName branchName))) + case maybeSwitchCommand of + Just switchCommand -> do + atomically . Q.undequeue cmdQueue $ Just p + pure $ Right switchCommand + Nothing -> do + case words . Text.unpack $ lineTxt of + [] -> Cli.returnEarlyWithoutOutput + args -> do + liftIO $ outputUcmLine p + numberedArgs <- use #numberedArgs + PP.ProjectAndBranch projId branchId <- + PP.toProjectAndBranch . NonEmpty.head <$> use #projectPathStack + let getProjectRoot = liftIO $ Codebase.expectProjectBranchRoot codebase projId branchId + liftIO (parseInput codebase curPath getProjectRoot numberedArgs patternMap args) + >>= either + -- invalid command is treated as a failure + ( \msg -> do + liftIO $ outputUcmResult msg + liftIO $ maybeDieWithMsg msg + Cli.returnEarlyWithoutOutput + ) + -- No input received from this line, try again. + (maybe Cli.returnEarlyWithoutOutput $ pure . Right . snd) + + startProcessedBlock block = case block of + Unison infoTags txt -> do + liftIO do + writeIORef isHidden $ hidden infoTags + outputEcho $ pure block + writeIORef allowErrors $ expectingError infoTags + writeIORef expectFailure $ hasBug infoTags + -- Open a ucm block which will contain the output from UCM after processing the `UnisonFileChanged` event. + -- Close the ucm block after processing the UnisonFileChanged event. + atomically . Q.enqueue cmdQueue $ Nothing + let sourceName = fromMaybe "scratch.u" $ additionalTags infoTags + liftIO $ updateVirtualFile sourceName txt + pure . Left $ UnisonFileChanged sourceName txt + API infoTags apiRequests -> do + liftIO do + writeIORef isHidden $ hidden infoTags + writeIORef allowErrors $ expectingError infoTags + writeIORef expectFailure $ hasBug infoTags + outputEcho . pure . API infoTags . fold =<< traverse apiRequest apiRequests + Cli.returnEarlyWithoutOutput + Ucm infoTags cmds -> do + liftIO do + writeIORef currentTags $ pure infoTags + writeIORef isHidden $ hidden infoTags + writeIORef allowErrors $ expectingError infoTags + writeIORef expectFailure $ hasBug infoTags + writeIORef hasErrors False + traverse_ (atomically . Q.enqueue cmdQueue . Just) cmds + atomically . Q.enqueue cmdQueue $ Nothing + Cli.returnEarlyWithoutOutput + + showStatus alwaysShow indicator msg = unless (not alwaysShow && Verbosity.isSilent verbosity) do + clearCurrentLine + putStr $ "\r" <> indicator <> " " <> msg + IO.hFlush IO.stdout + + finishTranscript = do + showStatus True "✔️" "Completed transcript.\n" + pure $ Right QuitI + + processStanza stanza midx = do + liftIO . showStatus False "⚙️" $ + maybe + "Processing UCM-generated stanza." + (\idx -> "Processing stanza " <> show idx <> " of " <> show (length stanzas) <> ".") + midx + either + (bypassStanza . Left) + ( \block -> + if isGeneratedBlock block + then bypassStanza $ pure block + else do + liftIO . writeIORef mBlock $ pure block + startProcessedBlock block + ) + stanza + + bypassStanza stanza = do + liftIO $ output stanza + Cli.returnEarlyWithoutOutput + + whatsNext = do + liftIO dieUnexpectedSuccess + liftIO $ writeIORef currentTags Nothing + liftIO $ writeIORef isHidden Shown + liftIO $ writeIORef allowErrors False + liftIO $ writeIORef expectFailure False + maybe (liftIO finishTranscript) (uncurry processStanza) =<< atomically (Q.tryDequeue inputQueue) + + awaitInput :: Cli (Either Event Input) + awaitInput = maybe whatsNext (maybe endUcmBlock processUcmLine) =<< atomically (Q.tryDequeue cmdQueue) + + loadPreviousUnisonBlock name = + maybe + -- This lets transcripts use the `load` command, as in: + -- + -- .> load someFile.u + (fmap Cli.LoadSuccess (readUtf8 $ Text.unpack name) <|> pure Cli.InvalidSourceNameError) + (pure . Cli.LoadSuccess) + . Map.lookup name + =<< readIORef unisonFiles + + writeSource :: ScratchFileName -> Text -> Bool -> IO () + writeSource fp contents _addFold = do + shouldShowSourceChanges <- (== Shown) <$> readIORef isHidden + when shouldShowSourceChanges . atomically $ Q.enqueue ucmScratchFileUpdatesQueue (fp, contents) + updateVirtualFile fp contents + + updateVirtualFile :: ScratchFileName -> Text -> IO () + updateVirtualFile fp = modifyIORef' unisonFiles . Map.insert fp + + print :: Output.Output -> IO () + print o = do + msg <- notifyUser dir o + outputUcmResult msg + when (Output.isFailure o) $ maybeDieWithMsg msg + + printNumbered :: Output.NumberedOutput -> IO Output.NumberedArgs + printNumbered o = do + let (msg, numberedArgs) = notifyNumbered o + outputUcmResult msg + when (Output.isNumberedFailure o) $ maybeDieWithMsg msg + pure numberedArgs + + -- Looks at the current stanza and decides if it is contained in the + -- output so far. Appends it if not. + appendFailingStanza :: IO () + appendFailingStanza = do + blockOpt <- readIORef mBlock + currentOut <- readIORef out + maybe + (pure ()) + (\block -> unless (elem (pure block) currentOut) $ modifyIORef' out (<> pure (pure block))) + blockOpt + + dieWithMsg :: forall a. String -> IO a + dieWithMsg msg = do + appendFailingStanza + transcriptFailure out "The transcript failed due to an error in the stanza above. The error is:" . pure $ + Text.pack msg + + dieUnexpectedSuccess :: IO () + dieUnexpectedSuccess = do + errOk <- readIORef allowErrors + expectBug <- readIORef expectFailure + hasErr <- readIORef hasErrors + case (errOk, expectBug, hasErr) of + (True, False, False) -> do + appendFailingStanza + transcriptFailure + out + "The transcript was expecting an error in the stanza above, but did not encounter one." + Nothing + (False, True, False) -> do + fixedBug + out + "The stanza above with `:bug` is now passing! You can remove `:bug` and close any appropriate Github \ + \issues." + (_, _, _) -> pure () + + authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion + + seedRef <- newIORef (0 :: Int) + + let env = + Cli.Env + { authHTTPClient = authenticatedHTTPClient, + codebase, + credentialManager = credMan, + generateUniqueName = do + i <- atomicModifyIORef' seedRef \i -> let !i' = i + 1 in (i', i) + pure (Parser.uniqueBase32Namegen (Random.drgNewSeed (Random.seedFromInteger (fromIntegral i)))), + loadSource = loadPreviousUnisonBlock, + writeSource, + notify = print, + notifyNumbered = printNumbered, + runtime, + sandboxedRuntime = sbRuntime, + nativeRuntime = nRuntime, + serverBaseUrl = Nothing, + ucmVersion, + isTranscriptTest = isTest + } + + let loop :: Cli.LoopState -> IO (Seq Stanza) + loop s0 = do + Cli.runCli env s0 awaitInput >>= \case + (Cli.Success input, s1) -> + let next s = loop $ either (const s) (\inp -> s & #lastInput ?~ inp) input + in Cli.runCli env s1 (HandleInput.loop input) >>= \case + (Cli.Success (), s2) -> next s2 + (Cli.Continue, s2) -> next s2 + (Cli.HaltRepl, _) -> onHalt + (Cli.Continue, s1) -> loop s1 + (Cli.HaltRepl, _) -> onHalt + where + onHalt = readIORef out + + loop (Cli.loopState0 (PP.toIds initialPP)) + +transcriptFailure :: IORef (Seq Stanza) -> Text -> Maybe Text -> IO b +transcriptFailure out heading mbody = do + texts <- readIORef out + UnliftIO.throwIO . RunFailure $ + texts + <> Seq.fromList + ( Left + <$> [ CMark.Node Nothing CMark.PARAGRAPH [CMark.Node Nothing (CMark.TEXT "🛑") []], + CMark.Node Nothing CMark.PARAGRAPH [CMark.Node Nothing (CMark.TEXT heading) []] + ] + <> foldr ((:) . CMarkCodeBlock Nothing "") [] mbody + ) + +fixedBug :: IORef (Seq Stanza) -> Text -> IO b +fixedBug out body = do + texts <- readIORef out + -- `CMark.commonmarkToNode` returns a @DOCUMENT@, which won’t be rendered inside another document, so we strip the + -- outer `CMark.Node`. + let CMark.Node _ _DOCUMENT bodyNodes = CMark.commonmarkToNode [CMark.optNormalize] body + UnliftIO.throwIO . RunFailure $ + texts + <> Seq.fromList + ( Left + <$> [ CMark.Node Nothing CMark.PARAGRAPH [CMark.Node Nothing (CMark.TEXT "🎉") []], + CMark.Node Nothing (CMark.HEADING 2) [CMark.Node Nothing (CMark.TEXT "You fixed a bug!") []] + ] + <> bodyNodes + ) + +data Error + = ParseError (P.ParseErrorBundle Text Void) + | RunFailure (Seq Stanza) + deriving stock (Show) + deriving anyclass (Exception) diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs deleted file mode 100644 index b9e82f7ed5..0000000000 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ /dev/null @@ -1,742 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -{- Parse and execute markdown transcripts. --} -module Unison.Codebase.TranscriptParser - ( Stanza (..), - FenceType, - ExpectingError, - Hidden, - TranscriptError (..), - UcmLine (..), - withTranscriptRunner, - parse, - parseFile, - ) -where - -import Control.Lens (use, (?~)) -import Crypto.Random qualified as Random -import Data.Aeson qualified as Aeson -import Data.Aeson.Encode.Pretty qualified as Aeson -import Data.ByteString.Lazy.Char8 qualified as BL -import Data.Char qualified as Char -import Data.Configurator qualified as Configurator -import Data.Configurator.Types (Config) -import Data.IORef -import Data.List (isSubsequenceOf) -import Data.Map qualified as Map -import Data.Text qualified as Text -import Data.These (These (..)) -import Data.UUID.V4 qualified as UUID -import Ki qualified -import Network.HTTP.Client qualified as HTTP -import System.Directory (doesFileExist) -import System.Environment (lookupEnv) -import System.Exit (die) -import System.IO qualified as IO -import System.IO.Error (catchIOError) -import Text.Megaparsec qualified as P -import U.Codebase.Sqlite.DbId qualified as Db -import U.Codebase.Sqlite.Operations qualified as Operations -import U.Codebase.Sqlite.Project (Project (..)) -import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) -import U.Codebase.Sqlite.Queries qualified as Q -import Unison.Auth.CredentialManager qualified as AuthN -import Unison.Auth.HTTPClient qualified as AuthN -import Unison.Auth.Tokens qualified as AuthN -import Unison.Cli.Monad (Cli) -import Unison.Cli.Monad qualified as Cli -import Unison.Cli.MonadUtils qualified as Cli -import Unison.Cli.ProjectUtils qualified as ProjectUtils -import Unison.Codebase (Codebase) -import Unison.Codebase qualified as Codebase -import Unison.Codebase.Editor.HandleInput qualified as HandleInput -import Unison.Codebase.Editor.Input (Event (UnisonFileChanged), Input (..)) -import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Editor.UCMVersion (UCMVersion) -import Unison.Codebase.Path qualified as Path -import Unison.Codebase.Path.Parse qualified as Path -import Unison.Codebase.Runtime qualified as Runtime -import Unison.Codebase.Verbosity (Verbosity, isSilent) -import Unison.Codebase.Verbosity qualified as Verbosity -import Unison.CommandLine -import Unison.CommandLine.InputPattern (InputPattern (aliases, patternName)) -import Unison.CommandLine.InputPatterns (validInputs) -import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser) -import Unison.CommandLine.Welcome (asciiartUnison) -import Unison.Parser.Ann (Ann) -import Unison.Prelude -import Unison.PrettyTerminal -import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (ProjectAndBranchNames'Unambiguous), ProjectBranchName, ProjectName) -import Unison.Runtime.Interface qualified as RTI -import Unison.Server.Backend qualified as Backend -import Unison.Server.CodebaseServer qualified as Server -import Unison.Sqlite qualified as Sqlite -import Unison.Symbol (Symbol) -import Unison.Syntax.Parser qualified as Parser -import Unison.Util.Pretty qualified as Pretty -import Unison.Util.TQueue qualified as Q -import UnliftIO qualified -import UnliftIO.STM -import Prelude hiding (readFile, writeFile) - --- | Render transcript errors at a width of 65 chars. -terminalWidth :: Pretty.Width -terminalWidth = 65 - --- | If provided, this access token will be used on all --- requests which use the Authenticated HTTP Client; i.e. all codeserver interactions. --- --- It's useful in scripted contexts or when running transcripts against a codeserver. -accessTokenEnvVarKey :: String -accessTokenEnvVarKey = "UNISON_SHARE_ACCESS_TOKEN" - -type ExpectingError = Bool - -type ScratchFileName = Text - -type FenceType = Text - -data Hidden = Shown | HideOutput | HideAll - deriving (Eq, Show) - -data UcmLine - = UcmCommand UcmContext Text - | UcmComment Text -- Text does not include the '--' prefix. - --- | Where a command is run: either loose code (.foo.bar.baz>) or a project branch (myproject/mybranch>). -data UcmContext - = UcmContextLooseCode Path.Absolute - | UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName) - -data APIRequest - = GetRequest Text - | APIComment Text - -instance Show APIRequest where - show (GetRequest txt) = "GET " <> Text.unpack txt - show (APIComment txt) = "-- " <> Text.unpack txt - -data Stanza - = Ucm Hidden ExpectingError [UcmLine] - | Unison Hidden ExpectingError (Maybe ScratchFileName) Text - | API [APIRequest] - | UnprocessedFence FenceType Text - | Unfenced Text - -instance Show UcmLine where - show = \case - UcmCommand context txt -> showContext context <> "> " <> Text.unpack txt - UcmComment txt -> "--" ++ Text.unpack txt - where - showContext = \case - UcmContextLooseCode path -> show path - UcmContextProject projectAndBranch -> Text.unpack (into @Text projectAndBranch) - -instance Show Stanza where - show s = case s of - Ucm _ _ cmds -> - unlines - [ "```ucm", - foldl (\x y -> x ++ show y) "" cmds, - "```" - ] - Unison _hide _ fname txt -> - unlines - [ "```unison", - case fname of - Nothing -> Text.unpack txt <> "```\n" - Just fname -> - unlines - [ "---", - "title: " <> Text.unpack fname, - "---", - Text.unpack txt, - "```", - "" - ] - ] - API apiRequests -> - "```api\n" - <> ( apiRequests - & fmap show - & unlines - ) - <> "```\n" - UnprocessedFence typ txt -> - unlines - [ "```" <> Text.unpack typ, - Text.unpack txt, - "```", - "" - ] - Unfenced txt -> Text.unpack txt - -parseFile :: FilePath -> IO (Either TranscriptError [Stanza]) -parseFile filePath = do - exists <- doesFileExist filePath - if exists - then do - txt <- readUtf8 filePath - pure $ parse filePath txt - else pure . Left . TranscriptParseError . Text.pack $ filePath <> " does not exist" - -parse :: String -> Text -> Either TranscriptError [Stanza] -parse srcName txt = case P.parse (stanzas <* P.eof) srcName txt of - Right a -> Right a - Left e -> Left . TranscriptParseError . Text.pack . P.errorBundlePretty $ e - -type TranscriptRunner = - ( String -> - Text -> - (FilePath, Codebase IO Symbol Ann) -> - IO (Either TranscriptError Text) - ) - -withTranscriptRunner :: - forall m r. - (UnliftIO.MonadUnliftIO m) => - Verbosity -> - UCMVersion -> - FilePath -> - Maybe FilePath -> - (TranscriptRunner -> m r) -> - m r -withTranscriptRunner verbosity ucmVersion nrtp configFile action = do - withRuntimes nrtp \runtime sbRuntime nRuntime -> withConfig \config -> do - action \transcriptName transcriptSrc (codebaseDir, codebase) -> do - Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) Server.defaultCodebaseServerOpts runtime codebase \baseUrl -> do - let parsed = parse transcriptName transcriptSrc - result <- for parsed \stanzas -> do - liftIO $ run verbosity codebaseDir stanzas codebase runtime sbRuntime nRuntime config ucmVersion (tShow baseUrl) - pure $ join @(Either TranscriptError) result - where - withRuntimes :: - FilePath -> (Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> m a) -> m a - withRuntimes nrtp action = - RTI.withRuntime False RTI.Persistent ucmVersion \runtime -> do - RTI.withRuntime True RTI.Persistent ucmVersion \sbRuntime -> do - action runtime sbRuntime - =<< liftIO (RTI.startNativeRuntime ucmVersion nrtp) - withConfig :: forall a. ((Maybe Config -> m a) -> m a) - withConfig action = do - case configFile of - Nothing -> action Nothing - Just configFilePath -> do - let loadConfig = liftIO do - catchIOError - (watchConfig configFilePath) - \_ -> die "Your .unisonConfig could not be loaded. Check that it's correct!" - UnliftIO.bracket - loadConfig - (\(_config, cancelConfig) -> liftIO cancelConfig) - (\(config, _cancelConfig) -> action (Just config)) - -run :: - Verbosity -> - FilePath -> - [Stanza] -> - Codebase IO Symbol Ann -> - Runtime.Runtime Symbol -> - Runtime.Runtime Symbol -> - Runtime.Runtime Symbol -> - Maybe Config -> - UCMVersion -> - Text -> - IO (Either TranscriptError Text) -run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion baseURL = UnliftIO.try $ Ki.scoped \scope -> do - httpManager <- HTTP.newManager HTTP.defaultManagerSettings - let initialPath = Path.absoluteEmpty - unless (isSilent verbosity) . putPrettyLn $ - Pretty.lines - [ asciiartUnison, - "", - "Running the provided transcript file...", - "" - ] - initialRootCausalHash <- Codebase.runTransaction codebase Operations.expectRootCausalHash - rootVar <- newEmptyTMVarIO - void $ Ki.fork scope do - root <- Codebase.getRootBranch codebase - atomically $ putTMVar rootVar root - mayShareAccessToken <- fmap Text.pack <$> lookupEnv accessTokenEnvVarKey - credMan <- AuthN.newCredentialManager - let tokenProvider :: AuthN.TokenProvider - tokenProvider = - case mayShareAccessToken of - Nothing -> do - AuthN.newTokenProvider credMan - Just accessToken -> - \_codeserverID -> pure $ Right accessToken - seedRef <- newIORef (0 :: Int) - -- Queue of Stanzas and Just index, or Nothing if the stanza was programmatically generated - -- e.g. a unison-file update by a command like 'edit' - inputQueue <- Q.newIO @(Stanza, Maybe Int) - -- Queue of UCM commands to run. - -- Nothing indicates the end of a ucm block. - cmdQueue <- Q.newIO @(Maybe UcmLine) - -- Queue of scratch file updates triggered by UCM itself, e.g. via `edit`, `update`, etc. - ucmScratchFileUpdatesQueue <- Q.newIO @(ScratchFileName, Text) - unisonFiles <- newIORef Map.empty - out <- newIORef mempty - hidden <- newIORef Shown - allowErrors <- newIORef False - hasErrors <- newIORef False - mStanza <- newIORef Nothing - traverse_ (atomically . Q.enqueue inputQueue) (stanzas `zip` (Just <$> [1 :: Int ..])) - let patternMap = - Map.fromList $ - validInputs - >>= (\p -> (patternName p, p) : ((,p) <$> aliases p)) - let output' :: Bool -> String -> IO () - output' inputEcho msg = do - hide <- readIORef hidden - unless (hideOutput inputEcho hide) $ modifyIORef' out (\acc -> acc <> pure msg) - - hideOutput :: Bool -> Hidden -> Bool - hideOutput inputEcho = \case - Shown -> False - HideOutput -> True && (not inputEcho) - HideAll -> True - - output, outputEcho :: String -> IO () - output = output' False - outputEcho = output' True - - apiRequest :: APIRequest -> IO () - apiRequest req = do - output (show req <> "\n") - case req of - APIComment {} -> pure () - GetRequest path -> do - req <- case HTTP.parseRequest (Text.unpack $ baseURL <> path) of - Left err -> dieWithMsg (show err) - Right req -> pure req - respBytes <- HTTP.httpLbs req httpManager - case Aeson.eitherDecode (HTTP.responseBody respBytes) of - Right (v :: Aeson.Value) -> do - let prettyBytes = Aeson.encodePretty' (Aeson.defConfig {Aeson.confCompare = compare}) v - output . (<> "\n") . BL.unpack $ prettyBytes - Left err -> dieWithMsg ("Error decoding response from " <> Text.unpack path <> ": " <> err) - - awaitInput :: Cli (Either Event Input) - awaitInput = do - cmd <- atomically (Q.tryDequeue cmdQueue) - case cmd of - -- end of ucm block - Just Nothing -> do - liftIO (output "\n```\n") - liftIO dieUnexpectedSuccess - atomically $ void $ do - scratchFileUpdates <- Q.flush ucmScratchFileUpdatesQueue - -- Push them onto the front stanza queue in the correct order. - for (reverse scratchFileUpdates) \(fp, contents) -> do - let fenceDescription = "unison:added-by-ucm " <> fp - -- Output blocks for any scratch file updates the ucm block triggered. - Q.undequeue inputQueue (UnprocessedFence fenceDescription contents, Nothing) - awaitInput - -- ucm command to run - Just (Just ucmLine) -> do - case ucmLine of - p@(UcmComment {}) -> do - liftIO (output ("\n" <> show p)) - awaitInput - p@(UcmCommand context lineTxt) -> do - curPath <- Cli.getCurrentPath - -- We're either going to run the command now (because we're in the right context), else we'll switch to - -- the right context first, then run the command next. - maybeSwitchCommand <- - case context of - UcmContextLooseCode path -> - if curPath == path - then pure Nothing - else pure $ Just (SwitchBranchI (Path.absoluteToPath' path)) - UcmContextProject (ProjectAndBranch projectName branchName) -> Cli.runTransaction do - Project {projectId, name = projectName} <- - Q.loadProjectByName projectName - >>= \case - Nothing -> do - projectId <- Sqlite.unsafeIO (Db.ProjectId <$> UUID.nextRandom) - Q.insertProject projectId projectName - pure $ Project {projectId, name = projectName} - Just project -> pure project - projectBranch <- - Q.loadProjectBranchByName projectId branchName >>= \case - Nothing -> do - branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom) - let projectBranch = ProjectBranch {projectId, parentBranchId = Nothing, branchId, name = branchName} - Q.insertProjectBranch projectBranch - pure projectBranch - Just projBranch -> pure projBranch - let projectAndBranchIds = ProjectAndBranch projectBranch.projectId projectBranch.branchId - pure - if curPath == ProjectUtils.projectBranchPath projectAndBranchIds - then Nothing - else Just (ProjectSwitchI (ProjectAndBranchNames'Unambiguous (These projectName branchName))) - case maybeSwitchCommand of - Just switchCommand -> do - atomically $ Q.undequeue cmdQueue (Just p) - pure (Right switchCommand) - Nothing -> do - case words . Text.unpack $ lineTxt of - [] -> awaitInput - args -> do - liftIO (output ("\n" <> show p <> "\n")) - numberedArgs <- use #numberedArgs - liftIO (parseInput codebase curPath numberedArgs patternMap args) >>= \case - -- invalid command is treated as a failure - Left msg -> do - liftIO $ writeIORef hasErrors True - liftIO (readIORef allowErrors) >>= \case - True -> do - liftIO (output . Pretty.toPlain terminalWidth $ ("\n" <> msg <> "\n")) - awaitInput - False -> do - liftIO (dieWithMsg $ Pretty.toPlain terminalWidth msg) - -- No input received from this line, try again. - Right Nothing -> awaitInput - Right (Just (_expandedArgs, input)) -> pure $ Right input - Nothing -> do - liftIO (dieUnexpectedSuccess) - liftIO (writeIORef hidden Shown) - liftIO (writeIORef allowErrors False) - maybeStanza <- atomically (Q.tryDequeue inputQueue) - _ <- liftIO (writeIORef mStanza maybeStanza) - case maybeStanza of - Nothing -> do - liftIO (putStrLn "") - pure $ Right QuitI - Just (s, idx) -> do - unless (Verbosity.isSilent verbosity) . liftIO $ do - putStr $ - "\r⚙️ Processing stanza " - ++ show idx - ++ " of " - ++ show (length stanzas) - ++ "." - IO.hFlush IO.stdout - case s of - Unfenced _ -> do - liftIO (output $ show s) - awaitInput - UnprocessedFence _ _ -> do - liftIO (output $ show s) - awaitInput - Unison hide errOk filename txt -> do - liftIO (writeIORef hidden hide) - liftIO (outputEcho $ show s) - liftIO (writeIORef allowErrors errOk) - -- Open a ucm block which will contain the output from UCM - -- after processing the UnisonFileChanged event. - liftIO (output "```ucm\n") - -- Close the ucm block after processing the UnisonFileChanged event. - atomically . Q.enqueue cmdQueue $ Nothing - let sourceName = fromMaybe "scratch.u" filename - liftIO $ updateVirtualFile sourceName txt - pure $ Left (UnisonFileChanged sourceName txt) - API apiRequests -> do - liftIO (output "```api\n") - liftIO (for_ apiRequests apiRequest) - liftIO (output "```") - awaitInput - Ucm hide errOk cmds -> do - liftIO (writeIORef hidden hide) - liftIO (writeIORef allowErrors errOk) - liftIO (writeIORef hasErrors False) - liftIO (output "```ucm") - traverse_ (atomically . Q.enqueue cmdQueue . Just) cmds - atomically . Q.enqueue cmdQueue $ Nothing - awaitInput - - loadPreviousUnisonBlock name = do - ufs <- readIORef unisonFiles - case Map.lookup name ufs of - Just uf -> - return (Cli.LoadSuccess uf) - Nothing -> - -- This lets transcripts use the `load` command, as in: - -- - -- .> load someFile.u - -- - -- Important for Unison syntax that can't be embedded in - -- transcripts (like docs, which use ``` in their syntax). - let f = Cli.LoadSuccess <$> readUtf8 (Text.unpack name) - in f <|> pure Cli.InvalidSourceNameError - - writeSourceFile :: ScratchFileName -> Text -> IO () - writeSourceFile fp contents = do - shouldShowSourceChanges <- (== Shown) <$> readIORef hidden - when shouldShowSourceChanges $ do - atomically (Q.enqueue ucmScratchFileUpdatesQueue (fp, contents)) - updateVirtualFile fp contents - - updateVirtualFile :: ScratchFileName -> Text -> IO () - updateVirtualFile fp contents = do - liftIO (modifyIORef' unisonFiles (Map.insert fp contents)) - - print :: Output.Output -> IO () - print o = do - msg <- notifyUser dir o - errOk <- readIORef allowErrors - let rendered = Pretty.toPlain terminalWidth (Pretty.border 2 msg) - output rendered - when (Output.isFailure o) $ - if errOk - then writeIORef hasErrors True - else dieWithMsg rendered - - printNumbered :: Output.NumberedOutput -> IO Output.NumberedArgs - printNumbered o = do - let (msg, numberedArgs) = notifyNumbered o - errOk <- readIORef allowErrors - let rendered = Pretty.toPlain terminalWidth (Pretty.border 2 msg) - output rendered - when (Output.isNumberedFailure o) $ - if errOk - then writeIORef hasErrors True - else dieWithMsg rendered - pure numberedArgs - - -- Looks at the current stanza and decides if it is contained in the - -- output so far. Appends it if not. - appendFailingStanza :: IO () - appendFailingStanza = do - stanzaOpt <- readIORef mStanza - currentOut <- readIORef out - let stnz = maybe "" show (fmap fst stanzaOpt :: Maybe Stanza) - unless (stnz `isSubsequenceOf` concat currentOut) $ - modifyIORef' out (\acc -> acc <> pure stnz) - - -- output ``` and new lines then call transcriptFailure - dieWithMsg :: forall a. String -> IO a - dieWithMsg msg = do - output "\n```\n\n" - appendFailingStanza - transcriptFailure out $ - Text.unlines - [ "\128721", - "", - "The transcript failed due to an error in the stanza above. The error is:", - "", - Text.pack msg - ] - - dieUnexpectedSuccess :: IO () - dieUnexpectedSuccess = do - errOk <- readIORef allowErrors - hasErr <- readIORef hasErrors - when (errOk && not hasErr) $ do - output "\n```\n\n" - appendFailingStanza - transcriptFailure out $ - Text.unlines - [ "\128721", - "", - "The transcript was expecting an error in the stanza above, but did not encounter one." - ] - - authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion - - let env = - Cli.Env - { authHTTPClient = authenticatedHTTPClient, - codebase, - config = fromMaybe Configurator.empty config, - credentialManager = credMan, - generateUniqueName = do - i <- atomicModifyIORef' seedRef \i -> let !i' = i + 1 in (i', i) - pure (Parser.uniqueBase32Namegen (Random.drgNewSeed (Random.seedFromInteger (fromIntegral i)))), - loadSource = loadPreviousUnisonBlock, - writeSource = writeSourceFile, - notify = print, - notifyNumbered = printNumbered, - runtime, - sandboxedRuntime = sbRuntime, - nativeRuntime = nRuntime, - serverBaseUrl = Nothing, - ucmVersion - } - - let loop :: Cli.LoopState -> IO Text - loop s0 = do - Cli.runCli env s0 awaitInput >>= \case - (Cli.Success input, s1) -> do - let next s = - loop case input of - Left _ -> s - Right inp -> s & #lastInput ?~ inp - Cli.runCli env s1 (HandleInput.loop input) >>= \case - (Cli.Success (), s2) -> next s2 - (Cli.Continue, s2) -> next s2 - (Cli.HaltRepl, _) -> onHalt - (Cli.Continue, s1) -> loop s1 - (Cli.HaltRepl, _) -> onHalt - where - onHalt = do - texts <- readIORef out - pure $ Text.concat (Text.pack <$> toList (texts :: Seq String)) - - loop (Cli.loopState0 initialRootCausalHash rootVar initialPath) - -transcriptFailure :: IORef (Seq String) -> Text -> IO b -transcriptFailure out msg = do - texts <- readIORef out - UnliftIO.throwIO - . TranscriptRunFailure - $ Text.concat (Text.pack <$> toList texts) - <> "\n\n" - <> msg - -type P = P.Parsec Void Text - -stanzas :: P [Stanza] -stanzas = P.many (fenced <|> unfenced) - -ucmLine :: P UcmLine -ucmLine = ucmCommand <|> ucmComment - where - ucmCommand :: P UcmLine - ucmCommand = do - context <- - P.try do - contextString <- P.takeWhile1P Nothing (/= '>') - context <- - case (tryFrom @Text contextString, Path.parsePath' (Text.unpack contextString)) of - (Right (These project branch), _) -> pure (UcmContextProject (ProjectAndBranch project branch)) - (Left _, Right (Path.unPath' -> Left abs)) -> pure (UcmContextLooseCode abs) - _ -> fail "expected project/branch or absolute path" - void $ lineToken $ word ">" - pure context - line <- P.takeWhileP Nothing (/= '\n') <* spaces - pure $ UcmCommand context line - - ucmComment :: P UcmLine - ucmComment = do - word "--" - line <- P.takeWhileP Nothing (/= '\n') <* spaces - pure $ UcmComment line - -apiRequest :: P APIRequest -apiRequest = do - apiComment <|> getRequest - where - getRequest = do - word "GET" - spaces - path <- P.takeWhile1P Nothing (/= '\n') - spaces - pure (GetRequest path) - apiComment = do - word "--" - comment <- P.takeWhileP Nothing (/= '\n') - spaces - pure (APIComment comment) - -fenced :: P Stanza -fenced = do - fence - fenceType <- lineToken (word "ucm" <|> word "unison" <|> word "api" <|> language) - stanza <- - case fenceType of - "ucm" -> do - hide <- hidden - err <- expectingError - _ <- spaces - cmds <- many ucmLine - pure $ Ucm hide err cmds - "unison" -> - do - -- todo: this has to be more interesting - -- ```unison:hide - -- ```unison - -- ```unison:hide:all scratch.u - hide <- lineToken hidden - err <- lineToken expectingError - fileName <- optional untilSpace1 - blob <- spaces *> untilFence - pure $ Unison hide err fileName blob - "api" -> do - _ <- spaces - apiRequests <- many apiRequest - pure $ API apiRequests - _ -> UnprocessedFence fenceType <$> untilFence - fence - pure stanza - --- Three backticks, consumes trailing spaces too --- ``` -fence :: P () -fence = P.try $ do void (word "```"); spaces - --- Parses up until next fence -unfenced :: P Stanza -unfenced = Unfenced <$> untilFence - -untilFence :: P Text -untilFence = do - _ <- P.lookAhead (P.takeP Nothing 1) - go mempty - where - go :: Seq Text -> P Text - go !acc = do - f <- P.lookAhead (P.optional fence) - case f of - Nothing -> do - oneOrTwoBackticks <- optional (word' "``" <|> word' "`") - let start = fromMaybe "" oneOrTwoBackticks - txt <- P.takeWhileP (Just "unfenced") (/= '`') - eof <- P.lookAhead (P.optional P.eof) - case eof of - Just _ -> pure $ fold (acc <> pure txt) - Nothing -> go (acc <> pure start <> pure txt) - Just _ -> pure $ fold acc - -word' :: Text -> P Text -word' txt = P.try $ do - chs <- P.takeP (Just $ show txt) (Text.length txt) - guard (chs == txt) - pure txt - -word :: Text -> P Text -word = word' - --- token :: P a -> P a --- token p = p <* spaces - -lineToken :: P a -> P a -lineToken p = p <* nonNewlineSpaces - -nonNewlineSpaces :: P () -nonNewlineSpaces = void $ P.takeWhileP Nothing (\ch -> ch == ' ' || ch == '\t') - -hidden :: P Hidden -hidden = (\case Just x -> x; Nothing -> Shown) <$> optional go - where - go = - ((\_ -> HideAll) <$> (word ":hide:all")) - <|> ((\_ -> HideOutput) <$> (word ":hide")) - -expectingError :: P ExpectingError -expectingError = isJust <$> optional (word ":error") - -untilSpace1 :: P Text -untilSpace1 = P.takeWhile1P Nothing (not . Char.isSpace) - -language :: P Text -language = P.takeWhileP Nothing (\ch -> Char.isDigit ch || Char.isLower ch || ch == '_') - -spaces :: P () -spaces = void $ P.takeWhileP (Just "spaces") Char.isSpace - --- single :: Char -> P Char --- single t = P.satisfy (== t) - -data TranscriptError - = TranscriptRunFailure Text - | TranscriptParseError Text - deriving stock (Show) - deriving anyclass (Exception) diff --git a/unison-cli/src/Unison/Codebase/Watch.hs b/unison-cli/src/Unison/Codebase/Watch.hs index 54838c7a86..c587d6ece5 100644 --- a/unison-cli/src/Unison/Codebase/Watch.hs +++ b/unison-cli/src/Unison/Codebase/Watch.hs @@ -44,8 +44,8 @@ watchDirectory' d = do mvar <- newEmptyMVar let handler :: Event -> IO () handler e = case e of - Added fp t False -> doIt fp t - Modified fp t False -> doIt fp t + Added fp t FSNotify.IsFile -> doIt fp t + Modified fp t FSNotify.IsFile -> doIt fp t _ -> pure () where doIt fp t = do @@ -56,7 +56,7 @@ watchDirectory' d = do cleanupRef <- newEmptyMVar -- we don't like FSNotify's debouncing (it seems to drop later events) -- so we will be doing our own instead - let config = FSNotify.defaultConfig {FSNotify.confDebounce = FSNotify.NoDebounce} + let config = FSNotify.defaultConfig cancel <- liftIO $ forkIO $ FSNotify.withManagerConf config $ \mgr -> do diff --git a/unison-cli/src/Unison/CommandLine.hs b/unison-cli/src/Unison/CommandLine.hs index 2c8be9bf43..99ac5799d9 100644 --- a/unison-cli/src/Unison/CommandLine.hs +++ b/unison-cli/src/Unison/CommandLine.hs @@ -3,36 +3,18 @@ {-# LANGUAGE ViewPatterns #-} module Unison.CommandLine - ( -- * Pretty Printing - allow, - backtick, - aside, - bigproblem, - note, - nothingTodo, - plural, - plural', - problem, - tip, - warn, - warnNote, - - -- * Other + ( allow, parseInput, prompt, - watchConfig, watchFileSystem, ) where import Control.Concurrent (forkIO, killThread) +import Control.Lens hiding (aside) import Control.Monad.Except import Control.Monad.Trans.Except -import Data.Configurator (autoConfig, autoReload) -import Data.Configurator qualified as Config -import Data.Configurator.Types (Config, Worth (..)) import Data.List (isPrefixOf, isSuffixOf) -import Data.ListLike (ListLike) import Data.Map qualified as Map import Data.Semialign qualified as Align import Data.Text qualified as Text @@ -42,20 +24,20 @@ import Data.Vector qualified as Vector import System.FilePath (takeFileName) import Text.Regex.TDFA ((=~)) import Unison.Codebase (Codebase) -import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.Input (Event (..), Input (..)) import Unison.Codebase.Editor.Output (NumberedArgs) -import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Watch qualified as Watch import Unison.CommandLine.FZFResolvers qualified as FZFResolvers import Unison.CommandLine.FuzzySelect qualified as Fuzzy +import Unison.CommandLine.Helpers (warn) import Unison.CommandLine.InputPattern (InputPattern (..)) import Unison.CommandLine.InputPattern qualified as InputPattern +import Unison.CommandLine.InputPatterns qualified as IPs import Unison.Parser.Ann (Ann) import Unison.Prelude -import Unison.Project.Util (ProjectContext, projectContextFromPath) import Unison.Symbol (Symbol) import Unison.Util.ColorText qualified as CT import Unison.Util.Monoid (foldMapM) @@ -64,23 +46,12 @@ import Unison.Util.TQueue qualified as Q import UnliftIO.STM import Prelude hiding (readFile, writeFile) -disableWatchConfig :: Bool -disableWatchConfig = False - allow :: FilePath -> Bool allow p = -- ignore Emacs .# prefixed files, see https://github.com/unisonweb/unison/issues/457 not (".#" `isPrefixOf` takeFileName p) && (isSuffixOf ".u" p || isSuffixOf ".uu" p) -watchConfig :: FilePath -> IO (Config, IO ()) -watchConfig path = - if disableWatchConfig - then pure (Config.empty, pure ()) - else do - (config, t) <- autoReload autoConfig [Optional path] - pure (config, killThread t) - watchFileSystem :: Q.TQueue Event -> FilePath -> IO (IO ()) watchFileSystem q dir = do (cancel, watcher) <- Watch.watchDirectory dir allow @@ -89,40 +60,11 @@ watchFileSystem q dir = do atomically . Q.enqueue q $ UnisonFileChanged (Text.pack filePath) text pure (cancel >> killThread t) -warnNote :: String -> String -warnNote s = "⚠️ " <> s - -backtick :: (IsString s) => P.Pretty s -> P.Pretty s -backtick s = P.group ("`" <> s <> "`") - -tip :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s -tip s = P.column2 [("Tip:", P.wrap s)] - -note :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s -note s = P.column2 [("Note:", P.wrap s)] - -aside :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s -> P.Pretty s -aside a b = P.column2 [(a <> ":", b)] - -warn :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s -warn = emojiNote "⚠️" - -problem :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s -problem = emojiNote "❗️" - -bigproblem :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s -bigproblem = emojiNote "‼️" - -emojiNote :: (ListLike s Char, IsString s) => String -> P.Pretty s -> P.Pretty s -emojiNote lead s = P.group (fromString lead) <> "\n" <> P.wrap s - -nothingTodo :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s -nothingTodo = emojiNote "😶" - parseInput :: Codebase IO Symbol Ann -> - -- | Current path from root - Path.Absolute -> + -- | Current location + PP.ProjectPath -> + IO (Branch.Branch IO) -> -- | Numbered arguments NumberedArgs -> -- | Input Pattern Map @@ -132,10 +74,11 @@ parseInput :: -- Returns either an error message or the fully expanded arguments list and parsed input. -- If the output is `Nothing`, the user cancelled the input (e.g. ctrl-c) IO (Either (P.Pretty CT.ColorText) (Maybe (InputPattern.Arguments, Input))) -parseInput codebase currentPath numberedArgs patterns segments = runExceptT do +parseInput codebase projPath currentProjectRoot numberedArgs patterns segments = runExceptT do let getCurrentBranch0 :: IO (Branch0 IO) - getCurrentBranch0 = Branch.head <$> Codebase.getBranchAtPath codebase currentPath - let projCtx = projectContextFromPath currentPath + getCurrentBranch0 = do + projRoot <- currentProjectRoot + pure . Branch.head $ Branch.getAt' (projPath ^. PP.path_) projRoot case segments of [] -> throwE "" @@ -144,20 +87,40 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do let expandedNumbers :: InputPattern.Arguments expandedNumbers = foldMap (\arg -> maybe [Left arg] (fmap pure) $ expandNumber numberedArgs arg) args - lift (fzfResolve codebase projCtx getCurrentBranch0 pat expandedNumbers) >>= \case + lift (fzfResolve codebase projPath getCurrentBranch0 pat expandedNumbers) >>= \case Left (NoFZFResolverForArgumentType _argDesc) -> throwError help Left (NoFZFOptions argDesc) -> throwError (noCompletionsMessage argDesc) Left FZFCancelled -> pure Nothing Right resolvedArgs -> do - parsedInput <- except . parse $ resolvedArgs + parsedInput <- + except + . first + ( \msg -> + P.warnCallout $ + P.wrap "Sorry, I wasn’t sure how to process your request:" + <> P.newline + <> P.newline + <> P.indentN 2 msg + <> P.newline + <> P.newline + <> P.wrap + ( "You can run" + <> IPs.makeExample IPs.help [fromString command] + <> "for more information on using" + <> IPs.makeExampleEOS pat [] + ) + ) + $ parse resolvedArgs pure $ Just (Left command : resolvedArgs, parsedInput) Nothing -> throwE . warn . P.wrap - $ "I don't know how to " + $ "I don't know how to" <> P.group (fromString command <> ".") - <> "Type `help` or `?` to get help." + <> "Type" + <> IPs.makeExample' IPs.help + <> "or `?` to get help." where noCompletionsMessage argDesc = P.callout "⚠️" $ @@ -192,8 +155,8 @@ data FZFResolveFailure | NoFZFOptions Text {- argument description -} | FZFCancelled -fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments) -fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do +fzfResolve :: Codebase IO Symbol Ann -> PP.ProjectPath -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments) +fzfResolve codebase ppCtx getCurrentBranch pat args = runExceptT do -- We resolve args in two steps, first we check that all arguments that will require a fzf -- resolver have one, and only if so do we prompt the user to actually do a fuzzy search. -- Otherwise, we might ask the user to perform a search only to realize we don't have a resolver @@ -214,7 +177,7 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO InputPattern.Arguments fuzzyFillArg opt argDesc InputPattern.FZFResolver {getOptions} = do currentBranch <- Branch.withoutTransitiveLibs <$> liftIO getCurrentBranch - options <- liftIO $ getOptions codebase projCtx currentBranch + options <- liftIO $ getOptions codebase ppCtx currentBranch when (null options) $ throwError $ NoFZFOptions argDesc liftIO $ Text.putStrLn (FZFResolvers.fuzzySelectHeader argDesc) results <- @@ -235,15 +198,3 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do prompt :: String prompt = "> " - --- `plural [] "cat" "cats" = "cats"` --- `plural ["meow"] "cat" "cats" = "cat"` --- `plural ["meow", "meow"] "cat" "cats" = "cats"` -plural :: (Foldable f) => f a -> b -> b -> b -plural items one other = case toList items of - [_] -> one - _ -> other - -plural' :: (Integral a) => a -> b -> b -> b -plural' 1 one _other = one -plural' _ _one other = other diff --git a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs index a999edbbe0..cc49baa3ce 100644 --- a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs +++ b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs @@ -2,9 +2,9 @@ module Unison.CommandLine.BranchRelativePath ( BranchRelativePath (..), parseBranchRelativePath, branchRelativePathParser, - ResolvedBranchRelativePath (..), parseIncrementalBranchRelativePath, IncrementalBranchRelativePath (..), + toText, ) where @@ -14,10 +14,9 @@ import Data.These (These (..)) import Text.Builder qualified import Text.Megaparsec qualified as Megaparsec import Text.Megaparsec.Char qualified as Megaparsec -import U.Codebase.Sqlite.Project qualified as Sqlite -import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathG (..)) import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Project qualified as Project @@ -25,8 +24,11 @@ import Unison.Util.ColorText qualified as CT import Unison.Util.Pretty qualified as P data BranchRelativePath - = BranchRelative (These (Either ProjectBranchName (ProjectName, ProjectBranchName)) Path.Relative) - | LoosePath Path.Path' + = -- | A path rooted at some specified branch/project + BranchPathInCurrentProject ProjectBranchName Path.Absolute + | QualifiedBranchPath ProjectName ProjectBranchName Path.Absolute + | -- | A path which is relative to the user's current location. + UnqualifiedPath Path.Path' deriving stock (Eq, Show) -- | Strings without colons are parsed as loose code paths. A path with a colon may specify: @@ -37,72 +39,56 @@ data BranchRelativePath -- Specifying only a project is not allowed. -- -- >>> parseBranchRelativePath "foo" --- Right (LoosePath foo) +-- Right (UnqualifiedPath foo) -- >>> parseBranchRelativePath "foo/bar:" --- Right (BranchRelative (This (Right (UnsafeProjectName "foo",UnsafeProjectBranchName "bar")))) --- >>> parseBranchRelativePath "foo/bar:some.path" --- Right (BranchRelative (These (Right (UnsafeProjectName "foo",UnsafeProjectBranchName "bar")) some.path)) --- >>> parseBranchRelativePath "/bar:some.path" --- Right (BranchRelative (These (Left (UnsafeProjectBranchName "bar")) some.path)) --- >>> parseBranchRelativePath ":some.path" --- Right (BranchRelative (That some.path)) +-- Right (QualifiedBranchPath (UnsafeProjectName "foo") (UnsafeProjectBranchName "bar") .) +-- >>> parseBranchRelativePath "foo/bar:.some.path" +-- Right (QualifiedBranchPath (UnsafeProjectName "foo") (UnsafeProjectBranchName "bar") .some.path) +-- >>> parseBranchRelativePath "/bar:.some.path" +-- Right (BranchPathInCurrentProject (UnsafeProjectBranchName "bar") .some.path) +-- >>> parseBranchRelativePath ":.some.path" +-- Right (UnqualifiedPath .some.path) +-- +-- >>> parseBranchRelativePath ".branch" +-- Right (UnqualifiedPath .branch) parseBranchRelativePath :: String -> Either (P.Pretty CT.ColorText) BranchRelativePath parseBranchRelativePath str = case Megaparsec.parse branchRelativePathParser "" (Text.pack str) of Left e -> Left (P.string (Megaparsec.errorBundlePretty e)) Right x -> Right x +-- | +-- >>> from @BranchRelativePath @Text (BranchPathInCurrentProject "foo" (Path.absoluteEmpty "bar")) instance From BranchRelativePath Text where from = \case - BranchRelative brArg -> case brArg of - This eitherProj -> - Text.Builder.run - ( Text.Builder.text (eitherProjToText eitherProj) - <> Text.Builder.char ':' - ) - That path -> - Text.Builder.run - ( Text.Builder.char ':' - <> Text.Builder.text (Path.convert path) - ) - These eitherProj path -> - Text.Builder.run - ( Text.Builder.text (eitherProjToText eitherProj) - <> Text.Builder.char ':' - <> Text.Builder.text (Path.convert path) - ) - LoosePath path -> Path.toText' path - where - eitherProjToText = \case - Left branchName -> from @(These ProjectName ProjectBranchName) @Text (That branchName) - Right (projName, branchName) -> into @Text (These projName branchName) - -data ResolvedBranchRelativePath - = ResolvedBranchRelative (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) (Maybe Path.Relative) - | ResolvedLoosePath Path.Absolute - -instance From ResolvedBranchRelativePath BranchRelativePath where - from = \case - ResolvedBranchRelative (ProjectAndBranch proj branch) mRel -> case mRel of - Nothing -> BranchRelative (This (Right (view #name proj, view #name branch))) - Just rel -> BranchRelative (These (Right (view #name proj, view #name branch)) rel) - ResolvedLoosePath p -> LoosePath (Path.absoluteToPath' p) - -instance From ResolvedBranchRelativePath Text where - from = from . into @BranchRelativePath + BranchPathInCurrentProject branch path -> + Text.Builder.run $ + Text.Builder.char '/' + <> Text.Builder.text (into @Text branch) + <> Text.Builder.char ':' + <> Text.Builder.text (Path.absToText path) + QualifiedBranchPath proj branch path -> + Text.Builder.run $ + Text.Builder.text (into @Text proj) + <> Text.Builder.char '/' + <> Text.Builder.text (into @Text branch) + <> Text.Builder.char ':' + <> Text.Builder.text (Path.absToText path) + UnqualifiedPath path -> + Path.toText' path data IncrementalBranchRelativePath - = -- | no dots, slashes, or colons - ProjectOrRelative Text Path.Path' - | -- | dots, no slashes or colons - LooseCode Path.Path' + = -- | no dots, slashes, or colons, so could be a project name or a single path segment + ProjectOrPath' Text Path.Path' + | -- | dots, no slashes or colons, must be a relative or absolute path + OnlyPath' Path.Path' | -- | valid project, no slash IncompleteProject ProjectName | -- | valid project/branch, slash, no colon IncompleteBranch (Maybe ProjectName) (Maybe ProjectBranchName) | -- | valid project/branch, with colon - IncompletePath (Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName) (Maybe Path.Relative) - | PathRelativeToCurrentBranch Path.Relative + IncompletePath (Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName) (Maybe Path.Absolute) + | PathRelativeToCurrentBranch Path.Absolute deriving stock (Show) -- | @@ -158,9 +144,9 @@ incrementalBranchRelativePathParser = pure (IncompleteProject projectName) in end <|> startingAtSlash (Just projectName) -- The string doesn't parse as a project name but does parse as a path - That (_, path) -> pure (LooseCode path) + That (_, path) -> pure (OnlyPath' path) -- The string parses both as a project name and a path - These _ (_, path) -> ProjectOrRelative <$> Megaparsec.takeRest <*> pure path + These _ (_, path) -> ProjectOrPath' <$> Megaparsec.takeRest <*> pure path startingAtBranch :: Maybe ProjectName -> Megaparsec.Parsec Void Text IncrementalBranchRelativePath startingAtBranch mproj = @@ -180,28 +166,30 @@ incrementalBranchRelativePathParser = Megaparsec.Parsec Void Text IncrementalBranchRelativePath startingAtColon projStuff = do _ <- Megaparsec.char ':' - p <- optionalEof relPath + p <- optionalEof brPath pure (IncompletePath projStuff p) pathRelativeToCurrentBranch :: Megaparsec.Parsec Void Text IncrementalBranchRelativePath pathRelativeToCurrentBranch = do _ <- Megaparsec.char ':' - p <- relPath + p <- brPath pure (PathRelativeToCurrentBranch p) optionalEof :: Megaparsec.Parsec Void Text a -> Megaparsec.Parsec Void Text (Maybe a) - optionalEof pa = Just <$> pa <|> Nothing <$ Megaparsec.eof + optionalEof pa = Just <$> pa <|> (Nothing <$ Megaparsec.eof) optionalBranch :: Megaparsec.Parsec Void Text (Maybe ProjectBranchName) optionalBranch = optionalEof branchNameParser branchNameParser = Project.projectBranchNameParser False - relPath = do + brPath :: Megaparsec.Parsec Void Text Path.Absolute + brPath = do offset <- Megaparsec.getOffset path' >>= \(Path.Path' inner) -> case inner of - Left _ -> failureAt offset "Expected a relative path but found an absolute path" - Right x -> pure x + Left _ -> failureAt offset "Branch qualified paths don't require a leading '.'" + -- Branch relative paths are written as relative paths, but are always absolute to the branch root + Right (Path.Relative x) -> pure $ Path.Absolute x path' = Megaparsec.try do offset <- Megaparsec.getOffset pathStr <- Megaparsec.takeRest @@ -234,16 +222,20 @@ incrementalBranchRelativePathParser = branchRelativePathParser :: Megaparsec.Parsec Void Text BranchRelativePath branchRelativePathParser = incrementalBranchRelativePathParser >>= \case - ProjectOrRelative _txt path -> pure (LoosePath path) - LooseCode path -> pure (LoosePath path) + ProjectOrPath' _txt path -> pure (UnqualifiedPath path) + OnlyPath' path -> pure (UnqualifiedPath path) IncompleteProject _proj -> fail "Branch relative paths require a branch. Expected `/` here." IncompleteBranch _mproj _mbranch -> fail "Branch relative paths require a colon. Expected `:` here." - PathRelativeToCurrentBranch p -> pure (BranchRelative (That p)) + PathRelativeToCurrentBranch p -> pure (UnqualifiedPath (Path.AbsolutePath' p)) IncompletePath projStuff mpath -> case projStuff of - Left (ProjectAndBranch projName branchName) -> case mpath of - Nothing -> pure (BranchRelative (This (Right (projName, branchName)))) - Just path -> pure (BranchRelative (These (Right (projName, branchName)) path)) - Right branch -> case mpath of - Nothing -> pure (BranchRelative (This (Left branch))) - Just path -> pure (BranchRelative (These (Left branch) path)) + Left (ProjectAndBranch projName branchName) -> + pure $ QualifiedBranchPath projName branchName (fromMaybe Path.absoluteEmpty mpath) + Right branch -> + pure $ BranchPathInCurrentProject branch (fromMaybe Path.absoluteEmpty mpath) + +toText :: BranchRelativePath -> Text +toText = \case + BranchPathInCurrentProject pbName path -> ProjectPath () pbName path & into @Text + QualifiedBranchPath projName pbName path -> ProjectPath projName pbName path & into @Text + UnqualifiedPath path' -> Path.toText' path' diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index 28822ea6f8..10a838373e 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -20,9 +20,8 @@ module Unison.CommandLine.Completion ) where -import Control.Lens (ifoldMap) +import Control.Lens import Control.Lens qualified as Lens -import Control.Lens.Cons (unsnoc) import Data.Aeson qualified as Aeson import Data.List (isPrefixOf) import Data.List qualified as List @@ -48,9 +47,10 @@ import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.CommandLine.InputPattern qualified as IP -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name qualified as Name import Unison.NameSegment.Internal (NameSegment (NameSegment)) import Unison.Prelude @@ -73,9 +73,9 @@ haskelineTabComplete :: Map String IP.InputPattern -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> Line.CompletionFunc m -haskelineTabComplete patterns codebase authedHTTPClient currentPath = Line.completeWordWithPrev Nothing " " $ \prev word -> +haskelineTabComplete patterns codebase authedHTTPClient ppCtx = Line.completeWordWithPrev Nothing " " $ \prev word -> -- User hasn't finished a command name, complete from command names if null prev then pure . exactComplete word $ Map.keys patterns @@ -84,7 +84,7 @@ haskelineTabComplete patterns codebase authedHTTPClient currentPath = Line.compl h : t -> fromMaybe (pure []) $ do p <- Map.lookup h patterns argType <- IP.argType p (length t) - pure $ IP.suggestions argType word codebase authedHTTPClient currentPath + pure $ IP.suggestions argType word codebase authedHTTPClient ppCtx _ -> pure [] -- | Things which we may want to complete for. @@ -101,7 +101,7 @@ noCompletions :: String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> m [System.Console.Haskeline.Completion.Completion] noCompletions _ _ _ _ = pure [] @@ -141,11 +141,11 @@ completeWithinNamespace :: NESet CompletionType -> -- | The portion of this are that the user has already typed. String -> - Path.Absolute -> + PP.ProjectPath -> Sqlite.Transaction [System.Console.Haskeline.Completion.Completion] -completeWithinNamespace compTypes query currentPath = do +completeWithinNamespace compTypes query ppCtx = do shortHashLen <- Codebase.hashLength - b <- Codebase.getShallowBranchAtPath (Path.unabsolute absQueryPath) Nothing + b <- Codebase.getShallowBranchAtProjectPath queryProjectPath currentBranchSuggestions <- do nib <- namesInBranch shortHashLen b nib @@ -168,8 +168,8 @@ completeWithinNamespace compTypes query currentPath = do queryPathPrefix :: Path.Path' querySuffix :: Text (queryPathPrefix, querySuffix) = parseLaxPath'Query (Text.pack query) - absQueryPath :: Path.Absolute - absQueryPath = Path.resolve currentPath queryPathPrefix + queryProjectPath :: PP.ProjectPath + queryProjectPath = ppCtx & PP.absPath_ %~ \curPath -> Path.resolve curPath queryPathPrefix getChildSuggestions :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [Completion] getChildSuggestions shortHashLen b | Text.null querySuffix = pure [] @@ -196,12 +196,6 @@ completeWithinNamespace compTypes query currentPath = do namesInBranch :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [(CompletionType, Bool, Text)] namesInBranch hashLen b = do nonEmptyChildren <- V2Branch.nonEmptyChildren b - let textifyHQ :: (NameSegment -> r -> HQ'.HashQualified NameSegment) -> Map NameSegment (Map r metadata) -> [(Bool, Text)] - textifyHQ f xs = - xs - & hashQualifyCompletions f - & fmap (HQ'.toTextWith NameSegment.toEscapedText) - & fmap (True,) pure $ concat [ (NamespaceCompletion,False,) <$> (fmap NameSegment.toEscapedText . Map.keys $ nonEmptyChildren), @@ -216,6 +210,12 @@ completeWithinNamespace compTypes query currentPath = do (fmap ((PatchCompletion,True,) . NameSegment.toEscapedText) . Map.keys $ V2Branch.patches b) ] + textifyHQ :: (NameSegment -> r -> HQ'.HashQualified NameSegment) -> Map NameSegment (Map r metadata) -> [(Bool, Text)] + textifyHQ f xs = + xs + & hashQualifyCompletions f + & fmap (HQ'.toTextWith NameSegment.toEscapedText) + & fmap (True,) -- Regrettably there'shqFromNamedV2Referencenot a great spot to combinators for V2 references and shorthashes right now. hqFromNamedV2Referent :: Int -> NameSegment -> Referent.Referent -> HQ'.HashQualified NameSegment hqFromNamedV2Referent hashLen n r = HQ'.HashQualified n (Cv.referent2toshorthash1 (Just hashLen) r) @@ -274,35 +274,35 @@ parseLaxPath'Query txt = -- | Completes a namespace argument by prefix-matching against the query. prefixCompleteNamespace :: String -> - Path.Absolute -> -- Current path + PP.ProjectPath -> Sqlite.Transaction [Line.Completion] prefixCompleteNamespace = completeWithinNamespace (NESet.singleton NamespaceCompletion) -- | Completes a term or type argument by prefix-matching against the query. prefixCompleteTermOrType :: String -> - Path.Absolute -> -- Current path + PP.ProjectPath -> Sqlite.Transaction [Line.Completion] prefixCompleteTermOrType = completeWithinNamespace (NESet.fromList (TermCompletion NE.:| [TypeCompletion])) -- | Completes a term argument by prefix-matching against the query. prefixCompleteTerm :: String -> - Path.Absolute -> -- Current path + PP.ProjectPath -> Sqlite.Transaction [Line.Completion] prefixCompleteTerm = completeWithinNamespace (NESet.singleton TermCompletion) -- | Completes a term or type argument by prefix-matching against the query. prefixCompleteType :: String -> - Path.Absolute -> -- Current path + PP.ProjectPath -> Sqlite.Transaction [Line.Completion] prefixCompleteType = completeWithinNamespace (NESet.singleton TypeCompletion) -- | Completes a patch argument by prefix-matching against the query. prefixCompletePatch :: String -> - Path.Absolute -> -- Current path + PP.ProjectPath -> Sqlite.Transaction [Line.Completion] prefixCompletePatch = completeWithinNamespace (NESet.singleton PatchCompletion) diff --git a/unison-cli/src/Unison/CommandLine/DisplayValues.hs b/unison-cli/src/Unison/CommandLine/DisplayValues.hs index b7b7d3bf65..6bfb43957d 100644 --- a/unison-cli/src/Unison/CommandLine/DisplayValues.hs +++ b/unison-cli/src/Unison/CommandLine/DisplayValues.hs @@ -178,12 +178,12 @@ displayPretty pped terms typeOf eval types tm = go tm DD.Doc2SpecialFormExample n (DD.Doc2Example vs body) -> P.backticked <$> displayTerm pped terms typeOf eval types ex where - ex = Term.lam' (ABT.annotation body) (drop (fromIntegral n) vs) body + ex = Term.lamWithoutBindingAnns (ABT.annotation body) (drop (fromIntegral n) vs) body DD.Doc2SpecialFormExampleBlock n (DD.Doc2Example vs body) -> -- todo: maybe do something with `vs` to indicate the variables are free P.indentN 4 <$> displayTerm' True pped terms typeOf eval types ex where - ex = Term.lam' (ABT.annotation body) (drop (fromIntegral n) vs) body + ex = Term.lamWithoutBindingAnns (ABT.annotation body) (drop (fromIntegral n) vs) body -- Link (Either Link.Type Doc2.Term) DD.Doc2SpecialFormLink e -> diff --git a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs index a6f23f2dbf..d72e6db9bd 100644 --- a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs +++ b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs @@ -37,13 +37,13 @@ import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Path (Path, Path' (..)) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Name qualified as Name import Unison.NameSegment qualified as NameSegment import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) import Unison.Position qualified as Position import Unison.Prelude -import Unison.Project.Util (ProjectContext (..)) import Unison.Symbol (Symbol) import Unison.Syntax.HashQualified qualified as HQ (toText) import Unison.Syntax.NameSegment qualified as NameSegment @@ -51,7 +51,7 @@ import Unison.Util.Monoid (foldMapM) import Unison.Util.Monoid qualified as Monoid import Unison.Util.Relation qualified as Relation -type OptionFetcher = Codebase IO Symbol Ann -> ProjectContext -> Branch0 IO -> IO [Text] +type OptionFetcher = Codebase IO Symbol Ann -> PP.ProjectPath -> Branch0 IO -> IO [Text] data FZFResolver = FZFResolver { getOptions :: OptionFetcher @@ -121,7 +121,7 @@ fuzzySelectFromList options = -- | Combine multiple option fetchers into one resolver. multiResolver :: [OptionFetcher] -> FZFResolver multiResolver resolvers = - let getOptions :: Codebase IO Symbol Ann -> ProjectContext -> Branch0 IO -> IO [Text] + let getOptions :: Codebase IO Symbol Ann -> PP.ProjectPath -> Branch0 IO -> IO [Text] getOptions codebase projCtx searchBranch0 = do List.nubOrd <$> foldMapM (\f -> f codebase projCtx searchBranch0) resolvers in (FZFResolver {getOptions}) @@ -169,19 +169,28 @@ projectNameOptions codebase _projCtx _searchBranch0 = do -- | All possible local project/branch names. -- E.g. '@unison/base/main' projectBranchOptions :: OptionFetcher -projectBranchOptions codebase _projCtx _searchBranch0 = do - Codebase.runTransaction codebase Q.loadAllProjectBranchNamePairs - <&> fmap (into @Text . fst) +projectBranchOptions codebase projCtx _searchBranch0 = do + projs <- Codebase.runTransaction codebase Q.loadAllProjectBranchNamePairs + projs + & foldMap + ( \(names, projIds) -> + if projIds.project == projCtx.project.projectId + then -- If the branch is in the current project, put a shortened version of the branch name first, + -- then the long-form name at the end of the list (in case the user still types the full name) + [(0 :: Int, "/" <> into @Text names.branch), (2, into @Text names)] + else [(1, into @Text names)] + ) + -- Put branches in this project first. + & List.sort + & fmap snd + & pure -- | All possible local branch names within the current project. -- E.g. '@unison/base/main' projectBranchOptionsWithinCurrentProject :: OptionFetcher projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do - case projCtx of - LooseCodePath _ -> pure [] - ProjectBranchPath currentProjectId _projectBranchId _path -> do - Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith currentProjectId Nothing) - <&> fmap (into @Text . snd) + Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. #project . #projectId) Nothing) + <&> fmap (into @Text . snd) -- | Exported from here just so the debug command and actual implementation can use the same -- messaging. diff --git a/unison-cli/src/Unison/CommandLine/Helpers.hs b/unison-cli/src/Unison/CommandLine/Helpers.hs new file mode 100644 index 0000000000..d50258e304 --- /dev/null +++ b/unison-cli/src/Unison/CommandLine/Helpers.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.CommandLine.Helpers + ( -- * Pretty Printing + backtick, + aside, + bigproblem, + note, + nothingTodo, + plural, + plural', + problem, + tip, + warn, + warnNote, + ) +where + +import Data.ListLike (ListLike) +import Unison.Prelude +import Unison.Util.Pretty qualified as P +import Prelude hiding (readFile, writeFile) + +warnNote :: String -> String +warnNote s = "⚠️ " <> s + +backtick :: (IsString s) => P.Pretty s -> P.Pretty s +backtick s = P.group ("`" <> s <> "`") + +tip :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s +tip s = P.column2 [("Tip:", P.wrap s)] + +note :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s +note s = P.column2 [("Note:", P.wrap s)] + +aside :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s -> P.Pretty s +aside a b = P.column2 [(a <> ":", b)] + +warn :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s +warn = emojiNote "⚠️" + +problem :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s +problem = emojiNote "❗️" + +bigproblem :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s +bigproblem = emojiNote "‼️" + +emojiNote :: (ListLike s Char, IsString s) => String -> P.Pretty s -> P.Pretty s +emojiNote lead s = P.group (fromString lead) <> "\n" <> P.wrap s + +nothingTodo :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s +nothingTodo = emojiNote "😶" + +-- `plural [] "cat" "cats" = "cats"` +-- `plural ["meow"] "cat" "cats" = "cat"` +-- `plural ["meow", "meow"] "cat" "cats" = "cats"` +plural :: (Foldable f) => f a -> b -> b -> b +plural items one other = case toList items of + [_] -> one + _ -> other + +plural' :: (Integral a) => a -> b -> b -> b +plural' 1 one _other = one +plural' _ _one other = other diff --git a/unison-cli/src/Unison/CommandLine/InputPattern.hs b/unison-cli/src/Unison/CommandLine/InputPattern.hs index 4014bc1dc7..cc628559e6 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -28,7 +28,7 @@ import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Codebase (Codebase) import Unison.Codebase.Editor.Input (Input (..)) import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) -import Unison.Codebase.Path as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.FZFResolvers (FZFResolver (..)) import Unison.Prelude import Unison.Util.ColorText qualified as CT @@ -66,7 +66,16 @@ data InputPattern = InputPattern visibility :: Visibility, -- Allow hiding certain commands when debugging or work-in-progress args :: [(ArgumentDescription, IsOptional, ArgumentType)], help :: P.Pretty CT.ColorText, - parse :: Arguments -> Either (P.Pretty CT.ColorText) Input + -- | Parse the arguments and return either an error message or a command `Input`. + -- + -- __NB__: This function should return `Left` only on failure. For commands (like `help`) that simply produce + -- formatted output, use `pure . Input.CreateMessage`. The failure output should be fully formatted (using + -- `wrap`, etc.), but shouldn’t include any general error components like a warninng flag or the full help + -- message, and shouldn’t plan for the context it is being output to (e.g., don’t `P.indentN` the entire + -- message). + parse :: + Arguments -> + Either (P.Pretty CT.ColorText) Input } data ArgumentType = ArgumentType @@ -78,7 +87,7 @@ data ArgumentType = ArgumentType String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> -- Current path + PP.ProjectPath -> m [Line.Completion], -- | If an argument is marked as required, but not provided, the fuzzy finder will be triggered if -- available. @@ -157,14 +166,14 @@ unionSuggestions :: [ ( String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> m [Line.Completion] ) ] -> ( String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> m [Line.Completion] ) unionSuggestions suggesters inp codebase httpClient path = do @@ -179,14 +188,14 @@ suggestionFallbacks :: [ ( String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> m [Line.Completion] ) ] -> ( String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> m [Line.Completion] ) suggestionFallbacks suggesters inp codebase httpClient path = go suggesters diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 65c2c80e13..87597a8653 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1,7 +1,4 @@ -{- - This module defines 'InputPattern' values for every supported input command. --} - +-- | This module defines 'InputPattern' values for every supported input command. module Unison.CommandLine.InputPatterns ( -- * Input commands add, @@ -31,6 +28,7 @@ module Unison.CommandLine.InputPatterns debugNameDiff, debugNumberedArgs, debugTabCompletion, + debugLspNameCompletion, debugTerm, debugTermVerbose, debugType, @@ -53,6 +51,7 @@ module Unison.CommandLine.InputPatterns docs, docsToHtml, edit, + editDependents, editNamespace, execute, find, @@ -68,7 +67,9 @@ module Unison.CommandLine.InputPatterns helpTopics, history, ioTest, + ioTestNative, ioTestAll, + ioTestAllNative, libInstallInputPattern, load, makeStandalone, @@ -102,13 +103,15 @@ module Unison.CommandLine.InputPatterns renameTerm, renameType, reset, - resetRoot, runScheme, saveExecuteResult, sfind, sfindReplace, + textfind, test, + testNative, testAll, + testAllNative, todo, ui, undo, @@ -121,7 +124,10 @@ module Unison.CommandLine.InputPatterns upgradeCommitInputPattern, view, viewGlobal, - viewReflog, + deprecatedViewRootReflog, + branchReflog, + projectReflog, + globalReflog, -- * Misc formatStructuredArgument, @@ -138,9 +144,9 @@ module Unison.CommandLine.InputPatterns ) where -import Control.Lens (preview, review) import Control.Lens.Cons qualified as Cons import Data.Bitraversable (bitraverse) +import Data.Char (isSpace) import Data.List (intercalate) import Data.List.Extra qualified as List import Data.List.NonEmpty qualified as NE @@ -154,6 +160,8 @@ import System.Console.Haskeline.Completion (Completion (Completion)) import System.Console.Haskeline.Completion qualified as Haskeline import System.Console.Haskeline.Completion qualified as Line import Text.Megaparsec qualified as Megaparsec +import Text.Numeral (defaultInflection) +import Text.Numeral.Language.ENG qualified as Numeral import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Sqlite.DbId (ProjectBranchId) import U.Codebase.Sqlite.Project qualified as Sqlite @@ -168,14 +176,13 @@ import Unison.Cli.Pretty prettySlashProjectBranchName, prettyURI, ) -import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch.Merge qualified as Branch -import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input) +import Unison.Codebase.Editor.Input (BranchIdG (..), DeleteOutput (..), DeleteTarget (..), Input) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push)) -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.SlurpResult qualified as SR import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) @@ -185,19 +192,21 @@ import Unison.Codebase.Editor.UriParser qualified as UriParser import Unison.Codebase.Path (Path, Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath) +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.PushBehavior qualified as PushBehavior import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH -import Unison.CommandLine import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..), parseBranchRelativePath, parseIncrementalBranchRelativePath) import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath import Unison.CommandLine.Completion import Unison.CommandLine.FZFResolvers qualified as Resolvers +import Unison.CommandLine.Helpers (aside, backtick, tip) import Unison.CommandLine.InputPattern (ArgumentType (..), InputPattern (InputPattern), IsOptional (..), unionSuggestions) import Unison.CommandLine.InputPattern qualified as I import Unison.Core.Project (ProjectBranchName (..)) import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) @@ -213,7 +222,6 @@ import Unison.Project Semver, branchWithOptionalProjectParser, ) -import Unison.Project.Util (ProjectContext (..), projectContextFromPath) import Unison.Referent qualified as Referent import Unison.Server.Backend (ShallowListEntry (..)) import Unison.Server.Backend qualified as Backend @@ -249,8 +257,14 @@ formatStructuredArgument schLength = \case -- prefixBranchId ".base" "List.map" -> ".base.List.map" prefixBranchId :: Input.AbsBranchId -> Name -> Text prefixBranchId branchId name = case branchId of - Left sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name) - Right pathPrefix -> Name.toText (Path.prefixNameIfRel (Path.AbsolutePath' pathPrefix) name) + BranchAtSCH sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name) + BranchAtPath pathPrefix -> Name.toText (Path.prefixNameIfRel (Path.AbsolutePath' pathPrefix) name) + BranchAtProjectPath pp -> + pp + & PP.absPath_ + %~ (\pathPrefix -> Path.resolve pathPrefix (Path.fromName name)) + & PP.toNames + & into @Text entryToHQText :: Path' -> ShallowListEntry v Ann -> Text entryToHQText pathArg = @@ -302,18 +316,26 @@ searchResultToHQ oprefix = \case addPrefix :: Name -> Name addPrefix = maybe id Path.prefixNameIfRel oprefix -unsupportedStructuredArgument :: Text -> I.Argument -> Either (P.Pretty CT.ColorText) String -unsupportedStructuredArgument expected = - either pure (const . Left . P.text $ "can’t use a numbered argument for " <> expected) +unsupportedStructuredArgument :: InputPattern -> Text -> I.Argument -> Either (P.Pretty CT.ColorText) String +unsupportedStructuredArgument command expected = + either pure . const . Left . P.wrap $ + makeExample' command + <> "can’t accept a numbered argument for" + <> P.text expected + <> "and it’s not yet possible to provide un-expanded numbers as arguments." + +expectedButActually' :: Text -> String -> P.Pretty CT.ColorText +expectedButActually' expected actualValue = + P.text $ "I expected " <> expected <> ", but couldn’t recognize “" <> Text.pack actualValue <> "” as one." expectedButActually :: Text -> StructuredArgument -> Text -> P.Pretty CT.ColorText expectedButActually expected actualValue actualType = P.text $ - "Expected " + "I expected " <> expected - <> ", but the numbered arg resulted in " + <> ", but the numbered argument resulted in “" <> formatStructuredArgument Nothing actualValue - <> ", which is " + <> "”, which is " <> actualType <> "." @@ -334,6 +356,14 @@ wrongStructuredArgument expected actual = SA.ShallowListEntry _ _ -> "a name" SA.SearchResult _ _ -> "a search result" +wrongArgsLength :: Text -> [a] -> Either (P.Pretty CT.ColorText) b +wrongArgsLength expected args = + let foundCount = + case length args of + 0 -> "none" + n -> fromMaybe (tShow n) $ Numeral.us_cardinal defaultInflection n + in Left . P.text $ "I expected " <> expected <> ", but received " <> foundCount <> "." + patternName :: InputPattern -> P.Pretty P.ColorText patternName = fromString . I.patternName @@ -357,23 +387,11 @@ helpFor = I.help handleProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) ProjectName handleProjectArg = either - ( \name -> - first (const . P.text $ "“" <> Text.pack name <> "” is an invalid project name") . tryInto @ProjectName $ - Text.pack name - ) + (\name -> first (const $ expectedButActually' "a project" name) . tryInto @ProjectName $ Text.pack name) \case SA.Project project -> pure project otherArgType -> Left $ wrongStructuredArgument "a project" otherArgType -handleLooseCodeOrProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.LooseCodeOrProject -handleLooseCodeOrProjectArg = - either - (maybe (Left $ P.text "invalid path or project branch") pure . parseLooseCodeOrProject) - \case - SA.AbsolutePath path -> pure . This $ Path.absoluteToPath' path - SA.ProjectBranch pb -> pure $ That pb - otherArgType -> Left $ wrongStructuredArgument "a path or project branch" otherArgType - handleMaybeProjectBranchArg :: I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) handleMaybeProjectBranchArg = @@ -387,12 +405,12 @@ handleProjectMaybeBranchArg :: I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) handleProjectMaybeBranchArg = either - (first (const $ P.text "The argument wasn’t a project") . tryInto . Text.pack) + (\str -> first (const $ expectedButActually' "a project or branch" str) . tryInto $ Text.pack str) \case SA.Project proj -> pure $ ProjectAndBranch proj Nothing SA.ProjectBranch (ProjectAndBranch (Just proj) branch) -> pure . ProjectAndBranch proj . pure $ ProjectBranchNameOrLatestRelease'Name branch - otherArgType -> Left $ wrongStructuredArgument "a project" otherArgType + otherArgType -> Left $ wrongStructuredArgument "a project or branch" otherArgType handleHashQualifiedNameArg :: I.Argument -> Either (P.Pretty CT.ColorText) (HQ.HashQualified Name) handleHashQualifiedNameArg = @@ -468,8 +486,8 @@ handleSplit'Arg = (first P.text . Path.parseSplit') \case SA.Name name -> pure $ Path.splitFromName' name - SA.NameWithBranchPrefix (Left _) name -> pure $ Path.splitFromName' name - SA.NameWithBranchPrefix (Right prefix) name -> + SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure $ Path.splitFromName' name + SA.NameWithBranchPrefix (BranchAtPath prefix) name -> pure . Path.splitFromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg @@ -486,27 +504,35 @@ handleBranchIdArg = either (first P.text . Input.parseBranchId) \case - SA.AbsolutePath path -> pure . pure $ Path.absoluteToPath' path - SA.Name name -> pure . pure $ Path.fromName' name + SA.AbsolutePath path -> pure . BranchAtPath $ Path.absoluteToPath' path + SA.Name name -> pure . BranchAtPath $ Path.fromName' name SA.NameWithBranchPrefix mprefix name -> - pure . pure . Path.fromName' $ foldr (Path.prefixNameIfRel . Path.AbsolutePath') name mprefix - SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash + pure $ case mprefix of + BranchAtSCH _sch -> BranchAtPath . Path.fromName' $ name + BranchAtPath prefix -> BranchAtPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name + BranchAtProjectPath pp -> + pp + & PP.absPath_ + %~ (\pathPrefix -> Path.resolve pathPrefix (Path.fromName name)) + & BranchAtProjectPath + SA.Namespace hash -> pure . BranchAtSCH $ SCH.fromFullHash hash otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg -handleBranchIdOrProjectArg :: +-- | TODO: Maybe remove? +_handleBranchIdOrProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) (These Input.BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)) -handleBranchIdOrProjectArg = +_handleBranchIdOrProjectArg = either - (maybe (Left $ P.text "Expected a branch or project, but it’s not") pure . branchIdOrProject) + (\str -> maybe (Left $ expectedButActually' "a branch" str) pure $ branchIdOrProject str) \case - SA.Namespace hash -> pure . This . Left $ SCH.fromFullHash hash - SA.AbsolutePath path -> pure . This . pure $ Path.absoluteToPath' path - SA.Name name -> pure . This . pure $ Path.fromName' name - SA.NameWithBranchPrefix (Left _) name -> pure . This . pure $ Path.fromName' name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . This . pure . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name - SA.ProjectBranch pb -> pure $ pure pb + SA.Namespace hash -> pure . This . BranchAtSCH $ SCH.fromFullHash hash + SA.AbsolutePath path -> pure . This . BranchAtPath $ Path.absoluteToPath' path + SA.Name name -> pure . This . BranchAtPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . This . BranchAtPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtPath prefix) name -> + pure . This . BranchAtPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name + SA.ProjectBranch pb -> pure $ That pb otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType where branchIdOrProject :: @@ -527,19 +553,21 @@ handleBranchIdOrProjectArg = (Right bid, Left _) -> Just (This bid) (Right bid, Right pr) -> Just (These bid pr) -handleBranchId2Arg :: I.Argument -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath) +handleBranchId2Arg :: I.Argument -> Either (P.Pretty P.ColorText) Input.BranchId2 handleBranchId2Arg = either Input.parseBranchId2 \case SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash - SA.AbsolutePath path -> pure . pure . LoosePath $ Path.absoluteToPath' path - SA.Name name -> pure . pure . LoosePath $ Path.fromName' name - SA.NameWithBranchPrefix (Left _) name -> pure . pure . LoosePath $ Path.fromName' name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . pure . LoosePath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name + SA.AbsolutePath path -> pure . pure . UnqualifiedPath $ Path.absoluteToPath' path + SA.Name name -> pure . pure . UnqualifiedPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . pure . UnqualifiedPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtPath prefix) name -> + pure . pure . UnqualifiedPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name SA.ProjectBranch (ProjectAndBranch mproject branch) -> - pure . pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject + case mproject of + Just proj -> pure . pure $ QualifiedBranchPath proj branch Path.absoluteEmpty + Nothing -> pure . pure $ BranchPathInCurrentProject branch Path.absoluteEmpty otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg handleBranchRelativePathArg :: I.Argument -> Either (P.Pretty P.ColorText) BranchRelativePath @@ -547,13 +575,15 @@ handleBranchRelativePathArg = either parseBranchRelativePath \case - SA.AbsolutePath path -> pure . LoosePath $ Path.absoluteToPath' path - SA.Name name -> pure . LoosePath $ Path.fromName' name - SA.NameWithBranchPrefix (Left _) name -> pure . LoosePath $ Path.fromName' name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . LoosePath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name + SA.AbsolutePath path -> pure . UnqualifiedPath $ Path.absoluteToPath' path + SA.Name name -> pure . UnqualifiedPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . UnqualifiedPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtPath prefix) name -> + pure . UnqualifiedPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name SA.ProjectBranch (ProjectAndBranch mproject branch) -> - pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject + case mproject of + Just proj -> pure $ QualifiedBranchPath proj branch Path.absoluteEmpty + Nothing -> pure $ BranchPathInCurrentProject branch Path.absoluteEmpty otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg hqNameToSplit' :: HQ.HashQualified Name -> Either ShortHash Path.HQSplit' @@ -585,8 +615,8 @@ handleHashQualifiedSplit'Arg = \case SA.Name name -> pure $ Path.hqSplitFromName' name hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit' name - SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit' hqname - SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ hq'NameToSplit' hqname + SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname -> pure . hq'NameToSplit' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname SA.ShallowListEntry prefix entry -> pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry @@ -608,8 +638,8 @@ handleHashQualifiedSplitArg = pure $ Path.hqSplitFromName' name hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit name - SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit hqname - SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ hq'NameToSplit hqname + SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname -> pure . hq'NameToSplit $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname SA.ShallowListEntry _ entry -> pure . hq'NameToSplit $ shallowListEntryToHQ' entry sr@(SA.SearchResult mpath result) -> @@ -631,8 +661,8 @@ handleShortHashOrHQSplit'Arg = (first P.text . Path.parseShortHashOrHQSplit') \case SA.HashQualified name -> pure $ hqNameToSplit' name - SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure . pure $ hq'NameToSplit' hqname - SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure . pure $ hq'NameToSplit' hqname + SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname -> pure . pure $ hq'NameToSplit' (Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname) SA.ShallowListEntry prefix entry -> pure . pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry @@ -653,11 +683,11 @@ handleNameArg = (first P.text . Name.parseTextEither . Text.pack) \case SA.Name name -> pure name - SA.NameWithBranchPrefix (Left _) name -> pure name - SA.NameWithBranchPrefix (Right prefix) name -> pure $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name + SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure name + SA.NameWithBranchPrefix (BranchAtPath prefix) name -> pure $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name SA.HashQualified hqname -> maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname - SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toName hqname - SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ HQ'.toName hqname + SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname -> pure . Path.prefixNameIfRel (Path.AbsolutePath' prefix) $ HQ'.toName hqname SA.ShallowListEntry prefix entry -> pure . HQ'.toName . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry @@ -681,25 +711,20 @@ handlePullSourceArg = otherNumArg -> Left $ wrongStructuredArgument "a source to pull from" otherNumArg handlePushTargetArg :: - I.Argument -> Either (P.Pretty CT.ColorText) (WriteRemoteNamespace (These ProjectName ProjectBranchName)) + I.Argument -> Either (P.Pretty CT.ColorText) (These ProjectName ProjectBranchName) handlePushTargetArg = either - (maybe (Left "Wanted a source to push from, but this ain’t it.") pure . parsePushTarget) - $ fmap RemoteRepo.WriteRemoteProjectBranch . \case + (\str -> maybe (Left $ expectedButActually' "a target to push to" str) pure $ parsePushTarget str) + $ \case SA.Project project -> pure $ This project SA.ProjectBranch (ProjectAndBranch project branch) -> pure $ maybe That These project branch - otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg + otherNumArg -> Left $ wrongStructuredArgument "a target to push to" otherNumArg handlePushSourceArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.PushSource handlePushSourceArg = either - (maybe (Left $ P.text "Wanted a source to push from, but this ain’t it.") pure . parsePushSource) + (\str -> maybe (Left $ expectedButActually' "a source to push from" str) pure $ parsePushSource str) \case - SA.AbsolutePath path -> pure . Input.PathySource $ Path.absoluteToPath' path - SA.Name name -> pure . Input.PathySource $ Path.fromName' name - SA.NameWithBranchPrefix (Left _) name -> pure . Input.PathySource $ Path.fromName' name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . Input.PathySource . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name SA.Project project -> pure . Input.ProjySource $ This project SA.ProjectBranch (ProjectAndBranch project branch) -> pure . Input.ProjySource $ maybe That These project branch otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg @@ -707,7 +732,7 @@ handlePushSourceArg = handleProjectAndBranchNamesArg :: I.Argument -> Either (P.Pretty CT.ColorText) ProjectAndBranchNames handleProjectAndBranchNamesArg = either - (first (const $ P.text "The argument wasn’t a project or branch") . tryInto @ProjectAndBranchNames . Text.pack) + (\str -> first (const $ expectedButActually' "a project or branch" str) . tryInto @ProjectAndBranchNames $ Text.pack str) $ fmap ProjectAndBranchNames'Unambiguous . \case SA.Project project -> pure $ This project SA.ProjectBranch (ProjectAndBranch mproj branch) -> pure $ maybe That These mproj branch @@ -724,7 +749,7 @@ mergeBuiltins = \case [] -> pure . Input.MergeBuiltinsI $ Nothing [p] -> Input.MergeBuiltinsI . Just <$> handlePathArg p - _ -> Left (I.help mergeBuiltins) + args -> wrongArgsLength "no more than one argument" args mergeIOBuiltins :: InputPattern mergeIOBuiltins = @@ -737,7 +762,7 @@ mergeIOBuiltins = \case [] -> pure . Input.MergeIOBuiltinsI $ Nothing [p] -> Input.MergeIOBuiltinsI . Just <$> handlePathArg p - _ -> Left (I.help mergeBuiltins) + args -> wrongArgsLength "no more than one argument" args updateBuiltins :: InputPattern updateBuiltins = @@ -757,30 +782,15 @@ todo = "todo" [] I.Visible - [("patch", Optional, patchArg), ("namespace", Optional, namespaceArg)] - ( P.wrapColumn2 - [ ( makeExample' todo, - "lists the refactor work remaining in the default patch for the current" - <> " namespace." - ), - ( makeExample todo [""], - "lists the refactor work remaining in the given patch in the current " - <> "namespace." - ), - ( makeExample todo ["", "[path]"], - "lists the refactor work remaining in the given patch in given namespace." - ) - ] + [] + ( P.wrap $ + makeExample' todo + <> "lists the current namespace's outstanding issues, including conflicted names, dependencies with missing" + <> "names, and merge precondition violations." ) \case - patchStr : ws -> first warn $ do - patch <- handleSplit'Arg patchStr - branch <- case ws of - [] -> pure Path.relativeEmpty' - [pathStr] -> handlePath'Arg pathStr - _ -> Left "`todo` just takes a patch and one optional namespace" - Right $ Input.TodoI (Just patch) branch - [] -> Right $ Input.TodoI Nothing Path.relativeEmpty' + [] -> Right Input.TodoI + args -> wrongArgsLength "no arguments" args load :: InputPattern load = @@ -800,8 +810,8 @@ load = ) \case [] -> pure $ Input.LoadI Nothing - [file] -> Input.LoadI . Just <$> unsupportedStructuredArgument "a file name" file - _ -> Left (I.help load) + [file] -> Input.LoadI . Just <$> unsupportedStructuredArgument load "a file name" file + args -> wrongArgsLength "no more than one argument" args clear :: InputPattern clear = @@ -818,7 +828,7 @@ clear = ) \case [] -> pure Input.ClearI - _ -> Left (I.help clear) + args -> wrongArgsLength "no arguments" args add :: InputPattern add = @@ -861,7 +871,7 @@ update = <> "for your review.", parse = \case [] -> pure Input.Update2I - _ -> Left $ I.help update + args -> wrongArgsLength "no arguments" args } updateOldNoPatch :: InputPattern @@ -962,7 +972,7 @@ view = ] ) ( maybe - (Left $ I.help view) + (wrongArgsLength "at least one argument" []) ( fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionLocal) . traverse handleHashQualifiedNameArg ) @@ -982,7 +992,7 @@ viewGlobal = ] ) ( maybe - (Left $ I.help viewGlobal) + (wrongArgsLength "at least one argument" []) ( fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionGlobal) . traverse handleHashQualifiedNameArg ) @@ -1001,7 +1011,9 @@ display = "`display` without arguments invokes a search to select a definition to display, which requires that `fzf` can be found within your PATH." ] ) - $ maybe (Left $ I.help display) (fmap (Input.DisplayI Input.ConsoleLocation) . traverse handleHashQualifiedNameArg) + $ maybe + (wrongArgsLength "at least one argument" []) + (fmap (Input.DisplayI Input.ConsoleLocation) . traverse handleHashQualifiedNameArg) . NE.nonEmpty displayTo :: InputPattern @@ -1018,14 +1030,14 @@ displayTo = $ \case file : defs -> maybe - (Left $ I.help displayTo) - ( \defs -> - Input.DisplayI . Input.FileLocation - <$> unsupportedStructuredArgument "a file name" file - <*> traverse handleHashQualifiedNameArg defs + (wrongArgsLength "at least two arguments" [file]) + ( \defs -> do + file <- unsupportedStructuredArgument displayTo "a file name" file + names <- traverse handleHashQualifiedNameArg defs + pure (Input.DisplayI (Input.FileLocation file Input.AboveFold) names) ) $ NE.nonEmpty defs - _ -> Left (I.help displayTo) + [] -> wrongArgsLength "at least two arguments" [] docs :: InputPattern docs = @@ -1039,7 +1051,7 @@ docs = "`docs` without arguments invokes a search to select which definition to view documentation for, which requires that `fzf` can be found within your PATH." ] ) - $ maybe (Left $ I.help docs) (fmap Input.DocsI . traverse handleNameArg) . NE.nonEmpty + $ maybe (wrongArgsLength "at least one argument" []) (fmap Input.DocsI . traverse handleNameArg) . NE.nonEmpty api :: InputPattern api = @@ -1062,7 +1074,7 @@ ui = parse = \case [] -> pure $ Input.UiI Path.relativeEmpty' [path] -> Input.UiI <$> handlePath'Arg path - _ -> Left (I.help ui) + args -> wrongArgsLength "no more than one argument" args } undo :: InputPattern @@ -1075,14 +1087,53 @@ undo = "`undo` reverts the most recent change to the codebase." (const $ pure Input.UndoI) +textfind :: Bool -> InputPattern +textfind allowLib = + InputPattern cmdName aliases I.Visible [("token", OnePlus, noCompletionsArg)] msg parse + where + (cmdName, aliases, alternate) = + if allowLib + then ("text.find.all", ["grep.all"], "Use `text.find` to exclude `lib` from search.") + else ("text.find", ["grep"], "Use `text.find.all` to include search of `lib`.") + parse = \case + [] -> Left (P.text "Please supply at least one token.") + words -> pure $ Input.TextFindI allowLib (untokenize $ [e | Left e <- words]) + msg = + P.lines + [ P.wrap $ + makeExample (textfind allowLib) ["token1", "\"99\"", "token2"] + <> " finds terms with literals (text or numeric) containing" + <> "`token1`, `99`, and `token2`.", + "", + P.wrap $ + "Numeric literals must be quoted (ex: \"42\")" + <> "but single words need not be quoted.", + "", + P.wrap alternate + ] + +-- | Reinterprets `"` in the expected way, combining tokens until reaching +-- the closing quote. +-- Example: `untokenize ["\"uno", "dos\""]` becomes `["uno dos"]`. +untokenize :: [String] -> [String] +untokenize words = go (unwords words) + where + go words = case words of + [] -> [] + '"' : quoted -> takeWhile (/= '"') quoted : go (drop 1 . dropWhile (/= '"') $ quoted) + unquoted -> case span ok unquoted of + ("", rem) -> go (dropWhile isSpace rem) + (tok, rem) -> tok : go (dropWhile isSpace rem) + where + ok ch = ch /= '"' && not (isSpace ch) + sfind :: InputPattern sfind = InputPattern "rewrite.find" ["sfind"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse where - parse [q] = - Input.StructuredFindI (Input.FindLocal Path.relativeEmpty') - <$> handleHashQualifiedNameArg q - parse _ = Left "expected exactly one argument" + parse = \case + [q] -> Input.StructuredFindI (Input.FindLocal Path.relativeEmpty') <$> handleHashQualifiedNameArg q + args -> wrongArgsLength "exactly one argument" args msg = P.lines [ P.wrap $ @@ -1113,7 +1164,7 @@ sfindReplace = InputPattern "rewrite" ["sfind.replace"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse where parse [q] = Input.StructuredFindReplaceI <$> handleHashQualifiedNameArg q - parse _ = Left "expected exactly one argument" + parse args = wrongArgsLength "exactly one argument" args msg :: P.Pretty CT.ColorText msg = P.lines @@ -1145,7 +1196,7 @@ findAll :: InputPattern findAll = find' "find.all" (Input.FindLocalAndDeps Path.relativeEmpty') findGlobal :: InputPattern -findGlobal = find' "find.global" Input.FindGlobal +findGlobal = find' "debug.find.global" Input.FindGlobal findIn, findInAll :: InputPattern findIn = findIn' "find-in" Input.FindLocal @@ -1161,7 +1212,7 @@ findIn' cmd mkfscope = findHelp \case p : args -> Input.FindI False . mkfscope <$> handlePath'Arg p <*> pure (unifyArgument <$> args) - _ -> Left findHelp + args -> wrongArgsLength "at least one argument" args findHelp :: P.Pretty CT.ColorText findHelp = @@ -1193,8 +1244,8 @@ findHelp = "lists all definitions with a name similar to 'foo' or 'bar' in the " <> "specified subnamespace (including one level of its 'lib')." ), - ( "find.global foo", - "lists all definitions with a name similar to 'foo' in any namespace" + ( "debug.find.global foo", + "Iteratively searches all projects and branches and lists all definitions with a name similar to 'foo'. Note that this is a very slow operation." ) ] ) @@ -1225,7 +1276,7 @@ findShallow = ( fmap Input.FindShallowI . \case [] -> pure Path.relativeEmpty' [path] -> handlePath'Arg path - _ -> Left (I.help findShallow) + args -> wrongArgsLength "no more than one argument" args ) findVerbose :: InputPattern @@ -1264,7 +1315,7 @@ renameTerm = "`move.term foo bar` renames `foo` to `bar`." \case [oldName, newName] -> Input.MoveTermI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName - _ -> Left . P.warnCallout $ P.wrap "`rename.term` takes two arguments, like `rename.term oldname newname`." + _ -> Left $ P.wrap "`rename.term` takes two arguments, like `rename.term oldname newname`." moveAll :: InputPattern moveAll = @@ -1278,7 +1329,7 @@ moveAll = "`move foo bar` renames the term, type, and namespace foo to bar." \case [oldName, newName] -> Input.MoveAllI <$> handlePath'Arg oldName <*> handleNewPath newName - _ -> Left . P.warnCallout $ P.wrap "`move` takes two arguments, like `move oldname newname`." + _ -> Left $ P.wrap "`move` takes two arguments, like `move oldname newname`." renameType :: InputPattern renameType = @@ -1293,7 +1344,7 @@ renameType = \case [oldName, newName] -> Input.MoveTypeI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName _ -> - Left . P.warnCallout $ P.wrap "`rename.type` takes two arguments, like `rename.type oldname newname`." + Left $ P.wrap "`rename.type` takes two arguments, like `rename.type oldname newname`." deleteGen :: Maybe String -> ArgumentType -> String -> ([Path.HQSplit'] -> DeleteTarget) -> InputPattern deleteGen suffix queryCompletionArg target mkTarget = @@ -1319,7 +1370,7 @@ deleteGen suffix queryCompletionArg target mkTarget = "" ) ] - warn = + warning = P.sep " " [ backtick (P.string cmd), @@ -1333,7 +1384,7 @@ deleteGen suffix queryCompletionArg target mkTarget = [("definition to delete", OnePlus, queryCompletionArg)] info \case - [] -> Left . P.warnCallout $ P.wrap warn + [] -> Left $ P.wrap warning queries -> Input.DeleteI . mkTarget <$> traverse handleHashQualifiedSplit'Arg queries delete :: InputPattern @@ -1367,7 +1418,7 @@ deleteProject = ], parse = \case [name] -> Input.DeleteI . DeleteTarget'Project <$> handleProjectArg name - _ -> Left (showPatternHelp deleteProject) + args -> wrongArgsLength "exactly one argument" args } deleteBranch :: InputPattern @@ -1384,7 +1435,7 @@ deleteBranch = ], parse = \case [name] -> Input.DeleteI . DeleteTarget'ProjectBranch <$> handleMaybeProjectBranchArg name - _ -> Left (showPatternHelp deleteBranch) + args -> wrongArgsLength "exactly one argument" args } where suggestionsConfig = @@ -1397,14 +1448,30 @@ deleteBranch = aliasTerm :: InputPattern aliasTerm = InputPattern - "alias.term" - [] - I.Visible - [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)] - "`alias.term foo bar` introduces `bar` with the same definition as `foo`." - $ \case - [oldName, newName] -> Input.AliasTermI <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName - _ -> Left . warn $ P.wrap "`alias.term` takes two arguments, like `alias.term oldname newname`." + { patternName = "alias.term", + aliases = [], + visibility = I.Visible, + args = [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)], + help = "`alias.term foo bar` introduces `bar` with the same definition as `foo`.", + parse = \case + [oldName, newName] -> Input.AliasTermI False <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + _ -> Left $ P.wrap "`alias.term` takes two arguments, like `alias.term oldname newname`." + } + +debugAliasTermForce :: InputPattern +debugAliasTermForce = + InputPattern + { patternName = "debug.alias.term.force", + aliases = [], + visibility = I.Hidden, + args = [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)], + help = "`debug.alias.term.force foo bar` introduces `bar` with the same definition as `foo`.", + parse = \case + [oldName, newName] -> Input.AliasTermI True <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + _ -> + Left $ + P.wrap "`debug.alias.term.force` takes two arguments, like `debug.alias.term.force oldname newname`." + } aliasType :: InputPattern aliasType = @@ -1415,8 +1482,23 @@ aliasType = [("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)] "`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`." \case - [oldName, newName] -> Input.AliasTypeI <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName - _ -> Left . warn $ P.wrap "`alias.type` takes two arguments, like `alias.type oldname newname`." + [oldName, newName] -> Input.AliasTypeI False <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + _ -> Left $ P.wrap "`alias.type` takes two arguments, like `alias.type oldname newname`." + +debugAliasTypeForce :: InputPattern +debugAliasTypeForce = + InputPattern + { patternName = "debug.alias.type.force", + aliases = [], + visibility = I.Hidden, + args = [("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)], + help = "`debug.alias.type.force Foo Bar` introduces `Bar` with the same definition as `Foo`.", + parse = \case + [oldName, newName] -> Input.AliasTypeI True <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + _ -> + Left $ + P.wrap "`debug.alias.type.force` takes two arguments, like `debug.alias.type.force oldname newname`." + } aliasMany :: InputPattern aliasMany = @@ -1437,7 +1519,7 @@ aliasMany = \case srcs@(_ : _) Cons.:> dest -> Input.AliasManyI <$> traverse handleHashQualifiedSplitArg srcs <*> handlePath'Arg dest - _ -> Left (I.help aliasMany) + args -> wrongArgsLength "at least two arguments" args up :: InputPattern up = @@ -1449,7 +1531,7 @@ up = (P.wrapColumn2 [(makeExample up [], "move current path up one level (deprecated)")]) \case [] -> Right Input.UpI - _ -> Left (I.help up) + args -> wrongArgsLength "no arguments" args cd :: InputPattern cd = @@ -1480,7 +1562,7 @@ cd = \case [Left ".."] -> Right Input.UpI [p] -> Input.SwitchBranchI <$> handlePath'Arg p - _ -> Left (I.help cd) + args -> wrongArgsLength "exactly one argument" args back :: InputPattern back = @@ -1497,7 +1579,7 @@ back = ) \case [] -> pure Input.PopBranchI - _ -> Left (I.help cd) + args -> wrongArgsLength "no arguments" args deleteNamespace :: InputPattern deleteNamespace = @@ -1507,7 +1589,7 @@ deleteNamespace = I.Visible [("namespace to delete", Required, namespaceArg)] "`delete.namespace ` deletes the namespace `foo`" - (deleteNamespaceParser (I.help deleteNamespace) Input.Try) + (deleteNamespaceParser Input.Try) deleteNamespaceForce :: InputPattern deleteNamespaceForce = @@ -1519,13 +1601,13 @@ deleteNamespaceForce = ( "`delete.namespace.force ` deletes the namespace `foo`," <> "deletion will proceed even if other code depends on definitions in foo." ) - (deleteNamespaceParser (I.help deleteNamespaceForce) Input.Force) + (deleteNamespaceParser Input.Force) -deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> I.Arguments -> Either (P.Pretty CT.ColorText) Input -deleteNamespaceParser helpText insistence = \case +deleteNamespaceParser :: Input.Insistence -> I.Arguments -> Either (P.Pretty CT.ColorText) Input +deleteNamespaceParser insistence = \case [Left "."] -> first fromString . pure $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) - [p] -> Input.DeleteI . DeleteTarget'Namespace insistence . pure <$> handleSplitArg p - _ -> Left helpText + [p] -> Input.DeleteI . DeleteTarget'Namespace insistence <$> (Just <$> handleSplitArg p) + args -> wrongArgsLength "exactly one argument" args renameBranch :: InputPattern renameBranch = @@ -1537,7 +1619,7 @@ renameBranch = "`move.namespace foo bar` renames the path `foo` to `bar`." \case [src, dest] -> Input.MoveBranchI <$> handlePath'Arg src <*> handlePath'Arg dest - _ -> Left (I.help renameBranch) + args -> wrongArgsLength "exactly two arguments" args history :: InputPattern history = @@ -1557,8 +1639,8 @@ history = ) \case [src] -> Input.HistoryI (Just 10) (Just 10) <$> handleBranchIdArg src - [] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath) - _ -> Left (I.help history) + [] -> pure $ Input.HistoryI (Just 10) (Just 10) (BranchAtPath Path.currentPath) + args -> wrongArgsLength "no more than one argument" args forkLocal :: InputPattern forkLocal = @@ -1583,7 +1665,7 @@ forkLocal = ) \case [src, dest] -> Input.ForkLocalBranchI <$> handleBranchId2Arg src <*> handleBranchRelativePathArg dest - _ -> Left (I.help forkLocal) + args -> wrongArgsLength "exactly two arguments" args libInstallInputPattern :: InputPattern libInstallInputPattern = @@ -1613,7 +1695,7 @@ libInstallInputPattern = ], parse = \case [arg] -> Input.LibInstallI False <$> handleProjectMaybeBranchArg arg - _ -> Left (I.help libInstallInputPattern) + args -> wrongArgsLength "exactly one argument" args } reset :: InputPattern @@ -1625,17 +1707,20 @@ reset = [ ("namespace, hash, or branch to reset to", Required, namespaceOrProjectBranchArg config), ("namespace to be reset", Optional, namespaceOrProjectBranchArg config) ] - ( P.wrapColumn2 - [ ("`reset #pvfd222s8n`", "reset the current namespace to the causal `#pvfd222s8n`"), - ("`reset foo`", "reset the current namespace to that of the `foo` namespace."), - ("`reset foo bar`", "reset the namespace `bar` to that of the `foo` namespace."), - ("`reset #pvfd222s8n /topic`", "reset the branch `topic` of the current project to the causal `#pvfd222s8n`.") + ( P.lines + [ P.wrapColumn2 + [ ("`reset #pvfd222s8n`", "reset the current namespace to the hash `#pvfd222s8n`"), + ("`reset foo`", "reset the current namespace to the state of the `foo` namespace."), + ("`reset #pvfd222s8n /topic`", "reset the branch `topic` of the current project to the causal `#pvfd222s8n`.") + ], + "", + P.wrap $ "If you make a mistake using reset, consult the " <> makeExample' branchReflog <> " command and use another " <> makeExample' reset <> " command to return to a previous state." ] ) \case - [arg0] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> pure Nothing - [arg0, arg1] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> fmap pure (handleLooseCodeOrProjectArg arg1) - _ -> Left $ I.help reset + [resetTo] -> Input.ResetI <$> handleBranchId2Arg resetTo <*> pure Nothing + [resetTo, branchToReset] -> Input.ResetI <$> handleBranchId2Arg resetTo <*> fmap pure (handleMaybeProjectBranchArg branchToReset) + args -> wrongArgsLength "one or two arguments" args where config = ProjectBranchSuggestionsConfig @@ -1644,31 +1729,6 @@ reset = branchInclusion = AllBranches } --- asBranch = tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack inputString) - -resetRoot :: InputPattern -resetRoot = - InputPattern - "reset-root" - [] - I.Hidden - [("namespace or hash to reset to", Required, namespaceArg)] - ( P.lines - [ "Deprecated because it's incompatible with projects. ⚠️ Warning, this command can cause codebase corruption.", - P.wrapColumn2 - [ ( makeExample resetRoot [".foo"], - "Reset the root namespace (along with its history) to that of the `.foo` namespace. Deprecated" - ), - ( makeExample resetRoot ["#9dndk3kbsk13nbpeu"], - "Reset the root namespace (along with its history) to that of the namespace with hash `#9dndk3kbsk13nbpeu`." - ) - ] - ] - ) - $ \case - [src] -> Input.ResetRootI <$> handleBranchIdArg src - _ -> Left (I.help resetRoot) - pull :: InputPattern pull = pullImpl "pull" [] Input.PullWithHistory "" @@ -1764,31 +1824,26 @@ pullImpl name aliases pullMode addendum = do These sourceProject sourceBranch -> Right (Input.LibInstallI True (ProjectAndBranch sourceProject (Just sourceBranch))) (Right source, Left _, Right path) -> - Left . P.indentN 2 $ - P.wrap - ( "I think you're wanting to merge" - <> case source of - RemoteRepo.ReadShare'LooseCode _sourcePath -> "some non-project code" - RemoteRepo.ReadShare'ProjectBranch (This sourceProject) -> - prettyProjectNameSlash sourceProject - RemoteRepo.ReadShare'ProjectBranch (That ProjectBranchNameOrLatestRelease'LatestRelease) -> - "the latest release" - RemoteRepo.ReadShare'ProjectBranch (That (ProjectBranchNameOrLatestRelease'Name sourceBranch)) -> - prettySlashProjectBranchName sourceBranch - RemoteRepo.ReadShare'ProjectBranch (These sourceProject ProjectBranchNameOrLatestRelease'LatestRelease) -> - "the latest release of" <> prettyProjectName sourceProject - RemoteRepo.ReadShare'ProjectBranch (These sourceProject (ProjectBranchNameOrLatestRelease'Name sourceBranch)) -> - prettyProjectAndBranchName (ProjectAndBranch sourceProject sourceBranch) - <> "into the" - <> prettyPath' path - <> "namespace, but the" - <> makeExample' pull - <> "command only supports merging into the top level of a local project branch." - ) - <> P.newline - <> P.newline - <> P.wrap "Use `help pull` to see some examples." - _ -> Left $ I.help self + Left . P.wrap $ + "I think you want to merge " + <> case source of + RemoteRepo.ReadShare'LooseCode _sourcePath -> "some non-project code" + RemoteRepo.ReadShare'ProjectBranch (This sourceProject) -> + prettyProjectNameSlash sourceProject + RemoteRepo.ReadShare'ProjectBranch (That ProjectBranchNameOrLatestRelease'LatestRelease) -> + "the latest release" + RemoteRepo.ReadShare'ProjectBranch (That (ProjectBranchNameOrLatestRelease'Name sourceBranch)) -> + prettySlashProjectBranchName sourceBranch + RemoteRepo.ReadShare'ProjectBranch (These sourceProject ProjectBranchNameOrLatestRelease'LatestRelease) -> + "the latest release of" <> prettyProjectName sourceProject + RemoteRepo.ReadShare'ProjectBranch (These sourceProject (ProjectBranchNameOrLatestRelease'Name sourceBranch)) -> + prettyProjectAndBranchName (ProjectAndBranch sourceProject sourceBranch) + <> " into the " + <> prettyPath' path + <> " namespace, but the " + <> makeExample' pull + <> " command only supports merging into the top level of a local project branch." + args -> wrongArgsLength "no more than two arguments" args } debugTabCompletion :: InputPattern @@ -1803,7 +1858,22 @@ debugTabCompletion = P.wrap $ "Completions which are finished are prefixed with a * represent finished completions." ] ) - (fmap Input.DebugTabCompletionI . traverse (unsupportedStructuredArgument "text")) + (fmap Input.DebugTabCompletionI . traverse (unsupportedStructuredArgument debugTabCompletion "text")) + +debugLspNameCompletion :: InputPattern +debugLspNameCompletion = + InputPattern + "debug.lsp-name-completion" + [] + I.Hidden + [("Completion prefix", OnePlus, noCompletionsArg)] + ( P.lines + [ P.wrap $ "This command can be used to test and debug ucm's LSP name-completion within transcripts." + ] + ) + \case + [prefix] -> Input.DebugLSPNameCompletionI . Text.pack <$> unsupportedStructuredArgument debugLspNameCompletion "text" prefix + args -> wrongArgsLength "exactly one argument" args debugFuzzyOptions :: InputPattern debugFuzzyOptions = @@ -1823,9 +1893,9 @@ debugFuzzyOptions = \case (cmd : args) -> Input.DebugFuzzyOptionsI - <$> unsupportedStructuredArgument "a command" cmd - <*> traverse (unsupportedStructuredArgument "text") args - _ -> Left (I.help debugFuzzyOptions) + <$> unsupportedStructuredArgument debugFuzzyOptions "a command" cmd + <*> traverse (unsupportedStructuredArgument debugFuzzyOptions "text") args + args -> wrongArgsLength "at least one argument" args debugFormat :: InputPattern debugFormat = @@ -1841,7 +1911,7 @@ debugFormat = ) ( \case [] -> Right Input.DebugFormatI - _ -> Left (I.help debugFormat) + args -> wrongArgsLength "no arguments" args ) push :: InputPattern @@ -1888,7 +1958,7 @@ push = [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr [targetStr, sourceStr] -> Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr - _ -> Left (I.help push) + args -> wrongArgsLength "no more than two arguments" args where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1939,7 +2009,7 @@ pushCreate = [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr [targetStr, sourceStr] -> Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr - _ -> Left (I.help pushForce) + args -> wrongArgsLength "no more than two arguments" args where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1952,10 +2022,10 @@ pushForce :: InputPattern pushForce = InputPattern "unsafe.force-push" - [] - I.Hidden + ["push.unsafe-force"] + I.Visible [("remote destination", Optional, remoteNamespaceArg), ("local source", Optional, namespaceOrProjectBranchArg suggestionsConfig)] - (P.wrap "Like `push`, but overwrites any remote namespace.") + (P.wrap "Like `push`, but forcibly overwrites the remote namespace.") $ fmap ( \sourceTarget -> Input.PushRemoteBranchI @@ -1969,7 +2039,7 @@ pushForce = [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr [targetStr, sourceStr] -> Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr - _ -> Left (I.help pushForce) + args -> wrongArgsLength "no more than two arguments" args where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -2009,7 +2079,7 @@ pushExhaustive = [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr [targetStr, sourceStr] -> Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr - _ -> Left (I.help pushExhaustive) + args -> wrongArgsLength "no more than two arguments" args where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -2036,12 +2106,17 @@ mergeOldSquashInputPattern = <> "The resulting `dest` will have (at most) 1" <> "additional history entry.", parse = \case + [src] -> + Input.MergeLocalBranchI + <$> handleBranchRelativePathArg src + <*> pure Nothing + <*> pure Branch.SquashMerge [src, dest] -> Input.MergeLocalBranchI - <$> handleLooseCodeOrProjectArg src - <*> handleLooseCodeOrProjectArg dest + <$> handleBranchRelativePathArg src + <*> (Just <$> handleBranchRelativePathArg dest) <*> pure Branch.SquashMerge - _ -> Left $ I.help mergeOldSquashInputPattern + args -> wrongArgsLength "exactly two arguments" args } where suggestionsConfig = @@ -2072,27 +2147,21 @@ mergeOldInputPattern = ), ( makeExample mergeOldInputPattern ["/topic", "foo/main"], "merges the branch `topic` of the current project into the `main` branch of the project 'foo`" - ), - ( makeExample mergeOldInputPattern [".src"], - "merges `.src` namespace into the current namespace" - ), - ( makeExample mergeOldInputPattern [".src", ".dest"], - "merges `.src` namespace into the `dest` namespace" ) ] ) ( \case [src] -> Input.MergeLocalBranchI - <$> handleLooseCodeOrProjectArg src - <*> pure (This Path.relativeEmpty') + <$> handleBranchRelativePathArg src + <*> pure Nothing <*> pure Branch.RegularMerge [src, dest] -> Input.MergeLocalBranchI - <$> handleLooseCodeOrProjectArg src - <*> handleLooseCodeOrProjectArg dest + <$> handleBranchRelativePathArg src + <*> (Just <$> handleBranchRelativePathArg dest) <*> pure Branch.RegularMerge - _ -> Left $ I.help mergeOldInputPattern + args -> wrongArgsLength "one or two arguments" args ) where config = @@ -2122,9 +2191,8 @@ mergeInputPattern = help = P.wrap $ makeExample mergeInputPattern ["/branch"] <> "merges `branch` into the current branch", parse = \case - [branchString] -> - Input.MergeI <$> handleMaybeProjectBranchArg branchString - _ -> Left $ I.help mergeInputPattern + [branchString] -> Input.MergeI <$> handleMaybeProjectBranchArg branchString + args -> wrongArgsLength "exactly one argument" args } mergeCommitInputPattern :: InputPattern @@ -2166,20 +2234,9 @@ mergeCommitInputPattern = ), parse = \case [] -> Right Input.MergeCommitI - _ -> Left (I.help mergeCommitInputPattern) + args -> wrongArgsLength "no arguments" args } -parseLooseCodeOrProject :: String -> Maybe Input.LooseCodeOrProject -parseLooseCodeOrProject inputString = - case (asLooseCode, asBranch) of - (Right path, Left _) -> Just (This path) - (Left _, Right branch) -> Just (That branch) - (Right path, Right branch) -> Just (These path branch) - (Left _, Left _) -> Nothing - where - asLooseCode = Path.parsePath' inputString - asBranch = tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack inputString) - diffNamespace :: InputPattern diffNamespace = InputPattern @@ -2197,9 +2254,9 @@ diffNamespace = ] ) ( \case - [before, after] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> handleBranchIdArg after - [before] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> pure (pure Path.currentPath) - _ -> Left $ I.help diffNamespace + [before, after] -> Input.DiffNamespaceI <$> handleBranchId2Arg before <*> handleBranchId2Arg after + [before] -> Input.DiffNamespaceI <$> handleBranchId2Arg before <*> pure (Right . UnqualifiedPath $ Path.currentPath) + args -> wrongArgsLength "one or two arguments" args ) where suggestionsConfig = @@ -2226,10 +2283,10 @@ mergeOldPreviewInputPattern = ] ) ( \case - [src] -> Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> pure (This Path.relativeEmpty') + [src] -> Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> pure Nothing [src, dest] -> - Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> handleLooseCodeOrProjectArg dest - _ -> Left $ I.help mergeOldPreviewInputPattern + Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> (Just <$> handleBranchRelativePathArg dest) + args -> wrongArgsLength "one or two arguments" args ) where suggestionsConfig = @@ -2239,19 +2296,74 @@ mergeOldPreviewInputPattern = branchInclusion = AllBranches } -viewReflog :: InputPattern -viewReflog = +deprecatedViewRootReflog :: InputPattern +deprecatedViewRootReflog = InputPattern - "reflog" + "deprecated.root-reflog" [] I.Visible [] - "`reflog` lists the changes that have affected the root namespace" + ( "`deprecated.root-reflog` lists the changes that have affected the root namespace. This has been deprecated in favor of " + <> makeExample branchReflog [] + <> " which shows the reflog for the current project." + ) ( \case - [] -> pure Input.ShowReflogI + [] -> pure Input.ShowRootReflogI _ -> - Left . warn . P.string $ - I.patternName viewReflog ++ " doesn't take any arguments." + Left . P.string $ + I.patternName deprecatedViewRootReflog ++ " doesn't take any arguments." + ) + +branchReflog :: InputPattern +branchReflog = + InputPattern + "reflog" + ["reflog.branch", "branch.reflog"] + I.Visible + [] + ( P.lines + [ "`reflog` lists all the changes that have affected the current branch.", + "`reflog /mybranch` lists all the changes that have affected /mybranch." + ] + ) + ( \case + [] -> pure $ Input.ShowProjectBranchReflogI Nothing + [branchRef] -> Input.ShowProjectBranchReflogI <$> (Just <$> handleMaybeProjectBranchArg branchRef) + _ -> Left (I.help branchReflog) + ) + +projectReflog :: InputPattern +projectReflog = + InputPattern + "project.reflog" + ["reflog.project"] + I.Visible + [] + ( P.lines + [ "`project.reflog` lists all the changes that have affected any branches in the current project.", + "`project.reflog myproject` lists all the changes that have affected any branches in myproject." + ] + ) + ( \case + [] -> pure $ Input.ShowProjectReflogI Nothing + [projectRef] -> Input.ShowProjectReflogI <$> (Just <$> handleProjectArg projectRef) + _ -> Left (I.help projectReflog) + ) + +globalReflog :: InputPattern +globalReflog = + InputPattern + "reflog.global" + [] + I.Visible + [] + ( P.lines + [ "`reflog.global` lists all recent changes across all projects and branches." + ] + ) + ( \case + [] -> pure $ Input.ShowGlobalReflogI + _ -> Left (I.help globalReflog) ) edit :: InputPattern @@ -2269,13 +2381,43 @@ edit = ], parse = maybe - (Left $ I.help edit) - ( fmap (Input.ShowDefinitionI Input.LatestFileLocation Input.ShowDefinitionLocal) + (wrongArgsLength "at least one argument" []) + ( fmap (Input.ShowDefinitionI (Input.LatestFileLocation Input.WithinFold) Input.ShowDefinitionLocal) + . traverse handleHashQualifiedNameArg + ) + . NE.nonEmpty + } + +editNew :: InputPattern +editNew = + InputPattern + { patternName = "edit.new", + aliases = [], + visibility = I.Visible, + args = [("definition to edit", OnePlus, definitionQueryArg)], + help = "Like `edit`, but adds a new fold line below the definitions.", + parse = + maybe + (wrongArgsLength "at least one argument" []) + ( fmap (Input.ShowDefinitionI (Input.LatestFileLocation Input.AboveFold) Input.ShowDefinitionLocal) . traverse handleHashQualifiedNameArg ) . NE.nonEmpty } +editDependents :: InputPattern +editDependents = + InputPattern + { patternName = "edit.dependents", + aliases = [], + visibility = I.Visible, + args = [("definition to edit", Required, definitionQueryArg)], + help = "Like `edit`, but also includes all transitive dependents in the current project.", + parse = \case + [name] -> Input.EditDependentsI <$> handleHashQualifiedNameArg name + args -> wrongArgsLength "exactly one argument" args + } + editNamespace :: InputPattern editNamespace = InputPattern @@ -2309,13 +2451,13 @@ helpTopics = [("topic", Optional, topicNameArg)] ("`help-topics` lists all topics and `help-topics ` shows an explanation of that topic.") ( \case - [] -> Left topics + [] -> Right $ Input.CreateMessage topics [topic] -> do - topic <- unsupportedStructuredArgument "a help topic" topic + topic <- unsupportedStructuredArgument helpTopics "a help topic" topic case Map.lookup topic helpTopicsMap of - Nothing -> Left . warn $ "I don't know of that topic. Try `help-topics`." - Just t -> Left t - _ -> Left $ warn "Use `help-topics ` or `help-topics`." + Nothing -> Left $ "I don't know of that topic. Try `help-topics`." + Just t -> Right $ Input.CreateMessage t + _ -> Left $ "Use `help-topics ` or `help-topics`." ) where topics = @@ -2325,7 +2467,7 @@ helpTopics = "", P.indentN 2 $ P.sep "\n" (P.string <$> Map.keys helpTopicsMap), "", - aside "Example" "use `help filestatus` to learn more about that topic." + aside "Example" "use `help-topics filestatus` to learn more about that topic." ] helpTopicsMap :: Map String (P.Pretty P.ColorText) @@ -2494,21 +2636,21 @@ help = "`help` shows general help and `help ` shows help for one command." $ \case [] -> - Left $ + Right . Input.CreateMessage $ intercalateMap "\n\n" showPatternHelp visibleInputs [cmd] -> do - cmd <- unsupportedStructuredArgument "a command" cmd + cmd <- unsupportedStructuredArgument help "a command" cmd case (Map.lookup cmd commandsByName, isHelp cmd) of - (Nothing, Just msg) -> Left msg - (Nothing, Nothing) -> Left . warn $ "I don't know of that command. Try `help`." - (Just pat, Nothing) -> Left $ showPatternHelp pat + (Nothing, Just msg) -> Right $ Input.CreateMessage msg + (Nothing, Nothing) -> Left $ "I don't know of that command. Try" <> makeExampleEOS help [] + (Just pat, Nothing) -> Right . Input.CreateMessage $ showPatternHelp pat -- If we have a command and a help topic with the same name (like "projects"), then append a tip to the -- command's help that suggests running `help-topic command` (Just pat, Just _) -> - Left $ + Right . Input.CreateMessage $ showPatternHelp pat <> P.newline <> P.newline @@ -2518,7 +2660,7 @@ help = <> "use" <> makeExample helpTopics [P.string cmd] ) - _ -> Left $ warn "Use `help ` or `help`." + _ -> Left "Use `help ` or `help`." where commandsByName = Map.fromList $ do @@ -2546,12 +2688,15 @@ names isGlobal = [] I.Visible [("name or hash", Required, definitionQueryArg)] - (P.wrap $ makeExample (names isGlobal) ["foo"] <> " shows the hash and all known names for `foo`.") + (P.wrap $ makeExample (names isGlobal) ["foo"] <> description) $ \case [thing] -> Input.NamesI isGlobal <$> handleHashQualifiedNameArg thing - _ -> Left (I.help (names isGlobal)) + args -> wrongArgsLength "exactly one argument" args where - cmdName = if isGlobal then "names.global" else "names" + description + | isGlobal = "Iteratively search across all projects and branches for names matching `foo`. Note that this is expected to be quite slow and is primarily for debugging issues with your codebase." + | otherwise = "List all known names for `foo` in the current branch." + cmdName = if isGlobal then "debug.names.global" else "names" dependents, dependencies :: InputPattern dependents = @@ -2563,7 +2708,7 @@ dependents = "List the named dependents of the specified definition." $ \case [thing] -> Input.ListDependentsI <$> handleHashQualifiedNameArg thing - _ -> Left (I.help dependents) + args -> wrongArgsLength "exactly one argument" args dependencies = InputPattern "dependencies" @@ -2573,7 +2718,7 @@ dependencies = "List the dependencies of the specified definition." $ \case [thing] -> Input.ListDependenciesI <$> handleHashQualifiedNameArg thing - _ -> Left (I.help dependencies) + args -> wrongArgsLength "exactly one argument" args namespaceDependencies :: InputPattern namespaceDependencies = @@ -2586,7 +2731,7 @@ namespaceDependencies = $ \case [p] -> Input.NamespaceDependenciesI . pure <$> handlePath'Arg p [] -> pure (Input.NamespaceDependenciesI Nothing) - _ -> Left (I.help namespaceDependencies) + args -> wrongArgsLength "no more than one argument" args debugNumberedArgs :: InputPattern debugNumberedArgs = @@ -2638,7 +2783,7 @@ debugTerm = "View debugging information for a given term." ( \case [thing] -> Input.DebugTermI False <$> handleHashQualifiedNameArg thing - _ -> Left (I.help debugTerm) + args -> wrongArgsLength "exactly one argument" args ) debugTermVerbose :: InputPattern @@ -2651,7 +2796,7 @@ debugTermVerbose = "View verbose debugging information for a given term." ( \case [thing] -> Input.DebugTermI True <$> handleHashQualifiedNameArg thing - _ -> Left (I.help debugTermVerbose) + args -> wrongArgsLength "exactly one argument" args ) debugType :: InputPattern @@ -2664,7 +2809,7 @@ debugType = "View debugging information for a given type." ( \case [thing] -> Input.DebugTypeI <$> handleHashQualifiedNameArg thing - _ -> Left (I.help debugType) + args -> wrongArgsLength "exactly one argument" args ) debugLSPFoldRanges :: InputPattern @@ -2698,7 +2843,7 @@ debugDoctor = ) ( \case [] -> Right $ Input.DebugDoctorI - _ -> Left (showPatternHelp debugDoctor) + args -> wrongArgsLength "no arguments" args ) debugNameDiff :: InputPattern @@ -2711,7 +2856,7 @@ debugNameDiff = help = P.wrap "List all name changes between two causal hashes. Does not detect patch changes.", parse = \case [from, to] -> Input.DebugNameDiffI <$> handleShortCausalHashArg from <*> handleShortCausalHashArg to - _ -> Left (I.help debugNameDiff) + args -> wrongArgsLength "exactly two arguments" args } test :: InputPattern @@ -2730,6 +2875,7 @@ test = fmap ( \path -> Input.TestI + False Input.TestInput { includeLibNamespace = False, path, @@ -2740,7 +2886,39 @@ test = . \case [] -> pure Path.empty [pathString] -> handlePathArg pathString - _ -> Left $ I.help test + args -> wrongArgsLength "no more than one argument" args + } + +testNative :: InputPattern +testNative = + InputPattern + { patternName = "test.native", + aliases = [], + visibility = I.Hidden, + args = [("namespace", Optional, namespaceArg)], + help = + P.wrapColumn2 + [ ( "`test.native`", + "runs unit tests for the current branch on the native runtime" + ), + ("`test foo`", "runs unit tests for the current branch defined in namespace `foo` on the native runtime") + ], + parse = + fmap + ( \path -> + Input.TestI + True + Input.TestInput + { includeLibNamespace = False, + path, + showFailures = True, + showSuccesses = True + } + ) + . \case + [] -> pure Path.empty + [pathString] -> handlePathArg pathString + args -> wrongArgsLength "no more than one argument" args } testAll :: InputPattern @@ -2754,6 +2932,27 @@ testAll = ( const $ pure $ Input.TestI + False + Input.TestInput + { includeLibNamespace = True, + path = Path.empty, + showFailures = True, + showSuccesses = True + } + ) + +testAllNative :: InputPattern +testAllNative = + InputPattern + "test.native.all" + ["test.all.native"] + I.Hidden + [] + "`test.native.all` runs unit tests for the current branch (including the `lib` namespace) on the native runtime." + ( const $ + pure $ + Input.TestI + True Input.TestInput { includeLibNamespace = True, path = Path.empty, @@ -2768,20 +2967,22 @@ docsToHtml = "docs.to-html" [] I.Visible - [("namespace", Required, namespaceArg), ("", Required, filePathArg)] + [("namespace", Required, branchRelativePathArg), ("", Required, filePathArg)] ( P.wrapColumn2 - [ ( "`docs.to-html .path.to.namespace ~/path/to/file/output`", - "Render all docs contained within a namespace, no matter how deep," - <> "to html files on a file path" + [ ( makeExample docsToHtml [".path.to.ns", "doc-dir"], + "Render all docs contained within the namespace `.path.to.ns`, no matter how deep, to html files in `doc-dir` in the directory UCM was run from." + ), + ( makeExample docsToHtml ["project0/branch0:a.path", "/tmp/doc-dir"], + "Renders all docs anywhere in the namespace `a.path` from `branch0` of `project0` to html in `/tmp/doc-dir`." ) ] ) \case [namespacePath, destinationFilePath] -> Input.DocsToHtmlI - <$> handlePath'Arg namespacePath - <*> unsupportedStructuredArgument "a file name" destinationFilePath - _ -> Left $ showPatternHelp docsToHtml + <$> handleBranchRelativePathArg namespacePath + <*> unsupportedStructuredArgument docsToHtml "a file name" destinationFilePath + args -> wrongArgsLength "exactly two arguments" args docToMarkdown :: InputPattern docToMarkdown = @@ -2798,7 +2999,7 @@ docToMarkdown = ) \case [docNameText] -> Input.DocToMarkdownI <$> handleNameArg docNameText - _ -> Left $ showPatternHelp docToMarkdown + args -> wrongArgsLength "exactly one argument" args execute :: InputPattern execute = @@ -2820,8 +3021,8 @@ execute = main : args -> Input.ExecuteI <$> handleHashQualifiedNameArg main - <*> traverse (unsupportedStructuredArgument "a command-line argument") args - _ -> Left $ showPatternHelp execute + <*> traverse (unsupportedStructuredArgument execute "a command-line argument") args + [] -> wrongArgsLength "at least one argument" [] saveExecuteResult :: InputPattern saveExecuteResult = @@ -2835,7 +3036,7 @@ saveExecuteResult = ) $ \case [w] -> Input.SaveExecuteResultI <$> handleNameArg w - _ -> Left $ showPatternHelp saveExecuteResult + args -> wrongArgsLength "exactly one argument" args ioTest :: InputPattern ioTest = @@ -2851,8 +3052,28 @@ ioTest = ) ], parse = \case - [thing] -> Input.IOTestI <$> handleHashQualifiedNameArg thing - _ -> Left $ showPatternHelp ioTest + [thing] -> Input.IOTestI False <$> handleHashQualifiedNameArg thing + args -> wrongArgsLength "exactly one argument" args + } + +ioTestNative :: InputPattern +ioTestNative = + InputPattern + { patternName = "io.test.native", + aliases = ["test.io.native", "test.native.io"], + visibility = I.Hidden, + args = [("test to run", Required, exactDefinitionTermQueryArg)], + help = + P.wrapColumn2 + [ ( "`io.test.native mytest`", + "Runs `!mytest` on the native runtime, where `mytest` " + <> "is a delayed test that can use the `IO` and " + <> "`Exception` abilities." + ) + ], + parse = \case + [thing] -> Input.IOTestI True <$> handleHashQualifiedNameArg thing + args -> wrongArgsLength "exactly one argument" args } ioTestAll :: InputPattern @@ -2869,8 +3090,26 @@ ioTestAll = ) ], parse = \case - [] -> Right Input.IOTestAllI - _ -> Left $ showPatternHelp ioTest + [] -> Right (Input.IOTestAllI False) + args -> wrongArgsLength "no arguments" args + } + +ioTestAllNative :: InputPattern +ioTestAllNative = + InputPattern + { patternName = "io.test.native.all", + aliases = ["test.io.native.all", "test.native.io.all"], + visibility = I.Hidden, + args = [], + help = + P.wrapColumn2 + [ ( "`io.test.native.all`", + "runs unit tests for the current branch that use IO" + ) + ], + parse = \case + [] -> Right (Input.IOTestAllI True) + args -> wrongArgsLength "no arguments" args } makeStandalone :: InputPattern @@ -2891,9 +3130,9 @@ makeStandalone = $ \case [main, file] -> Input.MakeStandaloneI - <$> unsupportedStructuredArgument "a file name" file + <$> unsupportedStructuredArgument makeStandalone "a file name" file <*> handleHashQualifiedNameArg main - _ -> Left $ showPatternHelp makeStandalone + args -> wrongArgsLength "exactly two arguments" args runScheme :: InputPattern runScheme = @@ -2912,8 +3151,8 @@ runScheme = main : args -> Input.ExecuteSchemeI <$> handleHashQualifiedNameArg main - <*> traverse (unsupportedStructuredArgument "a command-line argument") args - _ -> Left $ showPatternHelp runScheme + <*> traverse (unsupportedStructuredArgument runScheme "a command-line argument") args + [] -> wrongArgsLength "at least one argument" [] compileScheme :: InputPattern compileScheme = @@ -2921,21 +3160,37 @@ compileScheme = "compile.native" [] I.Hidden - [("definition to compile", Required, exactDefinitionTermQueryArg), ("output file", Required, filePathArg)] + [ ("definition to compile", Required, exactDefinitionTermQueryArg), + ("output file", Required, filePathArg), + ("profile", Optional, profileArg) + ] ( P.wrapColumn2 - [ ( makeExample compileScheme ["main", "file"], + [ ( makeExample compileScheme ["main", "file", "profile"], "Creates stand alone executable via compilation to" <> "scheme. The created executable will have the effect" - <> "of running `!main`." + <> "of running `!main`. Providing `profile` as a third" + <> "argument will enable profiling." ) ] ) $ \case - [main, file] -> - Input.CompileSchemeI . Text.pack - <$> unsupportedStructuredArgument "a file name" file - <*> handleHashQualifiedNameArg main - _ -> Left $ showPatternHelp compileScheme + [main, file] -> mkCompileScheme False file main + [main, file, prof] -> do + unsupportedStructuredArgument compileScheme "profile" prof + >>= \case + "profile" -> mkCompileScheme True file main + parg -> + Left . P.text $ + "I expected the third argument to be `profile`, but" + <> " instead recieved `" + <> Text.pack parg + <> "`." + args -> wrongArgsLength "two or three arguments" args + where + mkCompileScheme pf fn mn = + Input.CompileSchemeI pf . Text.pack + <$> unsupportedStructuredArgument compileScheme "a file name" fn + <*> handleHashQualifiedNameArg mn createAuthor :: InputPattern createAuthor = @@ -2959,8 +3214,10 @@ createAuthor = symbolStr : authorStr@(_ : _) -> Input.CreateAuthorI <$> handleRelativeNameSegmentArg symbolStr - <*> fmap (parseAuthorName . unwords) (traverse (unsupportedStructuredArgument "text") authorStr) - _ -> Left $ showPatternHelp createAuthor + <*> fmap + (parseAuthorName . unwords) + (traverse (unsupportedStructuredArgument createAuthor "text") authorStr) + args -> wrongArgsLength "at least two arguments" args where -- let's have a real parser in not too long parseAuthorName :: String -> Text @@ -2984,7 +3241,7 @@ authLogin = ) ( \case [] -> Right $ Input.AuthLoginI - _ -> Left (showPatternHelp authLogin) + args -> wrongArgsLength "no arguments" args ) printVersion :: InputPattern @@ -2998,7 +3255,7 @@ printVersion = ) ( \case [] -> Right $ Input.VersionI - _ -> Left (showPatternHelp printVersion) + args -> wrongArgsLength "no arguments" args ) projectCreate :: InputPattern @@ -3016,7 +3273,7 @@ projectCreate = parse = \case [] -> pure $ Input.ProjectCreateI True Nothing [name] -> Input.ProjectCreateI True . pure <$> handleProjectArg name - _ -> Left $ showPatternHelp projectCreate + args -> wrongArgsLength "no more than one argument" args } projectCreateEmptyInputPattern :: InputPattern @@ -3034,7 +3291,7 @@ projectCreateEmptyInputPattern = parse = \case [] -> pure $ Input.ProjectCreateI False Nothing [name] -> Input.ProjectCreateI False . pure <$> handleProjectArg name - _ -> Left $ showPatternHelp projectCreateEmptyInputPattern + args -> wrongArgsLength "no more than one argument" args } projectRenameInputPattern :: InputPattern @@ -3050,7 +3307,7 @@ projectRenameInputPattern = ], parse = \case [nameString] -> Input.ProjectRenameI <$> handleProjectArg nameString - _ -> Left (showPatternHelp projectRenameInputPattern) + args -> wrongArgsLength "exactly one argument" args } projectSwitch :: InputPattern @@ -3069,7 +3326,7 @@ projectSwitch = ], parse = \case [name] -> Input.ProjectSwitchI <$> handleProjectAndBranchNamesArg name - _ -> Left (showPatternHelp projectSwitch) + args -> wrongArgsLength "exactly one argument" args } where suggestionsConfig = @@ -3105,7 +3362,7 @@ branchesInputPattern = parse = \case [] -> Right (Input.BranchesI Nothing) [nameString] -> Input.BranchesI . pure <$> handleProjectArg nameString - _ -> Left (showPatternHelp branchesInputPattern) + args -> wrongArgsLength "no more than one argument" args } branchInputPattern :: InputPattern @@ -3121,16 +3378,15 @@ branchInputPattern = help = P.wrapColumn2 [ ("`branch foo`", "forks the current project branch to a new branch `foo`"), - ("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`"), - ("`branch .bar foo`", "forks the path `.bar` of the current project to a new branch `foo`") + ("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`") ], parse = \case [source0, name] -> - Input.BranchI . Input.BranchSourceI'LooseCodeOrProject - <$> handleLooseCodeOrProjectArg source0 + Input.BranchI . Input.BranchSourceI'UnresolvedProjectBranch + <$> handleMaybeProjectBranchArg source0 <*> handleMaybeProjectBranchArg name [name] -> Input.BranchI Input.BranchSourceI'CurrentContext <$> handleMaybeProjectBranchArg name - _ -> Left $ showPatternHelp branchInputPattern + args -> wrongArgsLength "one or two arguments" args } where newBranchNameArg = @@ -3158,7 +3414,7 @@ branchEmptyInputPattern = [name] -> Input.BranchI Input.BranchSourceI'Empty <$> handleMaybeProjectBranchArg name - _ -> Left (showPatternHelp branchEmptyInputPattern) + args -> wrongArgsLength "exactly one argument" args } branchRenameInputPattern :: InputPattern @@ -3173,7 +3429,7 @@ branchRenameInputPattern = [("`branch.rename foo`", "renames the current branch to `foo`")], parse = \case [name] -> Input.BranchRenameI <$> handleProjectBranchNameArg name - _ -> Left (showPatternHelp branchRenameInputPattern) + args -> wrongArgsLength "exactly one argument" args } clone :: InputPattern @@ -3211,7 +3467,7 @@ clone = Input.CloneI <$> handleProjectAndBranchNamesArg remoteNames <*> fmap pure (handleProjectAndBranchNamesArg localNames) - _ -> Left $ showPatternHelp clone + args -> wrongArgsLength "one or two arguments" args } releaseDraft :: InputPattern @@ -3227,8 +3483,8 @@ releaseDraft = bimap (const "Couldn’t parse version number") Input.ReleaseDraftI . tryInto @Semver . Text.pack - =<< unsupportedStructuredArgument "a version number" semverString - _ -> Left (showPatternHelp releaseDraft) + =<< unsupportedStructuredArgument releaseDraft "a version number" semverString + args -> wrongArgsLength "exactly one argument" args } upgrade :: InputPattern @@ -3244,7 +3500,7 @@ upgrade = parse = \case [oldString, newString] -> Input.UpgradeI <$> handleRelativeNameSegmentArg oldString <*> handleRelativeNameSegmentArg newString - _ -> Left $ I.help upgrade + args -> wrongArgsLength "exactly two arguments" args } upgradeCommitInputPattern :: InputPattern @@ -3286,7 +3542,20 @@ upgradeCommitInputPattern = ), parse = \case [] -> Right Input.UpgradeCommitI - _ -> Left (I.help upgradeCommitInputPattern) + args -> wrongArgsLength "no arguments" args + } + +debugSynhashTermInputPattern :: InputPattern +debugSynhashTermInputPattern = + InputPattern + { patternName = "debug.synhash.term", + aliases = [], + visibility = I.Hidden, + args = [("term", Required, exactDefinitionTermQueryArg)], + help = mempty, + parse = \case + [arg] -> Input.DebugSynhashTermI <$> handleNameArg arg + args -> wrongArgsLength "exactly one argument" args } validInputs :: [InputPattern] @@ -3309,10 +3578,13 @@ validInputs = clone, compileScheme, createAuthor, + debugAliasTermForce, + debugAliasTypeForce, debugClearWatchCache, debugDoctor, debugDumpNamespace, debugDumpNamespaceSimple, + debugSynhashTermInputPattern, debugTerm, debugTermVerbose, debugType, @@ -3321,6 +3593,7 @@ validInputs = debugNameDiff, debugNumberedArgs, debugTabCompletion, + debugLspNameCompletion, debugFuzzyOptions, debugFormat, delete, @@ -3342,7 +3615,9 @@ validInputs = docs, docsToHtml, edit, + editDependents, editNamespace, + editNew, execute, find, findIn, @@ -3354,12 +3629,16 @@ validInputs = findVerboseAll, sfind, sfindReplace, + textfind False, + textfind True, forkLocal, help, helpTopics, history, ioTest, + ioTestNative, ioTestAll, + ioTestAllNative, libInstallInputPattern, load, makeStandalone, @@ -3371,7 +3650,7 @@ validInputs = mergeInputPattern, mergeCommitInputPattern, names False, -- names - names True, -- names.global + names True, -- debug.names.global namespaceDependencies, previewAdd, previewUpdate, @@ -3394,11 +3673,12 @@ validInputs = renameType, moveAll, reset, - resetRoot, runScheme, saveExecuteResult, test, + testNative, testAll, + testAllNative, todo, ui, undo, @@ -3411,7 +3691,10 @@ validInputs = upgradeCommitInputPattern, view, viewGlobal, - viewReflog + deprecatedViewRootReflog, + branchReflog, + projectReflog, + globalReflog ] -- | A map of all command patterns by pattern name or alias. @@ -3493,7 +3776,7 @@ namespaceOrProjectBranchArg config = ArgumentType { typeName = "namespace or branch", suggestions = - let namespaceSuggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteNamespace q p) + let namespaceSuggestions = \q cb _http pp -> Codebase.runTransaction cb (prefixCompleteNamespace q pp) in unionSuggestions [ projectAndOrBranchSuggestions config, namespaceSuggestions @@ -3519,8 +3802,8 @@ dependencyArg :: ArgumentType dependencyArg = ArgumentType { typeName = "project dependency", - suggestions = \q cb _http p -> Codebase.runTransaction cb do - prefixCompleteNamespace q (p Path.:> NameSegment.libSegment), + suggestions = \q cb _http pp -> Codebase.runTransaction cb do + prefixCompleteNamespace q (pp & PP.path_ .~ Path.singleton NameSegment.libSegment), fzfResolver = Just Resolvers.projectDependencyResolver } @@ -3557,6 +3840,15 @@ remoteNamespaceArg = fzfResolver = Nothing } +profileArg :: ArgumentType +profileArg = + ArgumentType + { typeName = "profile", + suggestions = \_input _cb _http _p -> + pure [Line.simpleCompletion "profile"], + fzfResolver = Nothing + } + data ProjectInclusion = OnlyWithinCurrentProject | OnlyOutsideCurrentProject | AllProjects deriving stock (Eq, Ord, Show) @@ -3579,14 +3871,14 @@ projectAndOrBranchSuggestions :: String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> -- Current path + ProjectPath -> m [Line.Completion] -projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do +projectAndOrBranchSuggestions config inputStr codebase _httpClient pp = do case Text.uncons input of -- Things like "/foo" would be parsed as unambiguous branches in the logic below, except we also want to -- handle "/" and "/@" inputs, which aren't valid branch names, but are valid branch prefixes. So, -- if the input begins with a forward slash, just rip it off and treat the rest as the branch prefix. - Just ('/', input1) -> handleBranchesComplete input1 codebase path + Just ('/', input1) -> handleBranchesComplete input1 codebase pp _ -> case tryInto @ProjectAndBranchNames input of -- This case handles inputs like "", "@", and possibly other things that don't look like a valid project @@ -3607,12 +3899,12 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do Nothing -> pure [] Just project -> do let projectId = project ^. #projectId - fmap (filterBranches config path) do + fmap (filterBranches config pp) do Queries.loadAllProjectBranchesBeginningWith projectId Nothing pure (map (projectBranchToCompletion projectName) branches) -- This branch is probably dead due to intercepting inputs that begin with "/" above Right (ProjectAndBranchNames'Unambiguous (That branchName)) -> - handleBranchesComplete (into @Text branchName) codebase path + handleBranchesComplete (into @Text branchName) codebase pp Right (ProjectAndBranchNames'Unambiguous (These projectName branchName)) -> do branches <- Codebase.runTransaction codebase do @@ -3620,16 +3912,12 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do Nothing -> pure [] Just project -> do let projectId = project ^. #projectId - fmap (filterBranches config path) do + fmap (filterBranches config pp) do Queries.loadAllProjectBranchesBeginningWith projectId (Just $ into @Text branchName) pure (map (projectBranchToCompletion projectName) branches) where input = Text.strip . Text.pack $ inputStr - (mayCurrentProjectId, _mayCurrentBranchId) = case projectContextFromPath path of - LooseCodePath {} -> (Nothing, Nothing) - ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) - handleAmbiguousComplete :: (MonadIO m) => Text -> @@ -3639,14 +3927,10 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do (branches, projects) <- Codebase.runTransaction codebase do branches <- - case mayCurrentProjectId of - Nothing -> pure [] - Just currentProjectId -> - fmap (filterBranches config path) do - Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input) - projects <- case (projectInclusion config, mayCurrentProjectId) of - (OnlyWithinCurrentProject, Just currentProjectId) -> Queries.loadProject currentProjectId <&> maybeToList - (OnlyWithinCurrentProject, Nothing) -> pure [] + fmap (filterBranches config pp) do + Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input) + projects <- case projectInclusion config of + OnlyWithinCurrentProject -> Queries.loadProject currentProjectId <&> maybeToList _ -> Queries.loadAllProjectsBeginningWith (Just input) <&> filterProjects pure (branches, projects) let branchCompletions = map currentProjectBranchToCompletion branches @@ -3720,28 +4004,28 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do then projectCompletions else branchCompletions ++ projectCompletions - handleBranchesComplete :: (MonadIO m) => Text -> Codebase m v a -> Path.Absolute -> m [Completion] - handleBranchesComplete branchName codebase path = do + -- Complete the text into a branch name within the provided project + handleBranchesComplete :: (MonadIO m) => Text -> Codebase m v a -> PP.ProjectPath -> m [Completion] + handleBranchesComplete branchName codebase pp = do + let projId = pp ^. #project . #projectId branches <- - case preview ProjectUtils.projectBranchPathPrism path of - Nothing -> pure [] - Just (ProjectAndBranch currentProjectId _, _) -> - Codebase.runTransaction codebase do - fmap (filterBranches config path) do - Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName) + Codebase.runTransaction codebase do + fmap (filterBranches config pp) do + Queries.loadAllProjectBranchesBeginningWith projId (Just branchName) pure (map currentProjectBranchToCompletion branches) filterProjects :: [Sqlite.Project] -> [Sqlite.Project] filterProjects projects = - case (mayCurrentProjectId, projectInclusion config) of - (_, AllProjects) -> projects - (Nothing, _) -> projects - (Just currentProjId, OnlyOutsideCurrentProject) -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjId) - (Just currentBranchId, OnlyWithinCurrentProject) -> + case (projectInclusion config) of + AllProjects -> projects + OnlyOutsideCurrentProject -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjectId) + OnlyWithinCurrentProject -> projects - & List.find (\Sqlite.Project {projectId} -> projectId == currentBranchId) + & List.find (\Sqlite.Project {projectId} -> projectId == currentProjectId) & maybeToList + PP.ProjectPath currentProjectId _currentBranchId _currentPath = PP.toIds pp + projectToCompletion :: Sqlite.Project -> Completion projectToCompletion project = Completion @@ -3765,28 +4049,22 @@ handleBranchesComplete :: ProjectBranchSuggestionsConfig -> Text -> Codebase m v a -> - Path.Absolute -> + PP.ProjectPath -> m [Completion] -handleBranchesComplete config branchName codebase path = do +handleBranchesComplete config branchName codebase pp = do branches <- - case preview ProjectUtils.projectBranchPathPrism path of - Nothing -> pure [] - Just (ProjectAndBranch currentProjectId _, _) -> - Codebase.runTransaction codebase do - fmap (filterBranches config path) do - Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName) + Codebase.runTransaction codebase do + fmap (filterBranches config pp) do + Queries.loadAllProjectBranchesBeginningWith (pp ^. #project . #projectId) (Just branchName) pure (map currentProjectBranchToCompletion branches) -filterBranches :: ProjectBranchSuggestionsConfig -> Path.Absolute -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)] -filterBranches config path branches = - case (mayCurrentBranchId, branchInclusion config) of - (_, AllBranches) -> branches - (Nothing, _) -> branches - (Just currentBranchId, ExcludeCurrentBranch) -> branches & filter (\(branchId, _) -> branchId /= currentBranchId) +filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)] +filterBranches config pp branches = + case (branchInclusion config) of + AllBranches -> branches + ExcludeCurrentBranch -> branches & filter (\(branchId, _) -> branchId /= currentBranchId) where - (_mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath path of - LooseCodePath {} -> (Nothing, Nothing) - ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) + currentBranchId = pp ^. #branch . #branchId currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion currentProjectBranchToCompletion (_, branchName) = @@ -3802,22 +4080,22 @@ branchRelativePathSuggestions :: String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> -- Current path + PP.ProjectPath -> m [Line.Completion] -branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = do +branchRelativePathSuggestions config inputStr codebase _httpClient pp = do case parseIncrementalBranchRelativePath inputStr of Left _ -> pure [] Right ibrp -> case ibrp of - BranchRelativePath.ProjectOrRelative _txt _path -> do - namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath) + BranchRelativePath.ProjectOrPath' _txt _path -> do + namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp) projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase pure (namespaceSuggestions ++ projectSuggestions) - BranchRelativePath.LooseCode _path -> - Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath) + BranchRelativePath.OnlyPath' _path -> + Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp) BranchRelativePath.IncompleteProject _proj -> projectNameSuggestions WithSlash inputStr codebase BranchRelativePath.IncompleteBranch mproj mbranch -> case mproj of - Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase currentPath + Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase pp Just projectName -> do branches <- Codebase.runTransaction codebase do @@ -3825,40 +4103,15 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = Nothing -> pure [] Just project -> do let projectId = project ^. #projectId - fmap (filterBranches config currentPath) do + fmap (filterBranches config pp) do Queries.loadAllProjectBranchesBeginningWith projectId (into @Text <$> mbranch) pure (map (projectBranchToCompletionWithSep projectName) branches) - BranchRelativePath.PathRelativeToCurrentBranch relPath -> Codebase.runTransaction codebase do - mprojectBranch <- runMaybeT do - (projectId, branchId) <- MaybeT (pure $ (,) <$> mayCurrentProjectId <*> mayCurrentBranchId) - MaybeT (Queries.loadProjectBranch projectId branchId) - case mprojectBranch of - Nothing -> pure [] - Just projectBranch -> do - let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty) - projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId) - map prefixPathSep <$> prefixCompleteNamespace (Path.convert relPath) branchPath + BranchRelativePath.PathRelativeToCurrentBranch absPath -> Codebase.runTransaction codebase do + map prefixPathSep <$> prefixCompleteNamespace (Text.unpack . Path.toText' $ Path.AbsolutePath' absPath) pp BranchRelativePath.IncompletePath projStuff mpath -> do Codebase.runTransaction codebase do - mprojectBranch <- runMaybeT do - case projStuff of - Left names@(ProjectAndBranch projectName branchName) -> do - (,Left names) <$> MaybeT (Queries.loadProjectBranchByNames projectName branchName) - Right branchName -> do - currentProjectId <- MaybeT (pure mayCurrentProjectId) - projectBranch <- MaybeT (Queries.loadProjectBranchByName currentProjectId branchName) - pure (projectBranch, Right (projectBranch ^. #name)) - case mprojectBranch of - Nothing -> pure [] - Just (projectBranch, prefix) -> do - let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty) - projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId) - map (addBranchPrefix prefix) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) branchPath + map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" (Text.unpack . Path.toText' . Path.AbsolutePath') mpath) pp where - (mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath currentPath of - LooseCodePath {} -> (Nothing, Nothing) - ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) - projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion projectBranchToCompletionWithSep projectName (_, branchName) = Completion @@ -3983,12 +4236,11 @@ projectNameSuggestions slash (Text.strip . Text.pack -> input) codebase = do parsePushSource :: String -> Maybe Input.PushSource parsePushSource sourceStr = fixup Input.ProjySource (tryFrom $ Text.pack sourceStr) - <|> fixup Input.PathySource (Path.parsePath' sourceStr) where fixup = either (const Nothing) . (pure .) -- | Parse a push target. -parsePushTarget :: String -> Maybe (WriteRemoteNamespace (These ProjectName ProjectBranchName)) +parsePushTarget :: String -> Maybe (These ProjectName ProjectBranchName) parsePushTarget = Megaparsec.parseMaybe UriParser.writeRemoteNamespace . Text.pack parseHashQualifiedName :: @@ -3996,7 +4248,6 @@ parseHashQualifiedName :: parseHashQualifiedName s = maybe ( Left - . P.warnCallout . P.wrap $ P.string s <> " is not a well-formed name, hash, or hash-qualified name. " diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 451ec731ba..3b86508eb0 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -6,10 +6,12 @@ where import Compat (withInterruptHandler) import Control.Concurrent.Async qualified as Async import Control.Exception (catch, displayException, finally, mask) -import Control.Lens (preview, (?~)) +import Control.Lens ((?~)) +import Control.Lens.Lens import Crypto.Random qualified as Random -import Data.Configurator.Types (Config) import Data.IORef +import Data.List.NonEmpty qualified as NEL +import Data.List.NonEmpty qualified as NonEmpty import Data.Text qualified as Text import Data.Text.IO qualified as Text import Ki qualified @@ -18,24 +20,21 @@ import System.Console.Haskeline qualified as Line import System.Console.Haskeline.History qualified as Line import System.IO (hGetEcho, hPutStrLn, hSetEcho, stderr, stdin) import System.IO.Error (isDoesNotExistError) -import U.Codebase.HashTags (CausalHash) -import U.Codebase.Sqlite.Operations qualified as Operations -import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Auth.CredentialManager (newCredentialManager) import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Auth.HTTPClient qualified as AuthN import Unison.Auth.Tokens qualified as AuthN import Unison.Cli.Monad qualified as Cli -import Unison.Cli.Pretty (prettyProjectAndBranchName) -import Unison.Cli.ProjectUtils (projectBranchPathPrism) +import Unison.Cli.Pretty qualified as P +import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase -import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Branch (Branch) import Unison.Codebase.Editor.HandleInput qualified as HandleInput import Unison.Codebase.Editor.Input (Event, Input (..)) import Unison.Codebase.Editor.Output (NumberedArgs, Output) import Unison.Codebase.Editor.UCMVersion (UCMVersion) -import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime qualified as Runtime import Unison.CommandLine import Unison.CommandLine.Completion (haskelineTabComplete) @@ -46,9 +45,10 @@ import Unison.CommandLine.Welcome qualified as Welcome import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal -import Unison.Project (ProjectAndBranch (..)) import Unison.Runtime.IOSource qualified as IOSource import Unison.Server.CodebaseServer qualified as Server +import Unison.Share.Codeserver (isCustomCodeserver) +import Unison.Share.Codeserver qualified as Codeserver import Unison.Symbol (Symbol) import Unison.Syntax.Parser qualified as Parser import Unison.Util.Pretty qualified as P @@ -60,10 +60,11 @@ import UnliftIO.STM getUserInput :: Codebase IO Symbol Ann -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> + IO (Branch IO) -> NumberedArgs -> IO Input -getUserInput codebase authHTTPClient currentPath numberedArgs = +getUserInput codebase authHTTPClient pp currentProjectRoot numberedArgs = Line.runInputT settings (haskelineCtrlCHandling go) @@ -76,33 +77,24 @@ getUserInput codebase authHTTPClient currentPath numberedArgs = Line.handleInterrupt (pure Nothing) (Line.withInterrupt (Just <$> act)) >>= \case Nothing -> haskelineCtrlCHandling act Just a -> pure a + + codeserverPrompt :: String + codeserverPrompt = + if isCustomCodeserver Codeserver.defaultCodeserver + then "🌐" <> Codeserver.codeserverRegName Codeserver.defaultCodeserver <> maybe "" (":" <>) (show <$> Codeserver.codeserverPort Codeserver.defaultCodeserver) <> "\n" + else "" + go :: Line.InputT IO Input go = do - promptString <- - case preview projectBranchPathPrism currentPath of - Nothing -> pure ((P.green . P.shown) currentPath) - Just (ProjectAndBranch projectId branchId, restPath) -> do - lift (Codebase.runTransaction codebase (Queries.loadProjectAndBranchNames projectId branchId)) <&> \case - -- If the project branch has been deleted from sqlite, just show a borked prompt - Nothing -> P.red "???" - Just (projectName, branchName) -> - P.sep - " " - ( catMaybes - [ Just (prettyProjectAndBranchName (ProjectAndBranch projectName branchName)), - case restPath of - Path.Empty -> Nothing - _ -> (Just . P.green . P.shown) restPath - ] - ) - let fullPrompt = P.toANSI 80 (promptString <> fromString prompt) + let promptString = P.prettyProjectPath pp + let fullPrompt = P.toANSI 80 (P.red (P.string codeserverPrompt) <> promptString <> fromString prompt) line <- Line.getInputLine fullPrompt case line of Nothing -> pure QuitI Just l -> case words l of [] -> go ws -> do - liftIO (parseInput codebase currentPath numberedArgs IP.patternMap ws) >>= \case + liftIO (parseInput codebase pp currentProjectRoot numberedArgs IP.patternMap ws) >>= \case Left msg -> do -- We still add history that failed to parse so the user can easily reload -- the input and fix it. @@ -126,13 +118,20 @@ getUserInput codebase authHTTPClient currentPath numberedArgs = historyFile = Just ".unisonHistory", autoAddHistory = False } - tabComplete = haskelineTabComplete IP.patternMap codebase authHTTPClient currentPath + tabComplete = haskelineTabComplete IP.patternMap codebase authHTTPClient pp + +loopStateProjectPath :: + Codebase IO Symbol Ann -> + Cli.LoopState -> + IO PP.ProjectPath +loopStateProjectPath codebase loopState = do + let ppIds = NEL.head $ Cli.projectPathStack loopState + ppIds & PP.projectAndBranch_ %%~ \pabIds -> liftIO . Codebase.runTransaction codebase $ ProjectUtils.expectProjectAndBranchByIds pabIds main :: FilePath -> Welcome.Welcome -> - Path.Absolute -> - Config -> + PP.ProjectPathIds -> [Either Event Input] -> Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> @@ -140,38 +139,18 @@ main :: Codebase IO Symbol Ann -> Maybe Server.BaseUrl -> UCMVersion -> - (CausalHash -> STM ()) -> - (Path.Absolute -> STM ()) -> + (PP.ProjectPathIds -> IO ()) -> ShouldWatchFiles -> IO () -main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime codebase serverBaseUrl ucmVersion notifyBranchChange notifyPathChange shouldWatchFiles = Ki.scoped \scope -> do - rootVar <- newEmptyTMVarIO - initialRootCausalHash <- Codebase.runTransaction codebase Operations.expectRootCausalHash +main dir welcome ppIds initialInputs runtime sbRuntime nRuntime codebase serverBaseUrl ucmVersion lspCheckForChanges shouldWatchFiles = Ki.scoped \scope -> do _ <- Ki.fork scope do - root <- Codebase.getRootBranch codebase - atomically do - -- Try putting the root, but if someone else as already written over the root, don't - -- overwrite it. - void $ tryPutTMVar rootVar root + -- Pre-load the project root in the background so it'll be ready when a command needs it. + projectRoot <- Codebase.expectProjectBranchRoot codebase ppIds.project ppIds.branch -- Start forcing thunks in a background thread. - -- This might be overly aggressive, maybe we should just evaluate the top level but avoid - -- recursive "deep*" things. UnliftIO.concurrently_ - (UnliftIO.evaluate root) + (UnliftIO.evaluate projectRoot) (UnliftIO.evaluate IOSource.typecheckedFile) -- IOSource takes a while to compile, we should start compiling it on startup - let initialState = Cli.loopState0 initialRootCausalHash rootVar initialPath - Ki.fork_ scope do - let loop lastRoot = do - -- This doesn't necessarily notify on _every_ update, but the LSP only needs the - -- most recent version at any given time, so it's fine to skip some intermediate - -- versions. - currentRoot <- atomically do - currentRoot <- readTMVar rootVar - guard $ Just currentRoot /= lastRoot - notifyBranchChange (Branch.headHash currentRoot) - pure (Just currentRoot) - loop currentRoot - loop Nothing + let initialState = Cli.loopState0 ppIds eventQueue <- Q.newIO initialInputsRef <- newIORef $ Welcome.run welcome ++ initialInputs pageOutput <- newIORef True @@ -187,10 +166,14 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod getInput loopState = do currentEcho <- hGetEcho stdin liftIO $ restoreEcho currentEcho + let PP.ProjectAndBranch projId branchId = PP.toProjectAndBranch $ NonEmpty.head loopState.projectPathStack + let getProjectRoot = liftIO $ Codebase.expectProjectBranchRoot codebase projId branchId + pp <- loopStateProjectPath codebase loopState getUserInput codebase authHTTPClient - (loopState ^. #currentPath) + pp + getProjectRoot (loopState ^. #numberedArgs) let loadSourceFile :: Text -> IO Cli.LoadSourceResult loadSourceFile fname = @@ -234,21 +217,22 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod writeIORef pageOutput True pure x - let foldLine :: Text - foldLine = "\n\n---- Anything below this line is ignored by Unison.\n\n" - let writeSourceFile :: Text -> Text -> IO () - writeSourceFile fp contents = do + let writeSource :: Text -> Text -> Bool -> IO () + writeSource fp contents addFold = do path <- Directory.canonicalizePath (Text.unpack fp) - prependUtf8 path (contents <> foldLine) + prependUtf8 + path + if addFold + then contents <> "\n\n---- Anything below this line is ignored by Unison.\n\n" + else contents <> "\n\n" let env = Cli.Env { authHTTPClient, codebase, - config, credentialManager, loadSource = loadSourceFile, - writeSource = writeSourceFile, + writeSource, generateUniqueName = Parser.uniqueBase32Namegen <$> Random.getSystemDRG, notify, notifyNumbered = \o -> @@ -258,7 +242,8 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod sandboxedRuntime = sbRuntime, nativeRuntime = nRuntime, serverBaseUrl, - ucmVersion + ucmVersion, + isTranscriptTest = False } (onInterrupt, waitForInterrupt) <- buildInterruptHandler @@ -267,6 +252,9 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod -- Handle inputs until @HaltRepl@, staying in the loop on Ctrl+C or synchronous exception. let loop0 :: Cli.LoopState -> IO () loop0 s0 = do + -- It's always possible the previous command changed the branch head, so tell the LSP to check if the current + -- path or project has changed. + lspCheckForChanges (NEL.head $ Cli.projectPathStack s0) let step = do input <- awaitInput s0 (!result, resultState) <- Cli.runCli env s0 (HandleInput.loop input) @@ -284,7 +272,6 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod Text.hPutStrLn stderr ("Encountered exception:\n" <> Text.pack (displayException e)) loop0 s0 Right (Right (result, s1)) -> do - when ((s0 ^. #currentPath) /= (s1 ^. #currentPath :: Path.Absolute)) (atomically . notifyPathChange $ s1 ^. #currentPath) case result of Cli.Success () -> loop0 s1 Cli.Continue -> loop0 s1 diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index bd33365eed..f2d1ab61c0 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -30,6 +30,7 @@ import Servant.Client qualified as Servant import System.Console.ANSI qualified as ANSI import System.Console.Haskeline.Completion qualified as Completion import System.Directory (canonicalizePath, getHomeDirectory) +import System.Exit (ExitCode (..)) import Text.Pretty.Simple (pShowNoColor, pStringNoColor) import U.Codebase.Branch (NamespaceStats (..)) import U.Codebase.Branch.Diff (NameChanges (..)) @@ -37,14 +38,15 @@ import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Reference qualified as Reference import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog import Unison.ABT qualified as ABT import Unison.Auth.Types qualified as Auth import Unison.Builtin.Decls qualified as DD import Unison.Cli.MergeTypes (MergeSourceAndTarget (..)) import Unison.Cli.Pretty -import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.ServantClientUtils qualified as ServantClientUtils import Unison.Codebase.Editor.DisplayObject (DisplayObject (..)) +import Unison.Codebase.Editor.Input (BranchIdG (..)) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output ( CreatedProjectBranchFrom (..), @@ -53,30 +55,25 @@ import Unison.Codebase.Editor.Output Output (..), ShareError (..), TestReportStats (CachedTests, NewlyComputed), + TodoOutput, UndoFailureReason (CantUndoPastMerge, CantUndoPastStart), + todoOutputIsEmpty, ) import Unison.Codebase.Editor.Output qualified as E import Unison.Codebase.Editor.Output.BranchDiff qualified as OBD import Unison.Codebase.Editor.Output.PushPull qualified as PushPull -import Unison.Codebase.Editor.RemoteRepo (ShareUserHandle (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..)) -import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) import Unison.Codebase.Editor.StructuredArgument qualified as SA -import Unison.Codebase.Editor.TodoOutput qualified as TO import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors) -import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path qualified as Path -import Unison.Codebase.PushBehavior qualified as PushBehavior import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv -import Unison.Codebase.TermEdit qualified as TermEdit -import Unison.Codebase.TypeEdit qualified as TypeEdit -import Unison.CommandLine (bigproblem, note, tip) import Unison.CommandLine.FZFResolvers qualified as FZFResolvers +import Unison.CommandLine.Helpers (bigproblem, note, tip) import Unison.CommandLine.InputPattern (InputPattern) import Unison.CommandLine.InputPatterns (makeExample') import Unison.CommandLine.InputPatterns qualified as IP @@ -87,12 +84,12 @@ import Unison.DataDeclaration qualified as DD import Unison.Hash qualified as Hash import Unison.Hash32 (Hash32) import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.LabeledDependency as LD +import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason (..), IncoherentDeclReasons (..)) import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment qualified as NameSegment -import Unison.NameSegment.Internal (NameSegment (NameSegment)) import Unison.Names (Names (..)) import Unison.Names qualified as Names import Unison.NamesWithHistory qualified as Names @@ -101,10 +98,7 @@ import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnv.Util qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED -import Unison.PrettyTerminal - ( clearCurrentLine, - putPretty', - ) +import Unison.PrettyTerminal (clearCurrentLine, putPretty') import Unison.PrintError ( prettyParseError, prettyResolutionFailures, @@ -113,17 +107,16 @@ import Unison.PrintError renderCompilerBug, ) import Unison.Project (ProjectAndBranch (..)) -import Unison.Reference (Reference, TermReferenceId) +import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent -import Unison.Referent' qualified as Referent +import Unison.ReferentPrime qualified as Referent import Unison.Result qualified as Result import Unison.Server.Backend (ShallowListEntry (..), TypeEntry (..)) import Unison.Server.Backend qualified as Backend -import Unison.Server.SearchResult' qualified as SR' -import Unison.Share.Sync qualified as Share -import Unison.Share.Sync.Types (CodeserverTransportError (..)) +import Unison.Server.SearchResultPrime qualified as SR' +import Unison.Share.Sync.Types qualified as Share (CodeserverTransportError (..), GetCausalHashByPathError (..), PullError (..)) import Unison.Sync.Types qualified as Share import Unison.Syntax.DeclPrinter qualified as DeclPrinter import Unison.Syntax.HashQualified qualified as HQ (toText, unsafeFromVar) @@ -137,7 +130,6 @@ import Unison.Syntax.NamePrinter prettyReference, prettyReferent, prettyShortHash, - styleHashQualified, ) import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Syntax.TermPrinter qualified as TermPrinter @@ -146,6 +138,10 @@ import Unison.Term (Term) import Unison.Term qualified as Term import Unison.Type (Type) import Unison.UnisonFile qualified as UF +import Unison.Util.ColorText qualified +import Unison.Util.Conflicted (Conflicted (..)) +import Unison.Util.Defn (Defn (..)) +import Unison.Util.Defns (Defns (..)) import Unison.Util.List qualified as List import Unison.Util.Monoid (intercalateMap) import Unison.Util.Monoid qualified as Monoid @@ -174,7 +170,7 @@ renderFileName dir = P.group . P.blue . fromString <$> shortenDirectory dir notifyNumbered :: NumberedOutput -> (Pretty, NumberedArgs) notifyNumbered = \case ShowDiffNamespace oldPrefix newPrefix ppe diffOutput -> - showDiffNamespace ShowNumbers ppe oldPrefix newPrefix diffOutput + showDiffNamespace ShowNumbers ppe (either BranchAtSCH BranchAtProjectPath oldPrefix) (either BranchAtSCH BranchAtProjectPath newPrefix) diffOutput ShowDiffAfterDeleteDefinitions ppe diff -> first ( \p -> @@ -228,12 +224,14 @@ notifyNumbered = \case <> "to run the tests." <> "Or you can use" <> IP.makeExample' IP.undo - <> " or" - <> IP.makeExample' IP.viewReflog - <> " to undo the results of this merge." + <> " or use a hash from " + <> IP.makeExample' IP.branchReflog + <> " with " + <> IP.makeExample' IP.reset + <> " to reset to a previous state." ] ) - (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput) + (showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput) ShowDiffAfterMergePropagate dest' destAbs patchPath' ppe diffOutput -> first ( \p -> @@ -255,12 +253,12 @@ notifyNumbered = \case <> "to run the tests." <> "Or you can use" <> IP.makeExample' IP.undo - <> " or" - <> IP.makeExample' IP.viewReflog + <> " or use a hash from " + <> IP.makeExample' IP.branchReflog <> " to undo the results of this merge." ] ) - (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput) + (showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput) ShowDiffAfterMergePreview dest' destAbs ppe diffOutput -> first ( \p -> @@ -270,7 +268,7 @@ notifyNumbered = \case p ] ) - (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput) + (showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput) ShowDiffAfterUndo ppe diffOutput -> first (\p -> P.lines ["Here are the changes I undid", "", p]) @@ -310,7 +308,30 @@ notifyNumbered = \case ] ) (showDiffNamespace ShowNumbers ppe (absPathToBranchId bAbs) (absPathToBranchId bAbs) diff) - TodoOutput names todo -> todoOutput names todo + TestResults stats ppe _showSuccess _showFailures oksUnsorted failsUnsorted -> + let oks = Name.sortByText (HQ.toText . fst) [(name r, msgs) | (r, msgs) <- Map.toList oksUnsorted] + fails = Name.sortByText (HQ.toText . fst) [(name r, msgs) | (r, msgs) <- Map.toList failsUnsorted] + name r = PPE.termName ppe (Referent.fromTermReferenceId r) + in ( case stats of + CachedTests 0 _ -> P.callout "😶" $ "No tests to run." + CachedTests n n' | n == n' -> P.lines [cache, "", displayTestResults True oks fails] + CachedTests _n m -> + if m == 0 + then "✅ " + else + P.indentN 2 $ + P.lines ["", cache, "", displayTestResults False oks fails, "", "✅ "] + NewlyComputed -> + P.lines + [ " " <> P.bold "New test results:", + "", + displayTestResults True oks fails + ], + fmap (SA.HashQualified . fst) $ oks <> fails + ) + where + cache = P.bold "Cached test results " <> "(`help testcache` to learn more)" + Output'Todo todoOutput -> runNumbered (handleTodoOutput todoOutput) CantDeleteDefinitions ppeDecl endangerments -> ( P.warnCallout $ P.lines @@ -452,7 +473,7 @@ notifyNumbered = \case ) where switch = IP.makeExample IP.projectSwitch - AmbiguousReset sourceOfAmbiguity (ProjectAndBranch pn0 bn0, path) (ProjectAndBranch currentProject branch) -> + AmbiguousReset sourceOfAmbiguity (ProjectAndBranch _pn0 _bn0, path) (ProjectAndBranch currentProject branch) -> ( P.wrap ( openingLine <> prettyProjectAndBranchName (ProjectAndBranch currentProject branch) @@ -492,10 +513,10 @@ notifyNumbered = \case E.AmbiguousReset'Target -> \xs -> "" : xs reset = IP.makeExample IP.reset relPath0 = prettyPath path - absPath0 = review ProjectUtils.projectBranchPathPrism (ProjectAndBranch (pn0 ^. #projectId) (bn0 ^. #branchId), path) + absPath0 = Path.Absolute path ListNamespaceDependencies _ppe _path Empty -> ("This namespace has no external dependencies.", mempty) ListNamespaceDependencies ppe path' externalDependencies -> - ( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyAbsolute path') $ + ( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyProjectPath path') $ List.intersperse spacer (externalDepsTable externalDependencies), numberedArgs ) @@ -536,16 +557,17 @@ notifyNumbered = \case & Set.toList & fmap (\name -> formatNum (getNameNumber name) <> prettyName name) & P.lines + ShowProjectBranchReflog now moreToShow entries -> displayProjectBranchReflogEntries now moreToShow entries where - absPathToBranchId = Right + absPathToBranchId = BranchAtPath undoTip :: P.Pretty P.ColorText undoTip = tip $ "You can use" <> IP.makeExample' IP.undo - <> "or" - <> IP.makeExample' IP.viewReflog + <> " or use a hash from " + <> IP.makeExample' IP.branchReflog <> "to undo this change." notifyUser :: FilePath -> Output -> IO Pretty @@ -581,13 +603,13 @@ notifyUser dir = \case pure . P.warnCallout $ "The namespace " - <> prettyBranchId p0 + <> either prettySCH prettyProjectPath p0 <> " is empty. Was there a typo?" ps -> pure . P.warnCallout $ "The namespaces " - <> P.commas (prettyBranchId <$> ps) + <> P.commas (either prettySCH prettyProjectPath <$> ps) <> " are empty. Was there a typo?" LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath -> pure $ @@ -641,29 +663,6 @@ notifyUser dir = \case OutputRewrittenFile dest vs -> displayOutputRewrittenFile dest vs DisplayRendered outputLoc pp -> displayRendered outputLoc pp - TestResults stats ppe _showSuccess _showFailures oks fails -> case stats of - CachedTests 0 _ -> pure . P.callout "😶" $ "No tests to run." - CachedTests n n' - | n == n' -> - pure $ - P.lines [cache, "", displayTestResults True ppe oks fails] - CachedTests _n m -> - pure $ - if m == 0 - then "✅ " - else - P.indentN 2 $ - P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "✅ "] - NewlyComputed -> do - clearCurrentLine - pure $ - P.lines - [ " " <> P.bold "New test results:", - "", - displayTestResults True ppe oks fails - ] - where - cache = P.bold "Cached test results " <> "(`help testcache` to learn more)" TestIncrementalOutputStart ppe (n, total) r -> do putPretty' $ P.shown (total - n) @@ -803,7 +802,7 @@ notifyUser dir = \case prettyProjectAndBranchName projectAndBranch <> "is empty. There is nothing to push." CreatedNewBranch path -> pure $ - "☝️ The namespace " <> prettyAbsoluteStripProject path <> " is empty." + "☝️ The namespace " <> prettyAbsolute path <> " is empty." -- RenameOutput rootPath oldName newName r -> do -- nameChange "rename" "renamed" oldName newName r -- AliasOutput rootPath existingName newName r -> do @@ -821,9 +820,13 @@ notifyUser dir = \case DeleteEverythingConfirmation -> pure . P.warnCallout . P.lines $ [ "Are you sure you want to clear away everything?", - "You could use " - <> IP.makeExample' IP.projectCreate - <> " to switch to a new project instead." + P.wrap + ( "You could use " + <> IP.makeExample' IP.projectCreate + <> " to switch to a new project instead," + <> " or delete the current branch with " + <> IP.makeExample' IP.deleteBranch + ) ] DeleteBranchConfirmation _uniqueDeletions -> error "todo" -- let @@ -852,49 +855,24 @@ notifyUser dir = \case ] ListOfDefinitions fscope ppe detailed results -> listOfDefinitions fscope ppe detailed results - ListNames global len types terms -> - if null types && null terms - then - pure . P.callout "😶" $ - P.sepNonEmpty "\n\n" $ - [ P.wrap "I couldn't find anything by that name.", - globalTip - ] - else - pure . P.sepNonEmpty "\n\n" $ - [ formatTypes types, - formatTerms terms, - globalTip - ] - where - globalTip = - if global - then mempty - else (tip $ "Use " <> IP.makeExample (IP.names True) [] <> " to see more results.") - formatTerms tms = - P.lines . P.nonEmpty $ P.plural tms (P.blue "Term") : List.intersperse "" (go <$> tms) - where - go (ref, hqs) = - P.column2 - [ ("Hash:", P.syntaxToColor (prettyReferent len ref)), - ( "Names: ", - P.group $ - P.spaced $ - P.bold . P.syntaxToColor . prettyHashQualified' <$> List.sortBy Name.compareAlphabetical hqs - ) - ] - formatTypes types = - P.lines . P.nonEmpty $ P.plural types (P.blue "Type") : List.intersperse "" (go <$> types) - where - go (ref, hqs) = - P.column2 - [ ("Hash:", P.syntaxToColor (prettyReference len ref)), - ( "Names:", - P.group $ - P.spaced $ - P.bold . P.syntaxToColor . prettyHashQualified' <$> List.sortBy Name.compareAlphabetical hqs - ) - ] + GlobalFindBranchResults projBranchName ppe detailed results -> do + output <- listOfDefinitions Input.FindGlobal ppe detailed results + pure $ + P.lines + [ P.wrap $ "Found results in " <> P.text (into @Text projBranchName), + "", + output + ] + ListNames len types terms -> + listOfNames len types terms + GlobalListNames projectBranchName len types terms -> do + output <- listOfNames len types terms + pure $ + P.lines + [ P.wrap $ "Found results in " <> P.text (into @Text projectBranchName), + "", + output + ] -- > names foo -- Terms: -- Hash: #asdflkjasdflkjasdf @@ -994,7 +972,6 @@ notifyUser dir = \case -- defs in the codebase. In some cases it's fine for bindings to -- shadow codebase names, but you don't want it to capture them in -- the decompiled output. - let prettyBindings = P.bracket . P.lines $ P.wrap "The watch expression(s) reference these definitions:" @@ -1202,7 +1179,7 @@ notifyUser dir = \case ] where name :: Name - name = Path.unsafeToName' (HQ'.toName (Path.unsplitHQ' p)) + name = HQ'.toName $ Path.nameFromHQSplit' p qualifyTerm :: Referent -> Pretty qualifyTerm = P.syntaxToColor . prettyNamedReferent hashLen name qualifyType :: Reference -> Pretty @@ -1287,8 +1264,8 @@ notifyUser dir = \case "to make an old namespace accessible again," ), (mempty, mempty), - ( IP.makeExample IP.resetRoot [prettySCH prevSCH], - "to reset the root namespace and its history to that of the specified" + ( IP.makeExample IP.reset [prettySCH prevSCH], + "to reset the current namespace and its history to that of the specified" <> "namespace." ) ] @@ -1331,26 +1308,33 @@ notifyUser dir = \case MergeAlreadyUpToDate src dest -> pure . P.callout "😶" $ P.wrap $ - either prettyPath' prettyProjectAndBranchName dest + prettyBranchRelativePath dest <> "was already up-to-date with" - <> P.group (either prettyPath' prettyProjectAndBranchName src <> ".") + <> P.group (prettyBranchRelativePath src <> ".") MergeAlreadyUpToDate2 aliceAndBob -> pure . P.callout "😶" $ P.wrap $ prettyProjectAndBranchName aliceAndBob.alice <> "was already up-to-date with" <> P.group (prettyMergeSource aliceAndBob.bob <> ".") - MergeConflictedAliases aliceOrBob name1 name2 -> + MergeConflictedAliases aliceOrBob defn -> pure $ P.wrap "Sorry, I wasn't able to perform the merge:" <> P.newline <> P.newline <> P.wrap ( "On the merge ancestor," - <> prettyName name1 - <> "and" - <> prettyName name2 - <> "were aliases for the same definition, but on" + <> ( let (isTerm, name1, name2) = + case defn of + TermDefn (n1, n2) -> (True, n1, n2) + TypeDefn (n1, n2) -> (False, n1, n2) + in prettyName name1 + <> "and" + <> prettyName name2 + <> "were aliases for the same" + <> P.group ((if isTerm then "term" else "type") <> ",") + ) + <> "but on" <> prettyMergeSourceOrTarget aliceOrBob <> "the names have different definitions currently. I'd need just a single new definition to use in their" <> "dependents when I merge." @@ -1381,43 +1365,28 @@ notifyUser dir = \case <> P.newline <> P.newline <> P.wrap "and then try merging again." - MergeConflictedTermName name _refs -> - pure . P.wrap $ - "The term name" <> prettyName name <> "is ambiguous. Please resolve the ambiguity before merging." - MergeConflictedTypeName name _refs -> - pure . P.wrap $ - "The type name" <> prettyName name <> "is ambiguous. Please resolve the ambiguity before merging." - MergeConflictInvolvingBuiltin name -> - pure . P.lines $ - [ P.wrap "Sorry, I wasn't able to perform the merge:", - "", - P.wrap - ( "There's a merge conflict on" - <> P.group (prettyName name <> ",") - <> "but it's a builtin on one or both branches. I can't yet handle merge conflicts involving builtins." - ), - "", - P.wrap - ( "Please eliminate this conflict by updating one branch or the other, making" - <> prettyName name - <> "the same on both branches, or making neither of them a builtin, and then try the merge again." - ) - ] - MergeConstructorAlias aliceOrBob typeName conName1 conName2 -> - pure . P.lines $ - [ P.wrap "Sorry, I wasn't able to perform the merge:", - "", - P.wrap $ - "On" - <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") - <> "the type" - <> prettyName typeName - <> "has a constructor with multiple names, and I can't perform a merge in this situation:", - "", - P.indentN 2 (P.bulleted [prettyName conName1, prettyName conName2]), - "", - P.wrap "Please delete all but one name for each constructor, and then try merging again." - ] + MergeConflictInvolvingBuiltin defn -> + let (isTerm, name) = + case defn of + TermDefn n -> (True, n) + TypeDefn n -> (False, n) + in pure . P.lines $ + [ P.wrap "Sorry, I wasn't able to perform the merge:", + "", + P.wrap + ( "There's a merge conflict on" + <> (if isTerm then "term" else "type") + <> P.group (prettyName name <> ",") + <> "but it's a builtin on one or both branches. I can't yet handle merge conflicts involving builtins." + ), + "", + P.wrap + ( "Please eliminate this conflict by updating one branch or the other, making" + <> prettyName name + <> "the same on both branches, or making neither of them a builtin, and then try the merge again." + ) + ] + -- Note [DefnsInLibMessage] If you change this, also change the other similar one MergeDefnsInLib aliceOrBob -> pure . P.lines $ [ P.wrap "Sorry, I wasn't able to perform the merge:", @@ -1430,61 +1399,14 @@ notifyUser dir = \case "", P.wrap "Please move or remove it and then try merging again." ] - MergeMissingConstructorName aliceOrBob name -> - pure . P.lines $ - [ P.wrap "Sorry, I wasn't able to perform the merge:", - "", - P.wrap $ - "On" - <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") - <> "the type" - <> prettyName name - <> "has some constructors with missing names, and I can't perform a merge in this situation.", - "", - P.wrap $ - "You can use" - <> IP.makeExample IP.view [prettyName name] - <> "and" - <> IP.makeExample IP.aliasTerm ["", prettyName name <> "."] - <> "to give names to each unnamed constructor, and then try the merge again." - ] - MergeNestedDeclAlias aliceOrBob shorterName longerName -> - pure . P.wrap $ - "On" - <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") - <> "the type" - <> prettyName longerName - <> "is an alias of" - <> P.group (prettyName shorterName <> ".") - <> "I'm not able to perform a merge when a type exists nested under an alias of itself. Please separate them or" - <> "delete one copy, and then try merging again." - MergeStrayConstructor aliceOrBob name -> - pure . P.lines $ - [ P.wrap $ - "Sorry, I wasn't able to perform the merge, because I need all constructor names to be nested somewhere" - <> "beneath the corresponding type name.", - "", - P.wrap $ - "On" - <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") - <> "the constructor" - <> prettyName name - <> "is not nested beneath the corresponding type name. Please either use" - <> IP.makeExample' IP.moveAll - <> "to move it, or if it's an extra copy, you can simply" - <> IP.makeExample' IP.delete - <> "it. Then try the merge again." - ] PreviewMergeAlreadyUpToDate src dest -> pure . P.callout "😶" $ P.wrap $ - prettyNamespaceKey dest + prettyProjectPath dest <> "is already up-to-date with" - <> P.group (prettyNamespaceKey src <> ".") + <> P.group (prettyProjectPath src) DumpNumberedArgs schLength args -> pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument (pure schLength)) args - NoConflictsOrEdits -> - pure (P.okCallout "No conflicts or edits in progress.") HelpMessage pat -> pure $ IP.showPatternHelp pat NoOp -> pure $ P.string "I didn't make any changes." DumpBitBooster head map -> @@ -1523,7 +1445,13 @@ notifyUser dir = \case ListDependencies ppe lds types terms -> pure $ listDependentsOrDependencies ppe "Dependencies" "dependencies" lds types terms ListStructuredFind terms -> - pure $ listStructuredFind terms + pure $ listFind False Nothing terms + ListTextFind True terms -> + pure $ listFind True Nothing terms + ListTextFind False terms -> + pure $ listFind False (Just tip) terms + where + tip = (IP.makeExample (IP.textfind True) [] <> " will search `lib` as well.") DumpUnisonFileHashes hqLength datas effects terms -> pure . P.syntaxToColor . P.lines $ ( effects <&> \(n, r) -> @@ -1537,11 +1465,6 @@ notifyUser dir = \case <> ( terms <&> \(n, r) -> prettyHashQualified' (HQ'.take hqLength . HQ'.fromNamedReference n $ Reference.DerivedId r) ) - RefusedToPush pushBehavior path -> - (pure . P.warnCallout) case pushBehavior of - PushBehavior.ForcePush -> error "impossible: refused to push due to ForcePush?" - PushBehavior.RequireEmpty -> expectedEmptyPushDest path - PushBehavior.RequireNonEmpty -> expectedNonEmptyPushDest path GistCreated remoteNamespace -> pure $ P.lines @@ -1603,10 +1526,7 @@ notifyUser dir = \case PrintVersion ucmVersion -> pure (P.text ucmVersion) ShareError shareError -> pure (prettyShareError shareError) ViewOnShare shareRef -> - pure $ - "View it here: " <> case shareRef of - Left repoPath -> prettyShareLink repoPath - Right branchInfo -> prettyRemoteBranchInfo branchInfo + pure $ "View it here: " <> prettyRemoteBranchInfo shareRef IntegrityCheck result -> pure $ case result of NoIntegrityErrors -> "🎉 No issues detected 🎉" IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns @@ -1650,6 +1570,16 @@ notifyUser dir = \case else "" in (isCompleteTxt, P.string (Completion.replacement comp)) ) + DisplayDebugLSPNameCompletions completions -> + pure $ + P.columnNHeader + ["Matching Path", "Name", "Hash"] + ( completions <&> \(pathText, fqn, ld) -> + let ldRef = case ld of + LD.TermReferent ref -> prettyReferent 10 ref + LD.TypeReference ref -> prettyReference 10 ref + in [P.text pathText, prettyName fqn, P.syntaxToColor ldRef] + ) DebugDisplayFuzzyOptions argDesc fuzzyOptions -> pure $ P.lines @@ -1841,16 +1771,16 @@ notifyUser dir = \case <> P.newline <> P.indentN 2 (P.pshown response) Servant.FailureResponse request response -> - P.wrap "Oops, I received an unexpected status code from the server." + unexpectedServerResponse response <> P.newline <> P.newline - <> P.wrap "Here is the request." + <> P.wrap "Here is the request:" <> P.newline <> P.newline <> P.indentN 2 (P.pshown request) <> P.newline <> P.newline - <> P.wrap "Here is the full response." + <> P.wrap "Here is the full response:" <> P.newline <> P.newline <> P.indentN 2 (P.pshown response) @@ -2006,9 +1936,6 @@ notifyUser dir = \case <> P.wrap "🎉 🥳 Happy coding!" ProjectHasNoReleases projectName -> pure . P.wrap $ prettyProjectName projectName <> "has no releases." - UpdateLookingForDependents -> pure . P.wrap $ "Okay, I'm searching the branch for code that needs to be updated..." - UpdateStartTypechecking -> pure . P.wrap $ "That's done. Now I'm making sure everything typechecks..." - UpdateTypecheckingSuccess -> pure . P.wrap $ "Everything typechecks, so I'm saving the results..." UpdateTypecheckingFailure -> pure . P.wrap $ "Typechecking failed. I've updated your scratch file with the definitions that need fixing." @@ -2072,16 +1999,6 @@ notifyUser dir = \case <> P.group (P.text (NameSegment.toEscapedText new) <> ",") <> "and removed" <> P.group (P.text (NameSegment.toEscapedText old) <> ".") - LooseCodePushDeprecated -> - pure . P.warnCallout $ - P.lines $ - [ P.wrap $ "Unison Share's projects are now the new preferred way to store code, and storing code outside of a project has been deprecated.", - "", - P.wrap $ "Learn how to convert existing code into a project using this guide: ", - "https://www.unison-lang.org/docs/tooling/projects-library-migration/", - "", - "Your non-project code is still available to pull from Share, and you can pull it into a local namespace using `pull myhandle.public`" - ] MergeFailure path aliceAndBob temp -> pure $ P.lines $ @@ -2108,6 +2025,49 @@ notifyUser dir = \case "to delete the temporary branch and switch back to" <> P.group (prettyProjectBranchName aliceAndBob.alice.branch <> ".") ] + MergeFailureWithMergetool aliceAndBob temp mergetool exitCode -> + case exitCode of + ExitSuccess -> + pure $ + P.lines $ + [ P.wrap $ + "I couldn't automatically merge" + <> prettyMergeSource aliceAndBob.bob + <> "into" + <> P.group (prettyProjectAndBranchName aliceAndBob.alice <> ",") + <> "so I'm running your UCM_MERGETOOL environment variable as", + "", + P.indentN 2 (P.text mergetool), + "", + P.wrap "When you're done, you can run", + "", + P.indentN 2 (IP.makeExampleNoBackticks IP.mergeCommitInputPattern []), + "", + P.wrap $ + "to merge your changes back into" + <> prettyProjectBranchName aliceAndBob.alice.branch + <> "and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run", + "", + P.indentN 2 (IP.makeExampleNoBackticks IP.deleteBranch [prettySlashProjectBranchName temp]), + "", + P.wrap $ + "to delete the temporary branch and switch back to" + <> P.group (prettyProjectBranchName aliceAndBob.alice.branch <> ".") + ] + ExitFailure code -> + pure $ + P.lines $ + [ P.wrap $ + "I couldn't automatically merge" + <> prettyMergeSource aliceAndBob.bob + <> "into" + <> P.group (prettyProjectAndBranchName aliceAndBob.alice <> ",") + <> "so I tried to run your UCM_MERGETOOL environment variable as", + "", + P.indentN 2 (P.text mergetool), + "", + P.wrap ("but it failed with exit code" <> P.group (P.num code <> ".")) + ] MergeSuccess aliceAndBob -> pure . P.wrap $ "I merged" @@ -2136,7 +2096,7 @@ notifyUser dir = \case <> P.group (IP.makeExample IP.libInstallInputPattern [prettyProjectAndBranchName libdep] <> ".") PullIntoMissingBranch source (ProjectAndBranch maybeTargetProject targetBranch) -> pure . P.wrap $ - "I think you're wanting to merge" + "I think you want to merge" <> sourcePretty <> "into the" <> targetPretty @@ -2153,40 +2113,162 @@ notifyUser dir = \case Just targetProject -> prettyProjectAndBranchName (ProjectAndBranch targetProject targetBranch) NoMergeInProgress -> pure . P.wrap $ "It doesn't look like there's a merge in progress." - -expectedEmptyPushDest :: WriteRemoteNamespace Void -> Pretty -expectedEmptyPushDest namespace = - P.lines - [ "The remote namespace " <> prettyWriteRemoteNamespace (absurd <$> namespace) <> " is not empty.", - "", - "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" - ] - -expectedNonEmptyPushDest :: WriteRemoteNamespace Void -> Pretty -expectedNonEmptyPushDest namespace = - P.lines - [ P.wrap ("The remote namespace " <> prettyWriteRemoteNamespace (absurd <$> namespace) <> " is empty."), - "", - P.wrap ("Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?") - ] + Output'DebugSynhashTerm ref synhash filename -> + pure $ + "Hash: " + <> P.syntaxToColor (prettyReference 120 ref) + <> P.newline + <> "Synhash: " + <> prettyHash synhash + <> P.newline + <> "Synhash tokens: " + <> P.text filename + ConflictedDefn operation defn -> + pure . P.wrap $ + ( "This branch has more than one" <> case defn of + TermDefn (Conflicted name _refs) -> "term with the name" <> P.group (P.backticked (prettyName name) <> ".") + TypeDefn (Conflicted name _refs) -> "type with the name" <> P.group (P.backticked (prettyName name) <> ".") + ) + <> P.newline + <> "Please delete or rename all but one of them, then try the" + <> P.text operation + <> "again." + IncoherentDeclDuringMerge aliceOrBob reason -> + case reason of + -- Note [ConstructorAliasMessage] If you change this, also change the other similar ones + IncoherentDeclReason'ConstructorAlias typeName conName1 conName2 -> + pure . P.lines $ + [ P.wrap "Sorry, I wasn't able to perform the merge:", + "", + P.wrap $ + "On" + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> "the type" + <> prettyName typeName + <> "has a constructor with multiple names, and I can't perform a merge in this situation:", + "", + P.indentN 2 (P.bulleted [prettyName conName1, prettyName conName2]), + "", + P.wrap "Please delete all but one name for each constructor, and then try merging again." + ] + -- Note [MissingConstructorNameMessage] If you change this, also change the other similar ones + IncoherentDeclReason'MissingConstructorName name -> + pure . P.lines $ + [ P.wrap "Sorry, I wasn't able to perform the merge:", + "", + P.wrap $ + "On" + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> "the type" + <> prettyName name + <> "has some constructors with missing names, and I can't perform a merge in this situation.", + "", + P.wrap $ + "You can use" + <> IP.makeExample IP.view [prettyName name] + <> "and" + <> IP.makeExample IP.aliasTerm ["", prettyName name <> "."] + <> "to give names to each unnamed constructor, and then try the merge again." + ] + -- Note [NestedDeclAliasMessage] If you change this, also change the other similar ones + IncoherentDeclReason'NestedDeclAlias shorterName longerName -> + pure . P.wrap $ + "On" + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> "the type" + <> prettyName longerName + <> "is an alias of" + <> P.group (prettyName shorterName <> ".") + <> "I'm not able to perform a merge when a type exists nested under an alias of itself. Please separate them or" + <> "delete one copy, and then try merging again." + -- Note [StrayConstructorMessage] If you change this, also change the other similar ones + IncoherentDeclReason'StrayConstructor _typeRef name -> + pure . P.lines $ + [ P.wrap $ + "Sorry, I wasn't able to perform the merge, because I need all constructor names to be nested somewhere" + <> "beneath the corresponding type name.", + "", + P.wrap $ + "On" + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> "the constructor" + <> prettyName name + <> "is not nested beneath the corresponding type name. Please either use" + <> IP.makeExample' IP.moveAll + <> "to move it, or if it's an extra copy, you can simply" + <> IP.makeExample' IP.delete + <> "it. Then try the merge again." + ] + IncoherentDeclDuringUpdate reason -> + case reason of + -- Note [ConstructorAliasMessage] If you change this, also change the other similar ones + IncoherentDeclReason'ConstructorAlias typeName conName1 conName2 -> + pure . P.lines $ + [ P.wrap "Sorry, I wasn't able to perform the update:", + "", + P.wrap $ + "The type" + <> prettyName typeName + <> "has a constructor with multiple names, and I can't perform an update in this situation:", + "", + P.indentN 2 (P.bulleted [prettyName conName1, prettyName conName2]), + "", + P.wrap "Please delete all but one name for each constructor, and then try updating again." + ] + -- Note [MissingConstructorNameMessage] If you change this, also change the other similar ones + IncoherentDeclReason'MissingConstructorName name -> + pure . P.lines $ + [ P.wrap "Sorry, I wasn't able to perform the update:", + "", + P.wrap $ + "The type" + <> prettyName name + <> "has some constructors with missing names, and I can't perform an update in this situation.", + "", + P.wrap $ + "You can use" + <> IP.makeExample IP.view [prettyName name] + <> "and" + <> IP.makeExample IP.aliasTerm ["", prettyName name <> "."] + <> "to give names to each unnamed constructor, and then try the update again." + ] + -- Note [NestedDeclAliasMessage] If you change this, also change the other similar ones + IncoherentDeclReason'NestedDeclAlias shorterName longerName -> + pure . P.wrap $ + "The type" + <> prettyName longerName + <> "is an alias of" + <> P.group (prettyName shorterName <> ".") + <> "I'm not able to perform an update when a type exists nested under an alias of itself. Please separate" + <> "them or delete one copy, and then try updating again." + -- Note [StrayConstructorMessage] If you change this, also change the other similar ones + IncoherentDeclReason'StrayConstructor _typeRef name -> + pure . P.lines $ + [ P.wrap $ + "Sorry, I wasn't able to perform the update, because I need all constructor names to be nested somewhere" + <> "beneath the corresponding type name.", + "", + P.wrap $ + "The constructor" + <> prettyName name + <> "is not nested beneath the corresponding type name. Please either use" + <> IP.makeExample' IP.moveAll + <> "to move it, or if it's an extra copy, you can simply" + <> IP.makeExample' IP.delete + <> "it. Then try the update again." + ] + Literal message -> pure message prettyShareError :: ShareError -> Pretty prettyShareError = P.fatalCallout . \case - ShareErrorCheckAndSetPush err -> prettyCheckAndSetPushError err ShareErrorDownloadEntities err -> prettyDownloadEntitiesError err - ShareErrorFastForwardPush err -> prettyFastForwardPushError err ShareErrorGetCausalHashByPath err -> prettyGetCausalHashByPathError err ShareErrorPull err -> prettyPullError err ShareErrorTransport err -> prettyTransportError err ShareErrorUploadEntities err -> prettyUploadEntitiesError err ShareExpectedSquashedHead -> "The server failed to provide a squashed branch head when requested. Please report this as a bug to the Unison team." -prettyCheckAndSetPushError :: Share.CheckAndSetPushError -> Pretty -prettyCheckAndSetPushError = \case - Share.CheckAndSetPushError'UpdatePath repoInfo err -> prettyUpdatePathError repoInfo err - Share.CheckAndSetPushError'UploadEntities err -> prettyUploadEntitiesError err - prettyDownloadEntitiesError :: Share.DownloadEntitiesError -> Pretty prettyDownloadEntitiesError = \case Share.DownloadEntitiesNoReadPermission repoInfo -> noReadPermissionForRepo repoInfo @@ -2195,27 +2277,6 @@ prettyDownloadEntitiesError = \case Share.DownloadEntitiesProjectNotFound project -> shareProjectNotFound project Share.DownloadEntitiesEntityValidationFailure err -> prettyEntityValidationFailure err -prettyFastForwardPathError :: Share.Path -> Share.FastForwardPathError -> Pretty -prettyFastForwardPathError path = \case - Share.FastForwardPathError'InvalidParentage Share.InvalidParentage {child, parent} -> - P.lines - [ "The server detected an error in the history being pushed, please report this as a bug in ucm.", - "The history in question is the hash: " <> prettyHash32 child <> " with the ancestor: " <> prettyHash32 parent - ] - Share.FastForwardPathError'InvalidRepoInfo err repoInfo -> invalidRepoInfo err repoInfo - Share.FastForwardPathError'MissingDependencies dependencies -> needDependencies dependencies - Share.FastForwardPathError'NoHistory -> expectedNonEmptyPushDest (sharePathToWriteRemotePathShare path) - Share.FastForwardPathError'NoWritePermission path -> noWritePermissionForPath path - Share.FastForwardPathError'NotFastForward _hashJwt -> notFastForward path - Share.FastForwardPathError'UserNotFound -> shareUserNotFound (Share.pathRepoInfo path) - -prettyFastForwardPushError :: Share.FastForwardPushError -> Pretty -prettyFastForwardPushError = \case - Share.FastForwardPushError'FastForwardPath path err -> prettyFastForwardPathError path err - Share.FastForwardPushError'GetCausalHash err -> prettyGetCausalHashByPathError err - Share.FastForwardPushError'NotFastForward path -> notFastForward path - Share.FastForwardPushError'UploadEntities err -> prettyUploadEntitiesError err - prettyGetCausalHashByPathError :: Share.GetCausalHashByPathError -> Pretty prettyGetCausalHashByPathError = \case Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermissionForPath sharePath @@ -2229,21 +2290,6 @@ prettyPullError = \case Share.PullError'NoHistoryAtPath sharePath -> P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath -prettyUpdatePathError :: Share.RepoInfo -> Share.UpdatePathError -> Pretty -prettyUpdatePathError repoInfo = \case - Share.UpdatePathError'HashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash} -> - case (expectedHash, actualHash) of - (Nothing, Just _) -> expectedEmptyPushDest (sharePathToWriteRemotePathShare sharePath) - _ -> - P.wrap $ - P.text "It looks like someone modified" - <> prettySharePath sharePath - <> P.text "an instant before you. Pull and try again? 🤞" - Share.UpdatePathError'InvalidRepoInfo err repoInfo -> invalidRepoInfo err repoInfo - Share.UpdatePathError'MissingDependencies dependencies -> needDependencies dependencies - Share.UpdatePathError'NoWritePermission path -> noWritePermissionForPath path - Share.UpdatePathError'UserNotFound -> shareUserNotFound repoInfo - prettyUploadEntitiesError :: Share.UploadEntitiesError -> Pretty prettyUploadEntitiesError = \case Share.UploadEntitiesError'EntityValidationFailure validationFailureErr -> prettyEntityValidationFailure validationFailureErr @@ -2294,43 +2340,46 @@ prettyEntityValidationFailure = \case Share.NamespaceDiffType -> "namespace diff" Share.CausalType -> "causal" -prettyTransportError :: CodeserverTransportError -> Pretty +prettyTransportError :: Share.CodeserverTransportError -> Pretty prettyTransportError = \case - DecodeFailure msg resp -> + Share.DecodeFailure msg resp -> (P.lines . catMaybes) [ Just ("The server sent a response that we couldn't decode: " <> P.text msg), responseRequestId resp <&> \responseId -> P.newline <> "Request ID: " <> P.blue (P.text responseId) ] - Unauthenticated codeServerURL -> + Share.Unauthenticated codeServerURL -> P.wrap . P.lines $ [ "Authentication with this code server (" <> P.string (Servant.showBaseUrl codeServerURL) <> ") is missing or expired.", "Please run " <> makeExample' IP.authLogin <> "." ] - PermissionDenied msg -> P.hang "Permission denied:" (P.text msg) - UnreachableCodeserver codeServerURL -> + Share.PermissionDenied msg -> P.hang "Permission denied:" (P.text msg) + Share.UnreachableCodeserver codeServerURL -> P.lines $ [ P.wrap $ "Unable to reach the code server hosted at:" <> P.string (Servant.showBaseUrl codeServerURL), "", P.wrap "Please check your network, ensure you've provided the correct location, or try again later." ] - RateLimitExceeded -> "Rate limit exceeded, please try again later." - Timeout -> "The code server timed-out when responding to your request. Please try again later or report an issue if the problem persists." - UnexpectedResponse resp -> - (P.lines . catMaybes) - [ Just - ( "The server sent a " - <> P.red (P.shown (Http.statusCode (Servant.responseStatusCode resp))) - <> " that we didn't expect." - ), - let body = Text.decodeUtf8 (LazyByteString.toStrict (Servant.responseBody resp)) - in if Text.null body then Nothing else Just (P.newline <> "Response body: " <> P.text body), - responseRequestId resp <&> \responseId -> P.newline <> "Request ID: " <> P.blue (P.text responseId) - ] - where - -- Dig the request id out of a response header. - responseRequestId :: Servant.Response -> Maybe Text - responseRequestId = - fmap Text.decodeUtf8 . List.lookup "X-RequestId" . Foldable.toList @Seq . Servant.responseHeaders + Share.RateLimitExceeded -> "Rate limit exceeded, please try again later." + Share.Timeout -> "The code server timed-out when responding to your request. Please try again later or report an issue if the problem persists." + Share.UnexpectedResponse resp -> + unexpectedServerResponse resp + +unexpectedServerResponse :: Servant.ResponseF LazyByteString.ByteString -> P.Pretty Unison.Util.ColorText.ColorText +unexpectedServerResponse resp = + (P.lines . catMaybes) + [ Just + ( "I received an unexpected status code from the server: " + <> P.red (P.shown (Http.statusCode (Servant.responseStatusCode resp))) + ), + let body = Text.decodeUtf8 (LazyByteString.toStrict (Servant.responseBody resp)) + in if Text.null body then Nothing else Just (P.newline <> "Response body: " <> P.text body), + responseRequestId resp <&> \responseId -> P.newline <> "Request ID: " <> P.blue (P.text responseId) + ] + +-- | Dig the request id out of a response header. +responseRequestId :: Servant.Response -> Maybe Text +responseRequestId = + fmap Text.decodeUtf8 . List.lookup "X-RequestId" . Foldable.toList @Seq . Servant.responseHeaders prettyEntityType :: Share.EntityType -> Pretty prettyEntityType = \case @@ -2441,17 +2490,6 @@ shareUserNotFound :: Share.RepoInfo -> Pretty shareUserNotFound repoInfo = P.wrap ("User" <> prettyRepoInfo repoInfo <> "does not exist.") -sharePathToWriteRemotePathShare :: Share.Path -> WriteRemoteNamespace void -sharePathToWriteRemotePathShare sharePath = - -- Recover the original WriteRemotePath from the information in the error, which is thrown from generic share - -- client code that doesn't know about WriteRemotePath - WriteRemoteNamespaceShare - WriteShareRemoteNamespace - { server = RemoteRepo.DefaultCodeserver, - repo = ShareUserHandle $ Share.unRepoInfo (Share.pathRepoInfo sharePath), - path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath)) - } - formatMissingStuff :: (Show tm, Show typ) => [(HQ.HashQualified Name, tm)] -> @@ -2540,38 +2578,37 @@ displayRendered outputLoc pp = displayTestResults :: Bool -> -- whether to show the tip - PPE.PrettyPrintEnv -> - [(TermReferenceId, Text)] -> - [(TermReferenceId, Text)] -> + [(HQ.HashQualified Name, [Text])] -> + [(HQ.HashQualified Name, [Text])] -> Pretty -displayTestResults showTip ppe oksUnsorted failsUnsorted = - let oks = Name.sortByText fst [(name r, msg) | (r, msg) <- oksUnsorted] - fails = Name.sortByText fst [(name r, msg) | (r, msg) <- failsUnsorted] - name r = HQ.toText $ PPE.termName ppe (Referent.fromTermReferenceId r) +displayTestResults showTip oks fails = + let name = P.text . HQ.toText okMsg = if null oks then mempty - else P.column2 [(P.green "◉ " <> P.text r, " " <> P.green (P.text msg)) | (r, msg) <- oks] + else + P.indentN 2 $ + P.numberedColumn2ListFrom 0 [(name r, P.lines $ P.green . (" ◉ " <>) . P.text <$> msgs) | (r, msgs) <- oks] okSummary = if null oks then mempty - else "✅ " <> P.bold (P.num (length oks)) <> P.green " test(s) passing" + else "✅ " <> P.bold (P.num (sum $ fmap (length . snd) oks)) <> P.green " test(s) passing" failMsg = if null fails then mempty - else P.column2 [(P.red "✗ " <> P.text r, " " <> P.red (P.text msg)) | (r, msg) <- fails] + else + P.indentN 2 $ + P.numberedColumn2ListFrom + (length oks) + [(name r, P.lines $ P.red . (" ✗ " <>) . P.text <$> msgs) | (r, msgs) <- fails] failSummary = if null fails then mempty - else "🚫 " <> P.bold (P.num (length fails)) <> P.red " test(s) failing" + else "🚫 " <> P.bold (P.num (sum $ fmap (length . snd) fails)) <> P.red " test(s) failing" tipMsg = if not showTip || (null oks && null fails) then mempty - else - tip $ - "Use " - <> P.blue ("view " <> P.text (fst $ head (fails ++ oks))) - <> "to view the source of a test." + else tip $ "Use " <> P.blue "view 1" <> "to view the source of a test." in if null oks && null fails then "😶 No tests available." else @@ -2592,32 +2629,31 @@ unsafePrettyTermResultSig' ppe = \case head (TypePrinter.prettySignaturesCT ppe [(r, name, typ)]) _ -> error "Don't pass Nothing" -renderNameConflicts :: PPE.PrettyPrintEnv -> Names -> Numbered Pretty -renderNameConflicts ppe conflictedNames = do +renderNameConflicts :: Int -> Names -> Numbered Pretty +renderNameConflicts hashLen conflictedNames = do let conflictedTypeNames :: Map Name [HQ.HashQualified Name] conflictedTypeNames = conflictedNames & Names.types & R.domain - & fmap (foldMap (pure @[] . PPE.typeName ppe)) + & Map.mapWithKey \name -> map (HQ.take hashLen . HQ.HashQualified name . Reference.toShortHash) . Set.toList let conflictedTermNames :: Map Name [HQ.HashQualified Name] conflictedTermNames = conflictedNames & Names.terms & R.domain - & fmap (foldMap (pure @[] . PPE.termName ppe)) + & Map.mapWithKey \name -> map (HQ.take hashLen . HQ.HashQualified name . Referent.toShortHash) . Set.toList let allConflictedNames :: [Name] allConflictedNames = Set.toList (Map.keysSet conflictedTermNames <> Map.keysSet conflictedTypeNames) prettyConflictedTypes <- showConflictedNames "type" conflictedTypeNames prettyConflictedTerms <- showConflictedNames "term" conflictedTermNames pure $ Monoid.unlessM (null allConflictedNames) $ - P.callout "❓" . P.sep "\n\n" . P.nonEmpty $ + P.callout "❓" . P.linesSpaced . P.nonEmpty $ [ prettyConflictedTypes, prettyConflictedTerms, tip $ - "This occurs when merging branches that both independently introduce the same name." - <> "Use " + "Use " <> makeExample' ( if (not . null) conflictedTypeNames then IP.renameType @@ -2634,87 +2670,31 @@ renderNameConflicts ppe conflictedNames = do where showConflictedNames :: Pretty -> Map Name [HQ.HashQualified Name] -> Numbered Pretty showConflictedNames thingKind conflictedNames = - P.lines <$> do - for (Map.toList conflictedNames) $ \(name, hashes) -> do + P.linesSpaced <$> do + for (Map.toList conflictedNames) \(name, hashes) -> do prettyConflicts <- for hashes \hash -> do n <- addNumberedArg $ SA.HashQualified hash pure $ formatNum n <> (P.blue . P.syntaxToColor . prettyHashQualified $ hash) - pure . P.wrap $ - ( "The " - <> thingKind - <> " " - <> P.green (prettyName name) - <> " has conflicting definitions:" - ) - `P.hang` P.lines prettyConflicts - -renderEditConflicts :: - PPE.PrettyPrintEnv -> Patch -> Numbered Pretty -renderEditConflicts ppe Patch {..} = do - formattedConflicts <- for editConflicts formatConflict - pure . Monoid.unlessM (null editConflicts) . P.callout "❓" . P.sep "\n\n" $ - [ P.wrap $ - "These" - <> P.bold "definitions were edited differently" - <> "in namespaces that have been merged into this one." - <> "You'll have to tell me what to use as the new definition:", - P.indentN 2 (P.lines formattedConflicts) - -- , tip $ "Use " <> makeExample IP.resolve [name (head editConflicts), " "] <> " to pick a replacement." -- todo: eventually something with `edit` - ] - where - -- todo: could possibly simplify all of this, but today is a copy/paste day. - editConflicts :: [Either (Reference, Set TypeEdit.TypeEdit) (Reference, Set TermEdit.TermEdit)] - editConflicts = - (fmap Left . Map.toList . R.toMultimap . R.filterManyDom $ _typeEdits) - <> (fmap Right . Map.toList . R.toMultimap . R.filterManyDom $ _termEdits) - numberedHQName :: HQ.HashQualified Name -> Numbered Pretty - numberedHQName hqName = do - n <- addNumberedArg $ SA.HashQualified hqName - pure $ formatNum n <> styleHashQualified P.bold hqName - formatTypeEdits :: - (Reference, Set TypeEdit.TypeEdit) -> - Numbered Pretty - formatTypeEdits (r, toList -> es) = do - replacedType <- numberedHQName (PPE.typeName ppe r) - replacements <- for [PPE.typeName ppe r | TypeEdit.Replace r <- es] numberedHQName - pure . P.wrap $ - "The type" - <> replacedType - <> "was" - <> ( if TypeEdit.Deprecate `elem` es - then "deprecated and also replaced with" - else "replaced with" - ) - `P.hang` P.lines replacements - formatTermEdits :: - (Reference.TermReference, Set TermEdit.TermEdit) -> - Numbered Pretty - formatTermEdits (r, toList -> es) = do - replacedTerm <- numberedHQName (PPE.termName ppe (Referent.Ref r)) - replacements <- for [PPE.termName ppe (Referent.Ref r) | TermEdit.Replace r _ <- es] numberedHQName - pure . P.wrap $ - "The term" - <> replacedTerm - <> "was" - <> ( if TermEdit.Deprecate `elem` es - then "deprecated and also replaced with" - else "replaced with" - ) - `P.hang` P.lines replacements - formatConflict :: - Either - (Reference, Set TypeEdit.TypeEdit) - (Reference.TermReference, Set TermEdit.TermEdit) -> - Numbered Pretty - formatConflict = either formatTypeEdits formatTermEdits + pure $ + P.wrap + ( "The " + <> thingKind + <> " " + <> P.green (prettyName name) + <> " has conflicting definitions:" + ) + <> P.newline + <> P.newline + <> P.indentN 2 (P.lines prettyConflicts) type Numbered = State.State (Int, Seq.Seq StructuredArgument) addNumberedArg :: StructuredArgument -> Numbered Int addNumberedArg s = do (n, args) <- State.get - State.put (n + 1, args Seq.|> s) - pure $ (n + 1) + let !n' = n + 1 + State.put (n', args Seq.|> s) + pure n' formatNum :: Int -> Pretty formatNum n = P.string (show n <> ". ") @@ -2724,96 +2704,257 @@ runNumbered m = let (a, (_, args)) = State.runState m (0, mempty) in (a, Foldable.toList args) -todoOutput :: (Var v) => PPED.PrettyPrintEnvDecl -> TO.TodoOutput v a -> (Pretty, NumberedArgs) -todoOutput ppe todo = runNumbered do - conflicts <- todoConflicts - edits <- todoEdits - pure (conflicts <> edits) - where - ppeu = PPED.unsuffixifiedPPE ppe - ppes = PPED.suffixifiedPPE ppe - (frontierTerms, frontierTypes) = TO.todoFrontier todo - (dirtyTerms, dirtyTypes) = TO.todoFrontierDependents todo - corruptTerms = - [(PPE.termName ppeu (Referent.Ref r), r) | (r, Nothing) <- frontierTerms] - corruptTypes = - [(PPE.typeName ppeu r, r) | (r, MissingObject _) <- frontierTypes] - goodTerms ts = - [(Referent.Ref r, PPE.termName ppeu (Referent.Ref r), typ) | (r, Just typ) <- ts] - todoConflicts :: Numbered Pretty - todoConflicts = do - if TO.noConflicts todo - then pure mempty - else do - editConflicts <- renderEditConflicts ppeu (TO.editConflicts todo) - nameConflicts <- renderNameConflicts ppeu conflictedNames - pure $ P.lines . P.nonEmpty $ [editConflicts, nameConflicts] - where - -- If a conflict is both an edit and a name conflict, we show it in the edit - -- conflicts section - conflictedNames :: Names - conflictedNames = removeEditConflicts (TO.editConflicts todo) (TO.nameConflicts todo) - -- e.g. `foo#a` has been independently updated to `foo#b` and `foo#c`. - -- This means there will be a name conflict: - -- foo -> #b - -- foo -> #c - -- as well as an edit conflict: - -- #a -> #b - -- #a -> #c - -- We want to hide/ignore the name conflicts that are also targets of an - -- edit conflict, so that the edit conflict will be dealt with first. - -- For example, if hash `h` has multiple edit targets { #x, #y, #z, ...}, - -- we'll temporarily remove name conflicts pointing to { #x, #y, #z, ...}. - removeEditConflicts :: Patch -> Names -> Names - removeEditConflicts Patch {..} Names {..} = Names terms' types' - where - terms' = R.filterRan (`Set.notMember` conflictedTermEditTargets) terms - types' = R.filterRan (`Set.notMember` conflictedTypeEditTargets) types - conflictedTypeEditTargets :: Set Reference - conflictedTypeEditTargets = - Set.fromList $ toList (R.ran typeEditConflicts) >>= TypeEdit.references - conflictedTermEditTargets :: Set Referent.Referent - conflictedTermEditTargets = - Set.fromList . fmap Referent.Ref $ - toList (R.ran termEditConflicts) >>= TermEdit.references - typeEditConflicts = R.filterDom (`R.manyDom` _typeEdits) _typeEdits - termEditConflicts = R.filterDom (`R.manyDom` _termEdits) _termEdits - - todoEdits :: Numbered Pretty - todoEdits = do - numberedTypes <- for (unscore <$> dirtyTypes) \(ref, displayObj) -> do - n <- addNumberedArg . SA.HashQualified $ PPE.typeName ppeu ref - pure $ formatNum n <> prettyDeclPair ppeu (ref, displayObj) - let filteredTerms = goodTerms (unscore <$> dirtyTerms) - termNumbers <- for filteredTerms \(ref, _, _) -> do - n <- addNumberedArg . SA.HashQualified $ PPE.termName ppeu ref - pure $ formatNum n - let formattedTerms = TypePrinter.prettySignaturesCT ppes filteredTerms - numberedTerms = zipWith (<>) termNumbers formattedTerms - pure $ - Monoid.unlessM (TO.noEdits todo) . P.callout "🚧" . P.sep "\n\n" . P.nonEmpty $ - [ P.wrap - ( "The namespace has" - <> fromString (show (TO.todoScore todo)) - <> "transitive dependent(s) left to upgrade." - <> "Your edit frontier is the dependents of these definitions:" - ), - P.indentN 2 . P.lines $ - ( (prettyDeclPair ppeu <$> toList frontierTypes) - ++ TypePrinter.prettySignaturesCT ppes (goodTerms frontierTerms) - ), - P.wrap "I recommend working on them in the following order:", - P.lines $ numberedTypes ++ numberedTerms, - formatMissingStuff corruptTerms corruptTypes - ] - unscore :: (a, b, c) -> (b, c) - unscore (_score, b, c) = (b, c) +handleTodoOutput :: TodoOutput -> Numbered Pretty +handleTodoOutput todo + | todoOutputIsEmpty todo = pure "You have no pending todo items. Good work! ✅" + | otherwise = do + prettyDependentsOfTodo <- do + if Set.null todo.dependentsOfTodo + then pure mempty + else do + terms <- + for (Set.toList todo.dependentsOfTodo) \term -> do + n <- addNumberedArg (SA.HashQualified (HQ.HashOnly (Reference.idToShortHash term))) + let name = + term + & Referent.fromTermReferenceId + & PPE.termName todo.ppe.suffixifiedPPE + & prettyHashQualified + & P.syntaxToColor + pure (formatNum n <> name) + pure $ + P.wrap "These terms call `todo`:" + <> P.newline + <> P.newline + <> P.indentN 2 (P.lines terms) + + prettyDirectTermDependenciesWithoutNames <- do + if Set.null todo.directDependenciesWithoutNames.terms + then pure mempty + else do + terms <- + for (Set.toList todo.directDependenciesWithoutNames.terms) \term -> do + n <- addNumberedArg (SA.HashQualified (HQ.HashOnly (Reference.toShortHash term))) + pure (formatNum n <> P.syntaxToColor (prettyReference todo.hashLen term)) + pure $ + P.wrap "These terms do not have any names in the current namespace:" + <> P.newline + <> P.newline + <> P.indentN 2 (P.lines terms) + + prettyDirectTypeDependenciesWithoutNames <- do + if Set.null todo.directDependenciesWithoutNames.types + then pure mempty + else do + types <- + for (Set.toList todo.directDependenciesWithoutNames.types) \typ -> do + n <- addNumberedArg (SA.HashQualified (HQ.HashOnly (Reference.toShortHash typ))) + pure (formatNum n <> P.syntaxToColor (prettyReference todo.hashLen typ)) + pure $ + P.wrap "These types do not have any names in the current namespace:" + <> P.newline + <> P.newline + <> P.indentN 2 (P.lines types) + + prettyConflicts <- + if todo.nameConflicts == mempty + then pure mempty + else renderNameConflicts todo.hashLen todo.nameConflicts + + let prettyDefnsInLib = + if todo.defnsInLib + then + P.wrap $ + -- Note [DefnsInLibMessage] If you change this, also change the other similar one + "There's a type or term at the top level of the `lib` namespace, where I only expect to find" + <> "subnamespaces representing library dependencies. Please move or remove it." + else mempty + + prettyConstructorAliases <- + let -- We want to filter out constructor aliases whose types are part of a "nested decl alias" problem, because + -- otherwise we'd essentially be reporting those issues twice. + -- + -- That is, if we have two nested aliases like + -- + -- Foo = #XYZ + -- Foo.Bar = #XYZ#0 + -- + -- Foo.inner.Alias = #XYZ + -- Foo.inner.Alias.Constructor = #XYZ#0 + -- + -- then we'd prefer to say "oh no Foo and Foo.inner.Alias are aliases" but *not* additionally say "oh no + -- Foo.Bar and Foo.inner.Alias.Constructor are aliases". + notNestedDeclAlias (typeName, _, _) = + foldr + (\(short, long) acc -> typeName /= short && typeName /= long && acc) + True + todo.incoherentDeclReasons.nestedDeclAliases + in case filter notNestedDeclAlias todo.incoherentDeclReasons.constructorAliases of + [] -> pure mempty + aliases -> do + things <- + for aliases \(typeName, conName1, conName2) -> do + n1 <- addNumberedArg (SA.Name conName1) + n2 <- addNumberedArg (SA.Name conName2) + pure (typeName, formatNum n1 <> prettyName conName1, formatNum n2 <> prettyName conName2) + pure $ + things + & map + ( \(typeName, prettyCon1, prettyCon2) -> + -- Note [ConstructorAliasMessage] If you change this, also change the other similar ones + P.wrap ("The type" <> prettyName typeName <> "has a constructor with multiple names.") + <> P.newline + <> P.newline + <> P.indentN 2 (P.lines [prettyCon1, prettyCon2]) + <> P.newline + <> P.newline + <> P.wrap "Please delete all but one name for each constructor." + ) + & P.sep "\n\n" + + prettyMissingConstructorNames <- + case NEList.nonEmpty todo.incoherentDeclReasons.missingConstructorNames of + Nothing -> pure mempty + Just types0 -> do + stuff <- + for types0 \typ -> do + n <- addNumberedArg (SA.Name typ) + pure (n, typ) + -- Note [MissingConstructorNameMessage] If you change this, also change the other similar ones + pure $ + P.wrap + "These types have some constructors with missing names." + <> P.newline + <> P.newline + <> P.indentN 2 (P.lines (fmap (\(n, typ) -> formatNum n <> prettyName typ) stuff)) + <> P.newline + <> P.newline + <> P.wrap + ( "You can use" + <> IP.makeExample + IP.view + [ let firstNum = fst (NEList.head stuff) + lastNum = fst (NEList.last stuff) + in if firstNum == lastNum + then P.string (show firstNum) + else P.string (show firstNum) <> "-" <> P.string (show lastNum) + ] + <> "and" + <> IP.makeExample IP.aliasTerm ["", "."] + <> "to give names to each unnamed constructor." + ) + + prettyNestedDeclAliases <- + case todo.incoherentDeclReasons.nestedDeclAliases of + [] -> pure mempty + aliases0 -> do + aliases1 <- + for aliases0 \(short, long) -> do + n1 <- addNumberedArg (SA.Name short) + n2 <- addNumberedArg (SA.Name long) + pure (formatNum n1 <> prettyName short, formatNum n2 <> prettyName long) + -- Note [NestedDeclAliasMessage] If you change this, also change the other similar ones + pure $ + aliases1 + & map + ( \(short, long) -> + P.wrap + ( "These types are aliases, but one is nested under the other. Please separate them or delete" + <> "one copy." + ) + <> P.newline + <> P.newline + <> P.indentN 2 (P.lines [short, long]) + ) + & P.sep "\n\n" + + prettyStrayConstructors <- + case todo.incoherentDeclReasons.strayConstructors of + [] -> pure mempty + constructors -> do + nums <- + for constructors \(_typeRef, constructor) -> do + addNumberedArg (SA.Name constructor) + -- Note [StrayConstructorMessage] If you change this, also change the other similar ones + pure $ + P.wrap "These constructors are not nested beneath their corresponding type names:" + <> P.newline + <> P.newline + <> P.indentN + 2 + ( P.lines + ( zipWith + (\n (_typeRef, constructor) -> formatNum n <> prettyName constructor) + nums + constructors + ) + ) + <> P.newline + <> P.newline + <> P.wrap + ( "For each one, please either use" + <> IP.makeExample' IP.moveAll + <> "to move if, or if it's an extra copy, you can simply" + <> IP.makeExample' IP.delete + <> "it." + ) + + (pure . P.sep "\n\n" . P.nonEmpty) + [ prettyDependentsOfTodo, + prettyDirectTermDependenciesWithoutNames, + prettyDirectTypeDependenciesWithoutNames, + prettyConflicts, + prettyDefnsInLib, + prettyConstructorAliases, + prettyMissingConstructorNames, + prettyNestedDeclAliases, + prettyStrayConstructors + ] listOfDefinitions :: (Var v) => Input.FindScope -> PPE.PrettyPrintEnv -> E.ListDetailed -> [SR'.SearchResult' v a] -> IO Pretty listOfDefinitions fscope ppe detailed results = pure $ listOfDefinitions' fscope ppe detailed results +listOfNames :: Int -> [(Reference, [HQ'.HashQualified Name])] -> [(Referent, [HQ'.HashQualified Name])] -> IO Pretty +listOfNames len types terms = do + if null types && null terms + then + pure . P.callout "😶" $ + P.sepNonEmpty "\n\n" $ + [ P.wrap "I couldn't find anything by that name." + ] + else + pure . P.sepNonEmpty "\n\n" $ + [ formatTypes types, + formatTerms terms + ] + where + formatTerms tms = + P.lines . P.nonEmpty $ P.plural tms (P.blue "Term") : List.intersperse "" (go <$> tms) + where + go (ref, hqs) = + P.column2 + [ ("Hash:", P.syntaxToColor (prettyReferent len ref)), + ( "Names: ", + P.group $ + P.spaced $ + P.bold . P.syntaxToColor . prettyHashQualified' <$> List.sortBy Name.compareAlphabetical hqs + ) + ] + formatTypes types = + P.lines . P.nonEmpty $ P.plural types (P.blue "Type") : List.intersperse "" (go <$> types) + where + go (ref, hqs) = + P.column2 + [ ("Hash:", P.syntaxToColor (prettyReference len ref)), + ( "Names:", + P.group $ + P.spaced $ + P.bold . P.syntaxToColor . prettyHashQualified' <$> List.sortBy Name.compareAlphabetical hqs + ) + ] + data ShowNumbers = ShowNumbers | HideNumbers -- | `ppe` is just for rendering type signatures @@ -3492,17 +3633,19 @@ endangeredDependentsTable ppeDecl m = & fmap (\(n, dep) -> numArg n <> prettyLabeled fqnEnv dep) & P.lines -listStructuredFind :: [HQ.HashQualified Name] -> Pretty -listStructuredFind [] = "😶 I couldn't find any matches." -listStructuredFind tms = +listFind :: Bool -> Maybe Pretty -> [HQ.HashQualified Name] -> Pretty +listFind _ Nothing [] = "😶 I couldn't find any matches." +listFind _ (Just onMissing) [] = P.lines ["😶 I couldn't find any matches.", "", tip onMissing] +listFind allowLib _ tms = P.callout "🔎" . P.lines $ - [ "These definitions from the current namespace (excluding `lib`) have matches:", + [ "These definitions from the current namespace " <> parenthetical <> "have matches:", "", P.indentN 2 $ P.numberedList (pnames tms), "", tip (msg (length tms)) ] where + parenthetical = if allowLib then "" else "(excluding `lib`) " pnames hqs = P.syntaxToColor . prettyHashQualified <$> hqs msg 1 = "Try " <> IP.makeExample IP.edit ["1"] <> " to bring this into your scratch file." msg n = @@ -3535,7 +3678,7 @@ listDependentsOrDependencies ppe labelStart label lds types terms = P.lines $ [ P.indentN 2 $ P.bold "Types:", "", - P.indentN 2 $ P.numbered (numFrom 0) $ c . prettyHashQualified <$> types + P.indentN 2 . P.numberedList $ c . prettyHashQualified <$> types ] termsOut = if null terms @@ -3544,7 +3687,47 @@ listDependentsOrDependencies ppe labelStart label lds types terms = P.lines [ P.indentN 2 $ P.bold "Terms:", "", - P.indentN 2 $ P.numbered (numFrom $ length types) $ c . prettyHashQualified <$> terms + P.indentN 2 . P.numberedListFrom (length types) $ c . prettyHashQualified <$> terms ] - numFrom k n = P.hiBlack $ P.shown (k + n) <> "." c = P.syntaxToColor + +displayProjectBranchReflogEntries :: + Maybe UTCTime -> + E.MoreEntriesThanShown -> + [ProjectReflog.Entry Project ProjectBranch (CausalHash, ShortCausalHash)] -> + (Pretty, NumberedArgs) +displayProjectBranchReflogEntries _ _ [] = + (P.warnCallout "The reflog is empty", mempty) +displayProjectBranchReflogEntries mayNow _ entries = + let (entryRows, numberedArgs) = foldMap renderEntry entries + rendered = + P.lines + [ header, + "", + P.numberedColumnNHeader (["Branch"] <> Monoid.whenM (isJust mayNow) ["When"] <> ["Hash", "Description"]) entryRows + ] + in (rendered, numberedArgs) + where + header = + P.lines + [ P.wrap $ + "Below is a record of recent changes, you can use " + <> IP.makeExample IP.reset ["#abcdef"] + <> " to reset the current branch to a previous state.", + "", + tip $ "Use " <> IP.makeExample IP.diffNamespace ["1", "7"] <> " to compare between points in history." + ] + renderEntry :: ProjectReflog.Entry Project ProjectBranch (CausalHash, SCH.ShortCausalHash) -> ([[Pretty]], NumberedArgs) + renderEntry ProjectReflog.Entry {time, project, branch, toRootCausalHash = (toCH, toSCH), reason} = + ( [ [prettyProjectAndBranchName $ ProjectAndBranch project.name branch.name] + <> ( mayNow + & foldMap (\now -> [prettyHumanReadableTime now time]) + ) + <> [P.blue (prettySCH toSCH), P.text $ truncateReason reason] + ], + [SA.Namespace toCH] + ) + truncateReason :: Text -> Text + truncateReason txt = case Text.splitAt 60 txt of + (short, "") -> short + (short, _) -> short <> "..." diff --git a/unison-cli/src/Unison/LSP.hs b/unison-cli/src/Unison/LSP.hs index 867a08ed1e..7ec47063b1 100644 --- a/unison-cli/src/Unison/LSP.hs +++ b/unison-cli/src/Unison/LSP.hs @@ -27,9 +27,8 @@ import Language.LSP.VFS import Network.Simple.TCP qualified as TCP import System.Environment (lookupEnv) import System.IO (hPutStrLn) -import U.Codebase.HashTags import Unison.Codebase -import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime (Runtime) import Unison.Debug qualified as Debug import Unison.LSP.CancelRequest (cancelRequestHandler) @@ -47,6 +46,7 @@ import Unison.LSP.NotificationHandlers qualified as Notifications import Unison.LSP.Orphans () import Unison.LSP.Types import Unison.LSP.UCMWorker (ucmWorker) +import Unison.LSP.Util.Signal (Signal) import Unison.LSP.VFS qualified as VFS import Unison.Parser.Ann import Unison.Prelude @@ -61,8 +61,13 @@ getLspPort :: IO String getLspPort = fromMaybe "5757" <$> lookupEnv "UNISON_LSP_PORT" -- | Spawn an LSP server on the configured port. -spawnLsp :: LspFormattingConfig -> Codebase IO Symbol Ann -> Runtime Symbol -> STM CausalHash -> STM (Path.Absolute) -> IO () -spawnLsp lspFormattingConfig codebase runtime latestRootHash latestPath = +spawnLsp :: + LspFormattingConfig -> + Codebase IO Symbol Ann -> + Runtime Symbol -> + Signal PP.ProjectPathIds -> + IO () +spawnLsp lspFormattingConfig codebase runtime signal = ifEnabled . TCP.withSocketsDo $ do lspPort <- getLspPort UnliftIO.handleIO (handleFailure lspPort) $ do @@ -80,9 +85,9 @@ spawnLsp lspFormattingConfig codebase runtime latestRootHash latestPath = -- currently we have an independent VFS for each LSP client since each client might have -- different un-saved state for the same file. - initVFS $ \vfs -> do - vfsVar <- newMVar vfs - void $ runServerWith lspServerLogger lspClientLogger clientInput clientOutput (serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestRootHash latestPath) + do + vfsVar <- newMVar emptyVFS + void $ runServerWith lspServerLogger lspClientLogger clientInput clientOutput (serverDefinition lspFormattingConfig vfsVar codebase runtime scope signal) where handleFailure :: String -> IOException -> IO () handleFailure lspPort ioerr = @@ -113,16 +118,15 @@ serverDefinition :: Codebase IO Symbol Ann -> Runtime Symbol -> Ki.Scope -> - STM CausalHash -> - STM (Path.Absolute) -> + Signal PP.ProjectPathIds -> ServerDefinition Config -serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestRootHash latestPath = +serverDefinition lspFormattingConfig vfsVar codebase runtime scope signal = ServerDefinition { defaultConfig = defaultLSPConfig, configSection = "unison", parseConfig = Config.parseConfig, onConfigChange = Config.updateConfig, - doInitialize = lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath, + doInitialize = lspDoInitialize vfsVar codebase runtime scope signal, staticHandlers = lspStaticHandlers lspFormattingConfig, interpretHandler = lspInterpretHandler, options = lspOptions @@ -134,12 +138,11 @@ lspDoInitialize :: Codebase IO Symbol Ann -> Runtime Symbol -> Ki.Scope -> - STM CausalHash -> - STM (Path.Absolute) -> + Signal PP.ProjectPathIds -> LanguageContextEnv Config -> Msg.TMessage 'Msg.Method_Initialize -> IO (Either Msg.ResponseError Env) -lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath lspContext _initMsg = do +lspDoInitialize vfsVar codebase runtime scope signal lspContext _initMsg = do checkedFilesVar <- newTVarIO mempty dirtyFilesVar <- newTVarIO mempty ppedCacheVar <- newEmptyTMVarIO @@ -152,13 +155,13 @@ lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath lspConte Env { ppedCache = atomically $ readTMVar ppedCacheVar, currentNamesCache = atomically $ readTMVar currentNamesCacheVar, - currentPathCache = atomically $ readTMVar currentPathCacheVar, + currentProjectPathCache = atomically $ readTMVar currentPathCacheVar, nameSearchCache = atomically $ readTMVar nameSearchCacheVar, .. } let lspToIO = flip runReaderT lspContext . unLspT . flip runReaderT env . runLspM Ki.fork scope (lspToIO Analysis.fileAnalysisWorker) - Ki.fork scope (lspToIO $ ucmWorker ppedCacheVar currentNamesCacheVar nameSearchCacheVar currentPathCacheVar latestRootHash latestPath) + Ki.fork scope (lspToIO $ ucmWorker ppedCacheVar currentNamesCacheVar nameSearchCacheVar currentPathCacheVar signal) pure $ Right $ env -- | LSP request handlers that don't register/unregister dynamically diff --git a/unison-cli/src/Unison/LSP/CodeLens.hs b/unison-cli/src/Unison/LSP/CodeLens.hs index 38df42a72e..a5017ee99d 100644 --- a/unison-cli/src/Unison/LSP/CodeLens.hs +++ b/unison-cli/src/Unison/LSP/CodeLens.hs @@ -6,7 +6,6 @@ module Unison.LSP.CodeLens where import Control.Lens hiding (List) -import Control.Monad.Except import Data.Aeson qualified as Aeson import Data.Map qualified as Map import Data.Text qualified as Text diff --git a/unison-cli/src/Unison/LSP/Completion.hs b/unison-cli/src/Unison/LSP/Completion.hs index 129ba8bc54..6e0ea31d56 100644 --- a/unison-cli/src/Unison/LSP/Completion.hs +++ b/unison-cli/src/Unison/LSP/Completion.hs @@ -3,7 +3,14 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -module Unison.LSP.Completion where +module Unison.LSP.Completion + ( completionHandler, + completionItemResolveHandler, + namesToCompletionTree, + -- Exported for transcript tests + completionsForQuery, + ) +where import Control.Comonad.Cofree import Control.Lens hiding (List, (:<)) @@ -11,6 +18,7 @@ import Control.Monad.Reader import Data.Aeson qualified as Aeson import Data.Aeson.Types qualified as Aeson import Data.Foldable qualified as Foldable +import Data.List qualified as List import Data.List.Extra (nubOrdOn) import Data.List.NonEmpty (NonEmpty (..)) import Data.Map qualified as Map @@ -23,7 +31,7 @@ import Text.Megaparsec qualified as Megaparsec import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.LSP.FileAnalysis import Unison.LSP.Queries qualified as LSPQ import Unison.LSP.Types @@ -34,7 +42,6 @@ import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment -import Unison.NameSegment.Internal qualified as NameSegment import Unison.Names (Names (..)) import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE @@ -43,7 +50,7 @@ import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.Runtime.IOSource qualified as IOSource import Unison.Syntax.DeclPrinter qualified as DeclPrinter -import Unison.Syntax.HashQualified' qualified as HQ' (toText) +import Unison.Syntax.HashQualifiedPrime qualified as HQ' (toText) import Unison.Syntax.Name qualified as Name (nameP, parseText, toText) import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Util.Monoid qualified as Monoid @@ -58,26 +65,30 @@ completionHandler m respond = (range, prefix) <- VFS.completionPrefix (m ^. params . textDocument . uri) (m ^. params . position) ppe <- PPED.suffixifiedPPE <$> lift currentPPED codebaseCompletions <- lift getCodebaseCompletions - -- Config {maxCompletions} <- lift getConfig - let defMatches = matchCompletions codebaseCompletions prefix - let (isIncomplete, defCompletions) = - defMatches - & nubOrdOn (\(p, _name, ref) -> (p, ref)) - & fmap (over _1 Path.toText) - & (False,) - -- case maxCompletions of - -- Nothing -> (False,) - -- Just n -> takeCompletions n + let (isIncomplete, matches) = completionsForQuery codebaseCompletions prefix let defCompletionItems = - defCompletions + matches & mapMaybe \(path, fqn, dep) -> let biasedPPE = PPE.biasTo [fqn] ppe hqName = LD.fold (PPE.types biasedPPE) (PPE.terms biasedPPE) dep in hqName <&> \hqName -> mkDefCompletionItem fileUri range (HQ'.toName hqName) fqn path (HQ'.toText hqName) dep + let itemDefaults = Nothing pure . CompletionList isIncomplete itemDefaults $ defCompletionItems where +completionsForQuery :: CompletionTree -> Text -> (Bool, [(Text, Name, LabeledDependency)]) +completionsForQuery codebaseCompletions prefix = + let defMatches = matchCompletions codebaseCompletions prefix + (isIncomplete, defCompletions) = + defMatches + -- sort shorter names first + & sortOn (matchSortCriteria . view _2) + & nubOrdOn (\(p, _name, ref) -> (p, ref)) + & fmap (over _1 Path.toText) + & (False,) + in (isIncomplete, defCompletions) + -- Takes at most the specified number of completions, but also indicates with a boolean -- whether there were more completions remaining so we can pass that along to the client. -- takeCompletions :: Int -> [a] -> (Bool, [a]) @@ -100,7 +111,9 @@ mkDefCompletionItem fileUri range relativeName fullyQualifiedName path suffixifi _documentation = Nothing, _deprecated = Nothing, _preselect = Nothing, - _sortText = Nothing, + _sortText = + let (nls, ns, fn) = matchSortCriteria fullyQualifiedName + in Just $ Text.intercalate "|" [paddedInt nls, paddedInt ns, Name.toText fn], _filterText = Just path, _insertText = Nothing, _insertTextFormat = Nothing, @@ -113,6 +126,13 @@ mkDefCompletionItem fileUri range relativeName fullyQualifiedName path suffixifi _data_ = Just $ Aeson.toJSON $ CompletionItemDetails {dep, relativeName, fullyQualifiedName, fileUri} } where + -- Pads an integer with zeroes so it sorts lexicographically in the right order + -- + -- >>> paddedInt 1 + -- "00001" + paddedInt :: Int -> Text + paddedInt n = + Text.justifyRight 5 '0' (Text.pack $ show n) -- We should generally show the longer of the path or suffixified name in the label, -- it helps the user understand the difference between options which may otherwise look -- the same. @@ -131,6 +151,21 @@ mkDefCompletionItem fileUri range relativeName fullyQualifiedName path suffixifi then path else suffixified +-- | LSP clients sort completions using a text field, so we have to convert Unison's sort criteria to text. +matchSortCriteria :: Name -> (Int, Int, Name) +matchSortCriteria fqn = + (numLibSegments, numSegments, fqn) + where + numSegments :: Int + numSegments = + Name.countSegments fqn + numLibSegments :: Int + numLibSegments = + Name.reverseSegments fqn + & Foldable.toList + & List.filter (== NameSegment.libSegment) + & List.length + -- | Generate a completion tree from a set of names. -- A completion tree is a suffix tree over the path segments of each name it contains. -- The goal is to allow fast completion of names by any partial path suffix. @@ -298,18 +333,18 @@ completionItemResolveHandler message respond = do LD.TermReferent ref -> do typ <- LSPQ.getTypeOfReferent fileUri ref let renderedType = ": " <> (Text.pack $ TypePrinter.prettyStr (Just typeWidth) (PPED.suffixifiedPPE pped) typ) - let doc = toMarkup (Text.unlines $ ["```unison", Name.toText fullyQualifiedName, "```"] ++ renderedDocs) + let doc = toMarkup (Text.unlines $ ["``` unison", Name.toText fullyQualifiedName, "```"] ++ renderedDocs) pure $ (completion {_detail = Just renderedType, _documentation = Just doc} :: CompletionItem) LD.TypeReference ref -> case ref of Reference.Builtin {} -> do let renderedBuiltin = ": " - let doc = toMarkup (Text.unlines $ ["```unison", Name.toText fullyQualifiedName, "```"] ++ renderedDocs) + let doc = toMarkup (Text.unlines $ ["``` unison", Name.toText fullyQualifiedName, "```"] ++ renderedDocs) pure $ (completion {_detail = Just renderedBuiltin, _documentation = Just doc} :: CompletionItem) Reference.DerivedId refId -> do decl <- LSPQ.getTypeDeclaration fileUri refId let renderedDecl = ": " <> (Text.pack . Pretty.toPlain typeWidth . Pretty.syntaxToColor $ DeclPrinter.prettyDecl pped ref (HQ.NameOnly relativeName) decl) - let doc = toMarkup (Text.unlines $ ["```unison", Name.toText fullyQualifiedName, "```"] ++ renderedDocs) + let doc = toMarkup (Text.unlines $ ["``` unison", Name.toText fullyQualifiedName, "```"] ++ renderedDocs) pure $ (completion {_detail = Just renderedDecl, _documentation = Just doc} :: CompletionItem) _ -> empty where diff --git a/unison-cli/src/Unison/LSP/Configuration.hs b/unison-cli/src/Unison/LSP/Configuration.hs index e47bff3d76..a95badc33a 100644 --- a/unison-cli/src/Unison/LSP/Configuration.hs +++ b/unison-cli/src/Unison/LSP/Configuration.hs @@ -9,7 +9,7 @@ import Unison.LSP.Types import Unison.Prelude -- | Handle configuration changes. -updateConfig :: Applicative m => Config -> m () +updateConfig :: (Applicative m) => Config -> m () updateConfig _newConfig = pure () parseConfig :: Config -> Value -> Either Text Config diff --git a/unison-cli/src/Unison/LSP/Conversions.hs b/unison-cli/src/Unison/LSP/Conversions.hs index 307fd5c99d..f6163485cb 100644 --- a/unison-cli/src/Unison/LSP/Conversions.hs +++ b/unison-cli/src/Unison/LSP/Conversions.hs @@ -49,3 +49,10 @@ annToRange = \case Ann.External -> Nothing Ann.GeneratedFrom a -> annToRange a Ann.Ann start end -> Just $ Range (uToLspPos start) (uToLspPos end) + +annToURange :: Ann.Ann -> Maybe Range.Range +annToURange = \case + Ann.Intrinsic -> Nothing + Ann.External -> Nothing + Ann.GeneratedFrom a -> annToURange a + Ann.Ann start end -> Just $ Range.Range start end diff --git a/unison-cli/src/Unison/LSP/Diagnostics.hs b/unison-cli/src/Unison/LSP/Diagnostics.hs index bf9d154980..9416fec9bb 100644 --- a/unison-cli/src/Unison/LSP/Diagnostics.hs +++ b/unison-cli/src/Unison/LSP/Diagnostics.hs @@ -9,6 +9,7 @@ import Language.LSP.Protocol.Message qualified as Msg import Language.LSP.Protocol.Types import Unison.LSP.Types import Unison.Prelude +import Unison.Util.Monoid qualified as Monoid reportDiagnostics :: (Foldable f) => @@ -23,15 +24,15 @@ reportDiagnostics docUri fileVersion diags = do let params = PublishDiagnosticsParams {_uri = docUri, _version = fromIntegral <$> fileVersion, _diagnostics = toList $ diags} sendNotification (Msg.TNotificationMessage jsonRPC Msg.SMethod_TextDocumentPublishDiagnostics params) -mkDiagnostic :: Uri -> Range -> DiagnosticSeverity -> Text -> [(Text, Range)] -> Diagnostic -mkDiagnostic uri r severity msg references = +mkDiagnostic :: Uri -> Range -> DiagnosticSeverity -> [DiagnosticTag] -> Text -> [(Text, Range)] -> Diagnostic +mkDiagnostic uri r severity tags msg references = Diagnostic { _range = r, _severity = Just severity, _code = Nothing, -- We could eventually pass error codes here _source = Just "unison", _message = msg, - _tags = Nothing, + _tags = Monoid.whenM (not $ null tags) (Just tags), _relatedInformation = case references of [] -> Nothing diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index f5f29b5e27..be83ae1810 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -7,6 +7,7 @@ import Control.Monad.Reader import Crypto.Random qualified as Random import Data.Align (alignWith) import Data.Foldable +import Data.Foldable qualified as Foldable import Data.IntervalMap.Lazy (IntervalMap) import Data.IntervalMap.Lazy qualified as IM import Data.Map qualified as Map @@ -35,6 +36,7 @@ import Unison.KindInference.Error qualified as KindInference import Unison.LSP.Conversions import Unison.LSP.Conversions qualified as Cv import Unison.LSP.Diagnostics (DiagnosticSeverity (..), mkDiagnostic, reportDiagnostics) +import Unison.LSP.FileAnalysis.UnusedBindings qualified as UnusedBindings import Unison.LSP.Orphans () import Unison.LSP.Types import Unison.LSP.VFS qualified as VFS @@ -55,8 +57,8 @@ import Unison.Referent qualified as Referent import Unison.Result (Note) import Unison.Result qualified as Result import Unison.Symbol (Symbol) -import Unison.Syntax.HashQualified' qualified as HQ' (toText) -import Unison.Syntax.Lexer qualified as L +import Unison.Syntax.HashQualifiedPrime qualified as HQ' (toText) +import Unison.Syntax.Lexer.Unison qualified as L import Unison.Syntax.Name qualified as Name import Unison.Syntax.Parser qualified as Parser import Unison.Syntax.TypePrinter qualified as TypePrinter @@ -77,7 +79,7 @@ import Witherable -- | Lex, parse, and typecheck a file. checkFile :: (HasUri d Uri) => d -> Lsp (Maybe FileAnalysis) checkFile doc = runMaybeT do - currentPath <- lift getCurrentPath + pp <- lift getCurrentProjectPath let fileUri = doc ^. uri (fileVersion, contents) <- VFS.getFileContents fileUri parseNames <- lift getCurrentNames @@ -90,19 +92,50 @@ checkFile doc = runMaybeT do let parsingEnv = Parser.ParsingEnv { uniqueNames = uniqueName, - uniqueTypeGuid = Cli.loadUniqueTypeGuid currentPath, - names = parseNames + uniqueTypeGuid = Cli.loadUniqueTypeGuid pp, + names = parseNames, + maybeNamespace = Nothing, + localNamespacePrefixedTypesAndConstructors = mempty } - (notes, parsedFile, typecheckedFile) <- do + (localBindingTypes, notes, parsedFile, typecheckedFile) <- do liftIO do Codebase.runTransaction cb do parseResult <- Parsers.parseFile (Text.unpack sourceName) (Text.unpack srcText) parsingEnv case Result.fromParsing parseResult of - Result.Result parsingNotes Nothing -> pure (parsingNotes, Nothing, Nothing) + Result.Result parsingNotes Nothing -> pure (mempty, parsingNotes, Nothing, Nothing) Result.Result _ (Just parsedFile) -> do typecheckingEnv <- computeTypecheckingEnvironment (ShouldUseTndr'Yes parsingEnv) cb ambientAbilities parsedFile let Result.Result typecheckingNotes maybeTypecheckedFile = FileParsers.synthesizeFile typecheckingEnv parsedFile - pure (typecheckingNotes, Just parsedFile, maybeTypecheckedFile) + for maybeTypecheckedFile \tf -> do + let parsedVars = + UF.terms parsedFile + & foldMap (ABT.allVars . snd) + let typeCheckvars = + UF.hashTermsId tf + & foldMap (\(_a, _tr, _wk, trm, _typ) -> ABT.allVars trm) + Debug.debugM Debug.Temp "Parsed Vars" $ parsedVars + Debug.debugM Debug.Temp "Typecheck Vars" $ typeCheckvars + + symbolTypes <- + typecheckingNotes + & Foldable.toList + & reverse -- Type notes that come later in typechecking have more information filled in. + & foldMap \case + Result.TypeInfo (Context.VarBinding v typ) -> Map.singleton v typ + _ -> mempty + & pure + let localBindings = + typecheckingNotes + & Foldable.toList + & reverse -- Type notes that come later in typechecking have more information filled in. + & foldMap \case + Result.TypeInfo (Context.VarMention v loc) -> + case Map.lookup v symbolTypes of + Just typ -> (annToInterval loc) & foldMap \interval -> (IM.singleton interval typ) + _ -> mempty + _ -> mempty + pure (localBindings, typecheckingNotes, Just parsedFile, maybeTypecheckedFile) + filePPED <- lift $ ppedForFileHelper parsedFile typecheckedFile (errDiagnostics, codeActions) <- lift $ analyseFile fileUri srcText filePPED notes let codeActionRanges = @@ -111,12 +144,13 @@ checkFile doc = runMaybeT do & toRangeMap let typeSignatureHints = fromMaybe mempty (mkTypeSignatureHints <$> parsedFile <*> typecheckedFile) let fileSummary = FileSummary.mkFileSummary parsedFile typecheckedFile + let unusedBindingDiagnostics = fileSummary ^.. _Just . to termsBySymbol . folded . folding (\(_topLevelAnn, _refId, trm, _type) -> UnusedBindings.analyseTerm fileUri trm) let tokenMap = getTokenMap tokens conflictWarningDiagnostics <- fold <$> for fileSummary \fs -> lift $ computeConflictWarningDiagnostics fileUri fs let diagnosticRanges = - (errDiagnostics <> conflictWarningDiagnostics) + (errDiagnostics <> conflictWarningDiagnostics <> unusedBindingDiagnostics) & fmap (\d -> (d ^. range, d)) & toRangeMap let fileAnalysis = FileAnalysis {diagnostics = diagnosticRanges, codeActions = codeActionRanges, fileSummary, typeSignatureHints, ..} @@ -192,6 +226,7 @@ computeConflictWarningDiagnostics fileUri fileSummary@FileSummary {fileNames} = fileUri newRange DiagnosticSeverity_Information + [] msg mempty pure $ toDiagnostics conflictedTermLocations <> toDiagnostics conflictedTypeLocations @@ -207,106 +242,107 @@ getTokenMap tokens = analyseNotes :: (Foldable f) => Uri -> PrettyPrintEnv -> String -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction]) analyseNotes fileUri ppe src notes = do - flip foldMapM notes \note -> case note of - Result.TypeError errNote@(Context.ErrorNote {cause}) -> do - let typeErr = TypeError.typeErrorFromNote errNote - ranges = case typeErr of - TypeError.Mismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite - TypeError.BooleanMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite - TypeError.ExistentialMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite - TypeError.FunctionApplication {f} -> singleRange $ ABT.annotation f - TypeError.NotFunctionApplication {f} -> singleRange $ ABT.annotation f - TypeError.AbilityCheckFailure {abilityCheckFailureSite} -> singleRange abilityCheckFailureSite - TypeError.AbilityEqFailure {abilityCheckFailureSite} -> singleRange abilityCheckFailureSite - TypeError.AbilityEqFailureFromAp {expectedSite, mismatchSite} -> do - let locs = [ABT.annotation expectedSite, ABT.annotation mismatchSite] - (r, rs) <- withNeighbours (locs >>= aToR) - pure (r, ("mismatch",) <$> rs) - TypeError.UnguardedLetRecCycle {cycleLocs} -> do - let ranges :: [Range] - ranges = cycleLocs >>= aToR - (range, cycleRanges) <- withNeighbours ranges - pure (range, ("cycle",) <$> cycleRanges) - TypeError.UnknownType {typeSite} -> singleRange typeSite - TypeError.UnknownTerm {termSite} -> singleRange termSite - TypeError.DuplicateDefinitions {defns} -> do - (_v, locs) <- toList defns - (r, rs) <- withNeighbours (locs >>= aToR) - pure (r, ("duplicate definition",) <$> rs) - TypeError.RedundantPattern loc -> singleRange loc - TypeError.UncoveredPatterns loc _pats -> singleRange loc - TypeError.KindInferenceFailure ke -> singleRange (KindInference.lspLoc ke) - -- These type errors don't have custom type error conversions, but some - -- still have valid diagnostics. - TypeError.Other e@(Context.ErrorNote {cause}) -> case cause of - Context.PatternArityMismatch loc _typ _numArgs -> singleRange loc - Context.HandlerOfUnexpectedType loc _typ -> singleRange loc - Context.TypeMismatch {} -> shouldHaveBeenHandled e - Context.IllFormedType {} -> shouldHaveBeenHandled e - Context.UnknownSymbol loc _ -> singleRange loc - Context.UnknownTerm loc _ _ _ -> singleRange loc - Context.AbilityCheckFailure {} -> shouldHaveBeenHandled e - Context.AbilityEqFailure {} -> shouldHaveBeenHandled e - Context.EffectConstructorWrongArgCount {} -> shouldHaveBeenHandled e - Context.MalformedEffectBind {} -> shouldHaveBeenHandled e - Context.DuplicateDefinitions {} -> shouldHaveBeenHandled e - Context.UnguardedLetRecCycle {} -> shouldHaveBeenHandled e - Context.ConcatPatternWithoutConstantLength loc _ -> singleRange loc - Context.DataEffectMismatch _ _ decl -> singleRange $ DD.annotation decl - Context.UncoveredPatterns loc _ -> singleRange loc - Context.RedundantPattern loc -> singleRange loc - Context.InaccessiblePattern loc -> singleRange loc - Context.KindInferenceFailure {} -> shouldHaveBeenHandled e - shouldHaveBeenHandled e = do - Debug.debugM Debug.LSP "This diagnostic should have been handled by a previous case but was not" e - empty - diags = noteDiagnostic note ranges - -- Sort on match accuracy first, then name. - codeActions <- case cause of - Context.UnknownTerm _ v suggestions typ -> do - typeHoleActions <- typeHoleReplacementCodeActions diags v typ - pure $ - nameResolutionCodeActions diags suggestions - <> typeHoleActions - _ -> pure [] - pure (diags, codeActions) - Result.NameResolutionFailures {} -> do - -- TODO: diagnostics/code actions for resolution failures - pure (noteDiagnostic note todoAnnotation, []) - Result.Parsing err -> do - let diags = do - (errMsg, ranges) <- PrintError.renderParseErrors src err - let txtMsg = Text.pack $ Pretty.toPlain 80 errMsg - range <- ranges - pure $ mkDiagnostic fileUri (uToLspRange range) DiagnosticSeverity_Error txtMsg [] - -- TODO: Some parsing errors likely have reasonable code actions - pure (diags, []) - Result.UnknownSymbol _ loc -> - pure (noteDiagnostic note (singleRange loc), []) - Result.TypeInfo {} -> - -- No relevant diagnostics from type info. - pure ([], []) - Result.CompilerBug cbug -> do - let ranges = case cbug of - Result.TopLevelComponentNotFound _ trm -> singleRange $ ABT.annotation trm - Result.ResolvedNameNotFound _ loc _ -> singleRange loc - Result.TypecheckerBug tcbug -> case tcbug of - Context.UnknownDecl _un _ref decls -> decls & foldMap \decl -> singleRange $ DD.annotation decl - Context.UnknownConstructor _un _gcr decl -> singleRange $ DD.annotation decl - Context.UndeclaredTermVariable _sym _con -> todoAnnotation - Context.RetractFailure _el _con -> todoAnnotation - Context.EmptyLetRec trm -> singleRange $ ABT.annotation trm - Context.PatternMatchFailure -> todoAnnotation - Context.EffectConstructorHadMultipleEffects typ -> singleRange $ ABT.annotation typ - Context.FreeVarsInTypeAnnotation _set -> todoAnnotation - Context.UnannotatedReference _ref -> todoAnnotation - Context.MalformedPattern pat -> singleRange $ Pattern.loc pat - Context.UnknownTermReference _ref -> todoAnnotation - Context.UnknownExistentialVariable _sym _con -> todoAnnotation - Context.IllegalContextExtension _con _el _s -> todoAnnotation - Context.OtherBug _s -> todoAnnotation - pure (noteDiagnostic note ranges, []) + foldMapM go notes where + go :: Note Symbol Ann -> Lsp ([Diagnostic], [RangedCodeAction]) + go note = case note of + Result.TypeError errNote@(Context.ErrorNote {cause}) -> do + let typeErr = TypeError.typeErrorFromNote errNote + ranges = case typeErr of + TypeError.Mismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite + TypeError.BooleanMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite + TypeError.ExistentialMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite + TypeError.FunctionApplication {f} -> singleRange $ ABT.annotation f + TypeError.NotFunctionApplication {f} -> singleRange $ ABT.annotation f + TypeError.AbilityCheckFailure {abilityCheckFailureSite} -> singleRange abilityCheckFailureSite + TypeError.AbilityEqFailure {abilityCheckFailureSite} -> singleRange abilityCheckFailureSite + TypeError.AbilityEqFailureFromAp {expectedSite, mismatchSite} -> do + let locs = [ABT.annotation expectedSite, ABT.annotation mismatchSite] + (r, rs) <- withNeighbours (locs >>= aToR) + pure (r, ("mismatch",) <$> rs) + TypeError.UnguardedLetRecCycle {cycleLocs} -> do + let ranges :: [Range] + ranges = cycleLocs >>= aToR + (range, cycleRanges) <- withNeighbours ranges + pure (range, ("cycle",) <$> cycleRanges) + TypeError.UnknownType {typeSite} -> singleRange typeSite + TypeError.UnknownTerm {termSite} -> singleRange termSite + TypeError.DuplicateDefinitions {defns} -> do + (_v, locs) <- toList defns + (r, rs) <- withNeighbours (locs >>= aToR) + pure (r, ("duplicate definition",) <$> rs) + TypeError.RedundantPattern loc -> singleRange loc + TypeError.UncoveredPatterns loc _pats -> singleRange loc + TypeError.KindInferenceFailure ke -> singleRange (KindInference.lspLoc ke) + -- These type errors don't have custom type error conversions, but some + -- still have valid diagnostics. + TypeError.Other e@(Context.ErrorNote {cause}) -> case cause of + Context.PatternArityMismatch loc _typ _numArgs -> singleRange loc + Context.HandlerOfUnexpectedType loc _typ -> singleRange loc + Context.TypeMismatch {} -> shouldHaveBeenHandled e + Context.IllFormedType {} -> shouldHaveBeenHandled e + Context.UnknownSymbol loc _ -> singleRange loc + Context.UnknownTerm loc _ _ _ -> singleRange loc + Context.AbilityCheckFailure {} -> shouldHaveBeenHandled e + Context.AbilityEqFailure {} -> shouldHaveBeenHandled e + Context.EffectConstructorWrongArgCount {} -> shouldHaveBeenHandled e + Context.MalformedEffectBind {} -> shouldHaveBeenHandled e + Context.DuplicateDefinitions {} -> shouldHaveBeenHandled e + Context.UnguardedLetRecCycle {} -> shouldHaveBeenHandled e + Context.ConcatPatternWithoutConstantLength loc _ -> singleRange loc + Context.DataEffectMismatch _ _ decl -> singleRange $ DD.annotation decl + Context.UncoveredPatterns loc _ -> singleRange loc + Context.RedundantPattern loc -> singleRange loc + Context.InaccessiblePattern loc -> singleRange loc + Context.KindInferenceFailure {} -> shouldHaveBeenHandled e + shouldHaveBeenHandled e = do + Debug.debugM Debug.LSP "This diagnostic should have been handled by a previous case but was not" e + empty + diags = noteDiagnostic note ranges + -- Sort on match accuracy first, then name. + codeActions <- case cause of + Context.UnknownTerm _ v suggestions typ -> do + typeHoleActions <- typeHoleReplacementCodeActions diags v typ + pure $ + nameResolutionCodeActions diags suggestions + <> typeHoleActions + _ -> pure [] + pure (diags, codeActions) + Result.NameResolutionFailures {} -> do + -- TODO: diagnostics/code actions for resolution failures + pure (noteDiagnostic note todoAnnotation, []) + Result.Parsing err -> do + let diags = do + (errMsg, ranges) <- PrintError.renderParseErrors src err + let txtMsg = Text.pack $ Pretty.toPlain 80 errMsg + range <- ranges + pure $ mkDiagnostic fileUri (uToLspRange range) DiagnosticSeverity_Error [] txtMsg [] + -- TODO: Some parsing errors likely have reasonable code actions + pure (diags, []) + Result.UnknownSymbol _ loc -> + pure (noteDiagnostic note (singleRange loc), []) + Result.TypeInfo {} -> pure ([], []) + Result.CompilerBug cbug -> do + let ranges = case cbug of + Result.TopLevelComponentNotFound _ trm -> singleRange $ ABT.annotation trm + Result.ResolvedNameNotFound _ loc _ -> singleRange loc + Result.TypecheckerBug tcbug -> case tcbug of + Context.UnknownDecl _un _ref decls -> decls & foldMap \decl -> singleRange $ DD.annotation decl + Context.UnknownConstructor _un _gcr decl -> singleRange $ DD.annotation decl + Context.UndeclaredTermVariable _sym _con -> todoAnnotation + Context.RetractFailure _el _con -> todoAnnotation + Context.EmptyLetRec trm -> singleRange $ ABT.annotation trm + Context.PatternMatchFailure -> todoAnnotation + Context.EffectConstructorHadMultipleEffects typ -> singleRange $ ABT.annotation typ + Context.FreeVarsInTypeAnnotation _set -> todoAnnotation + Context.UnannotatedReference _ref -> todoAnnotation + Context.MalformedPattern pat -> singleRange $ Pattern.loc pat + Context.UnknownTermReference _ref -> todoAnnotation + Context.UnknownExistentialVariable _sym _con -> todoAnnotation + Context.IllegalContextExtension _con _el _s -> todoAnnotation + Context.OtherBug _s -> todoAnnotation + pure (noteDiagnostic note ranges, []) + -- Diagnostics with this return value haven't been properly configured yet. todoAnnotation = [] singleRange :: Ann -> [(Range, [a])] @@ -334,7 +370,7 @@ analyseNotes fileUri ppe src notes = do let msg = Text.pack $ Pretty.toPlain 80 $ PrintError.printNoteWithSource ppe src note in do (range, references) <- ranges - pure $ mkDiagnostic fileUri range DiagnosticSeverity_Error msg references + pure $ mkDiagnostic fileUri range DiagnosticSeverity_Error [] msg references -- Suggest name replacements or qualifications when there's ambiguity nameResolutionCodeActions :: [Diagnostic] -> [Context.Suggestion Symbol Ann] -> [RangedCodeAction] nameResolutionCodeActions diags suggestions = do diff --git a/unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs b/unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs new file mode 100644 index 0000000000..5dd7c14cad --- /dev/null +++ b/unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs @@ -0,0 +1,99 @@ +module Unison.LSP.FileAnalysis.UnusedBindings where + +import Data.Foldable qualified as Foldable +import Data.Map qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Language.LSP.Protocol.Types (Diagnostic) +import Language.LSP.Protocol.Types qualified as Lsp +import U.Core.ABT (ABT (..)) +import U.Core.ABT qualified as ABT +import Unison.LSP.Conversions qualified as Cv +import Unison.LSP.Diagnostics qualified as Diagnostic +import Unison.Parser.Ann (Ann) +import Unison.Prelude +import Unison.Symbol (Symbol (..)) +import Unison.Term (Term) +import Unison.Term qualified as Term +import Unison.Util.List qualified as ListUtils +import Unison.Util.Range qualified as Range +import Unison.Util.Recursion +import Unison.Var qualified as Var + +data VarUsages = VarUsages + { unusedVars :: Map Symbol (Set Ann), + usedVars :: Set Symbol, + -- This is generally a copy of usedVars, except that we _don't_ remove variables when they go out of scope. + -- This is solely so we have the information to handle an edge case in pattern guards where vars are independently + -- brought into scope in BOTH the guards and the body of a match case, and we want to count a var as used if it + -- appears in _either_. + allUsedVars :: Set Symbol + } + +instance Semigroup VarUsages where + VarUsages a b c <> VarUsages a' b' c' = + VarUsages (Map.unionWith (<>) a a') (b <> b') (c <> c') + +instance Monoid VarUsages where + mempty = VarUsages mempty mempty mempty + +analyseTerm :: Lsp.Uri -> Term Symbol Ann -> [Diagnostic] +analyseTerm fileUri tm = + let (VarUsages {unusedVars}) = cata alg tm + vars = + Map.toList unusedVars & mapMaybe \(v, ann) -> do + (,ann) <$> getRelevantVarName v + diagnostics = + vars & foldMap \(varName, anns) -> do + ann <- Set.toList anns + range <- maybeToList $ Cv.annToURange ann + -- Limit the range to the first line of the binding to not be too annoying. + -- Maybe in the future we can get the actual annotation of the variable name. + let lspRange = Cv.uToLspRange . Range.startingLine $ range + pure $ Diagnostic.mkDiagnostic fileUri lspRange Diagnostic.DiagnosticSeverity_Warning [Lsp.DiagnosticTag_Unnecessary] ("Unused binding " <> tShow varName <> ". Use the binding, or prefix it with an _ to dismiss this warning.") [] + in diagnostics + where + getRelevantVarName :: Symbol -> Maybe Text + getRelevantVarName = \case + -- Sometimes 'do' gets a binding of '()', which we don't care about + Symbol _ (Var.User "()") -> Nothing + Symbol _ (Var.User "") -> Nothing + -- We only care about user bindings which don't start with an underscore + Symbol _ (Var.User n) -> do + guard (not (Text.isPrefixOf "_" n)) + Just n + _ -> Nothing + alg :: Algebra (ABT.Term' (Term.F Symbol Ann Ann) Symbol Ann) VarUsages + alg (ABT.Term' _ ann abt) = case abt of + Var v -> VarUsages {unusedVars = mempty, usedVars = Set.singleton v, allUsedVars = Set.singleton v} + Cycle x -> x + Abs v (VarUsages {unusedVars, usedVars, allUsedVars}) -> + if v `Set.member` usedVars + then VarUsages {unusedVars, usedVars = Set.delete v usedVars, allUsedVars} + else VarUsages {unusedVars = Map.insert v (Set.singleton ann) unusedVars, usedVars, allUsedVars} + Tm fx -> + case fx of + -- We need to special-case pattern guards because the pattern, guard, and body treat each of their vars in + -- their own independent scopes, even though the vars created in the pattern are the same ones used in the + -- guards and bindings :shrug: + Term.Match scrutinee cases -> + let -- There's a separate case for every guard on a single pattern, so we first do our best to group up cases with the same pattern. + -- Otherwise, a var may be reported unused in one branch of a guard even though it's used in another branch. + groupedCases = ListUtils.groupBy (\(Term.MatchCase pat _ _) -> pat) cases + caseVars = + groupedCases & foldMap \singlePatCases -> + let (VarUsages {unusedVars = unused, usedVars = used, allUsedVars = allUsed}) = + singlePatCases + & foldMap + ( \(Term.MatchCase pat guard body) -> + -- This is imprecise, but it's quite annoying to get the actual ann of the unused bindings, so + -- we just use the FULL span of the pattern for now. We could fix this with a bit + -- of elbow grease. + let patSpanAnn = fold pat + combindedVarUsages = fold guard <> body + in combindedVarUsages {unusedVars = (unusedVars combindedVarUsages) $> (Set.singleton patSpanAnn)} + ) + actuallyUnusedVars = unused & Map.filterWithKey \k _ -> k `Set.notMember` allUsed + in VarUsages {unusedVars = actuallyUnusedVars, usedVars = used, allUsedVars = allUsed} + in scrutinee <> caseVars + _ -> Foldable.fold fx diff --git a/unison-cli/src/Unison/LSP/Formatting.hs b/unison-cli/src/Unison/LSP/Formatting.hs index 48e46d8028..ebba4b1a81 100644 --- a/unison-cli/src/Unison/LSP/Formatting.hs +++ b/unison-cli/src/Unison/LSP/Formatting.hs @@ -8,6 +8,7 @@ import Language.LSP.Protocol.Lens import Language.LSP.Protocol.Message qualified as Msg import Language.LSP.Protocol.Types import Unison.Codebase.Editor.HandleInput.FormatFile qualified as Formatting +import Unison.Codebase.ProjectPath qualified as PP import Unison.LSP.Conversions (lspToURange, uToLspRange) import Unison.LSP.FileAnalysis (getFileAnalysis) import Unison.LSP.FileAnalysis qualified as FileAnalysis @@ -30,10 +31,10 @@ formatDefs :: Uri -> Maybe (Set Range {- the ranges to format, if Nothing then f formatDefs fileUri mayRangesToFormat = fromMaybe [] <$> runMaybeT do FileAnalysis {parsedFile = mayParsedFile, typecheckedFile = mayTypecheckedFile} <- getFileAnalysis fileUri - currentPath <- lift getCurrentPath + pp <- lift getCurrentProjectPath Config {formattingWidth} <- lift getConfig MaybeT $ - Formatting.formatFile (\uf tf -> FileAnalysis.ppedForFileHelper uf tf) formattingWidth currentPath mayParsedFile mayTypecheckedFile (Set.map lspToURange <$> mayRangesToFormat) + Formatting.formatFile (\uf tf -> FileAnalysis.ppedForFileHelper uf tf) formattingWidth (pp ^. PP.absPath_) mayParsedFile mayTypecheckedFile (Set.map lspToURange <$> mayRangesToFormat) <&> (fmap . fmap) uTextReplacementToLSP where uTextReplacementToLSP :: Formatting.TextReplacement -> TextEdit diff --git a/unison-cli/src/Unison/LSP/Hover.hs b/unison-cli/src/Unison/LSP/Hover.hs index aa6e6b7cf3..f1fbee0a2d 100644 --- a/unison-cli/src/Unison/LSP/Hover.hs +++ b/unison-cli/src/Unison/LSP/Hover.hs @@ -5,13 +5,16 @@ module Unison.LSP.Hover where import Control.Lens hiding (List) import Control.Monad.Reader +import Data.IntervalMap.Lazy qualified as IM import Data.Text qualified as Text import Language.LSP.Protocol.Lens import Language.LSP.Protocol.Message qualified as Msg import Language.LSP.Protocol.Types import Unison.ABT qualified as ABT +import Unison.Debug qualified as Debug import Unison.HashQualified qualified as HQ import Unison.LSP.FileAnalysis (ppedForFile) +import Unison.LSP.FileAnalysis qualified as FileAnalysis import Unison.LSP.Queries qualified as LSPQ import Unison.LSP.Types import Unison.LSP.VFS qualified as VFS @@ -24,18 +27,18 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference qualified as Reference import Unison.Runtime.IOSource qualified as IOSource import Unison.Symbol (Symbol) +import Unison.Symbol qualified as Symbol import Unison.Syntax.DeclPrinter qualified as DeclPrinter import Unison.Syntax.Name qualified as Name import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Term qualified as Term +import Unison.Type qualified as Type import Unison.Util.Pretty qualified as Pretty +import Unison.Var (Var) +import Unison.Var qualified as Var import UnliftIO qualified -- | Hover help handler --- --- TODO: --- * Add docs --- * Resolve fqn on hover hoverHandler :: Msg.TRequestMessage 'Msg.Method_TextDocumentHover -> (Either Msg.ResponseError (Msg.MessageResult 'Msg.Method_TextDocumentHover) -> Lsp ()) -> Lsp () hoverHandler m respond = do respond . Right . maybe (InR Null) InL =<< runMaybeT do @@ -49,10 +52,10 @@ hoverHandler m respond = do hoverInfo :: Uri -> Position -> MaybeT Lsp Text hoverInfo uri pos = - (hoverInfoForRef <|> hoverInfoForLiteral) + (hoverInfoForRef <|> hoverInfoForLiteral <|> hoverInfoForLocalVar) where markdownify :: Text -> Text - markdownify rendered = Text.unlines ["```unison", rendered, "```"] + markdownify rendered = Text.unlines ["``` unison", rendered, "```"] prettyWidth :: Pretty.Width prettyWidth = 40 hoverInfoForRef :: MaybeT Lsp Text @@ -100,9 +103,14 @@ hoverInfo uri pos = pure typ LD.TermReferent ref -> do typ <- LSPQ.getTypeOfReferent uri ref - let renderedType = Text.pack $ TypePrinter.prettyStr (Just prettyWidth) (PPED.suffixifiedPPE pped) typ - pure (symAtCursor <> " : " <> renderedType) + pure $ renderTypeSigForHover pped symAtCursor typ pure . Text.unlines $ [markdownify typeSig] <> renderedDocs + + renderTypeSigForHover :: (Var v) => PPED.PrettyPrintEnvDecl -> Text -> Type.Type v a -> Text + renderTypeSigForHover pped name typ = + let renderedType = Text.pack $ TypePrinter.prettyStr (Just prettyWidth) (PPED.suffixifiedPPE pped) typ + in (name <> " : " <> renderedType) + hoverInfoForLiteral :: MaybeT Lsp Text hoverInfoForLiteral = markdownify <$> do @@ -115,6 +123,29 @@ hoverInfo uri pos = typ <- hoistMaybe $ builtinTypeForPatternLiterals pat pure (": " <> typ) + hoverInfoForLocalVar :: MaybeT Lsp Text + hoverInfoForLocalVar = do + let varFromNode = do + node <- LSPQ.nodeAtPosition uri pos + Debug.debugM Debug.Temp "node" node + case node of + LSPQ.TermNode (Term.Var' v) -> pure $ v + LSPQ.TermNode {} -> empty + LSPQ.TypeNode {} -> empty + LSPQ.PatternNode _pat -> empty + -- let varFromText = VFS.identifierAtPosition uri pos + localVar <- varFromNode -- <|> varFromText + Debug.debugM Debug.Temp "localVar" localVar + FileAnalysis {localBindingTypes} <- FileAnalysis.getFileAnalysis uri + Debug.debugM Debug.Temp "pos" pos + Debug.debugM Debug.Temp "localBindingTypes" localBindingTypes + (_range, typ) <- hoistMaybe $ IM.lookupMin $ IM.intersecting localBindingTypes (IM.ClosedInterval pos pos) + pped <- lift $ ppedForFile uri + let varName = case localVar of + (Symbol.Symbol _ (Var.User name)) -> name + _ -> tShow localVar + pure $ renderTypeSigForHover pped varName typ + hoistMaybe :: Maybe a -> MaybeT Lsp a hoistMaybe = MaybeT . pure diff --git a/unison-cli/src/Unison/LSP/Queries.hs b/unison-cli/src/Unison/LSP/Queries.hs index b6e87497cf..9613781937 100644 --- a/unison-cli/src/Unison/LSP/Queries.hs +++ b/unison-cli/src/Unison/LSP/Queries.hs @@ -198,14 +198,14 @@ instance Functor SourceNode where -- children contain that position. findSmallestEnclosingNode :: Pos -> Term Symbol Ann -> Maybe (SourceNode Ann) findSmallestEnclosingNode pos term - | annIsFilePosition (ABT.annotation term) && not (ABT.annotation term `Ann.contains` pos) = Nothing + | annIsFilePosition ann && not (ann `Ann.contains` pos) = Nothing | Just r <- cleanImplicitUnit term = findSmallestEnclosingNode pos r | otherwise = do -- For leaf nodes we require that they be an in-file position, not Intrinsic or -- external. -- In some rare cases it's possible for an External/Intrinsic node to have children that -- ARE in the file, so we need to make sure we still crawl their children. - let guardInFile = guard (annIsFilePosition (ABT.annotation term)) + let guardInFile = guard (annIsFilePosition ann) let bestChild = case ABT.out term of ABT.Tm f -> case f of Term.Int {} -> guardInFile *> Just (TermNode term) @@ -244,7 +244,7 @@ findSmallestEnclosingNode pos term ABT.Var _v -> guardInFile *> Just (TermNode term) ABT.Cycle r -> findSmallestEnclosingNode pos r ABT.Abs _v r -> findSmallestEnclosingNode pos r - let fallback = if annIsFilePosition (ABT.annotation term) then Just (TermNode term) else Nothing + let fallback = if annIsFilePosition ann then Just (TermNode term) else Nothing bestChild <|> fallback where -- tuples always end in an implicit unit, but it's annotated with the span of the whole @@ -256,6 +256,13 @@ findSmallestEnclosingNode pos term ABT.Tm' (Term.App (ABT.Tm' (Term.App (ABT.Tm' (Term.Constructor (ConstructorReference ref 0))) x)) trm) | ref == Builtins.pairRef && Term.amap (const ()) trm == Builtins.unitTerm () -> Just x _ -> Nothing + ann = getTermSpanAnn term + +-- | Most nodes have the property that their annotation spans all their children, but there are some exceptions. +getTermSpanAnn :: Term Symbol Ann -> Ann +getTermSpanAnn tm = case ABT.out tm of + ABT.Abs _v r -> ABT.annotation tm <> getTermSpanAnn r + _ -> ABT.annotation tm findSmallestEnclosingPattern :: Pos -> Pattern.Pattern Ann -> Maybe (Pattern.Pattern Ann) findSmallestEnclosingPattern pos pat diff --git a/unison-cli/src/Unison/LSP/Types.hs b/unison-cli/src/Unison/LSP/Types.hs index c5fe0e9a95..d2b156cb3e 100644 --- a/unison-cli/src/Unison/LSP/Types.hs +++ b/unison-cli/src/Unison/LSP/Types.hs @@ -24,7 +24,7 @@ import Language.LSP.Server import Language.LSP.Server qualified as LSP import Language.LSP.VFS import Unison.Codebase -import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime (Runtime) import Unison.Debug qualified as Debug import Unison.LSP.Orphans () @@ -41,7 +41,7 @@ import Unison.Server.Backend qualified as Backend import Unison.Server.NameSearch (NameSearch) import Unison.Sqlite qualified as Sqlite import Unison.Symbol -import Unison.Syntax.Lexer qualified as Lexer +import Unison.Syntax.Lexer.Unison qualified as Lexer import Unison.Type (Type) import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Summary (FileSummary (..)) @@ -72,7 +72,7 @@ data Env = Env currentNamesCache :: IO Names, ppedCache :: IO PrettyPrintEnvDecl, nameSearchCache :: IO (NameSearch Sqlite.Transaction), - currentPathCache :: IO Path.Absolute, + currentProjectPathCache :: IO PP.ProjectPath, vfsVar :: MVar VFS, runtime :: Runtime Symbol, -- The information we have for each file. @@ -124,13 +124,15 @@ data FileAnalysis = FileAnalysis notes :: Seq (Note Symbol Ann), diagnostics :: IntervalMap Position [Diagnostic], codeActions :: IntervalMap Position [CodeAction], + -- | The types of local variable bindings keyed by the mention's location. + localBindingTypes :: IntervalMap Position (Type Symbol Ann), typeSignatureHints :: Map Symbol TypeSignatureHint, fileSummary :: Maybe FileSummary } deriving stock (Show) -getCurrentPath :: Lsp Path.Absolute -getCurrentPath = asks currentPathCache >>= liftIO +getCurrentProjectPath :: Lsp PP.ProjectPath +getCurrentProjectPath = asks currentProjectPathCache >>= liftIO getCodebaseCompletions :: Lsp CompletionTree getCodebaseCompletions = asks completionsVar >>= atomically . readTMVar diff --git a/unison-cli/src/Unison/LSP/UCMWorker.hs b/unison-cli/src/Unison/LSP/UCMWorker.hs index 2f28955021..713ce207f6 100644 --- a/unison-cli/src/Unison/LSP/UCMWorker.hs +++ b/unison-cli/src/Unison/LSP/UCMWorker.hs @@ -1,16 +1,18 @@ module Unison.LSP.UCMWorker where import Control.Monad.Reader -import U.Codebase.HashTags import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Names qualified as Branch -import Unison.Codebase.Path qualified as Path -import Unison.Debug qualified as Debug +import Unison.Codebase.ProjectPath (ProjectPath) +import Unison.Codebase.ProjectPath qualified as PP import Unison.LSP.Completion import Unison.LSP.Types +import Unison.LSP.Util.Signal (Signal) +import Unison.LSP.Util.Signal qualified as Signal import Unison.LSP.VFS qualified as VFS import Unison.Names (Names) +import Unison.Prelude import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl import Unison.PrettyPrintEnvDecl.Names qualified as PPED @@ -24,42 +26,43 @@ ucmWorker :: TMVar PrettyPrintEnvDecl -> TMVar Names -> TMVar (NameSearch Sqlite.Transaction) -> - TMVar Path.Absolute -> - STM CausalHash -> - STM Path.Absolute -> + TMVar ProjectPath -> + Signal PP.ProjectPathIds -> Lsp () -ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestRoot getLatestPath = do - Env {codebase, completionsVar} <- ask - let loop :: (CausalHash, Path.Absolute) -> Lsp a - loop (currentRoot, currentPath) = do - Debug.debugM Debug.LSP "LSP path: " currentPath - currentBranch0 <- fmap Branch.head . liftIO $ (Codebase.getBranchAtPath codebase currentPath) - let currentNames = Branch.toNames currentBranch0 - hl <- liftIO $ Codebase.runTransaction codebase Codebase.hashLength - let pped = PPED.makePPED (PPE.hqNamer hl currentNames) (PPE.suffixifyByHash currentNames) - atomically $ do - writeTMVar currentPathVar currentPath - writeTMVar currentNamesVar currentNames - writeTMVar ppedVar pped - writeTMVar nameSearchCacheVar (NameSearch.makeNameSearch hl currentNames) - -- Re-check everything with the new names and ppe - VFS.markAllFilesDirty - atomically do - writeTMVar completionsVar (namesToCompletionTree currentNames) - Debug.debugLogM Debug.LSP "LSP Initialized" - latest <- atomically $ do - latestRoot <- getLatestRoot - latestPath <- getLatestPath - guard $ (currentRoot /= latestRoot || currentPath /= latestPath) - pure (latestRoot, latestPath) - Debug.debugLogM Debug.LSP "LSP Change detected" - loop latest - (rootBranch, currentPath) <- atomically $ do - rootBranch <- getLatestRoot - currentPath <- getLatestPath - pure (rootBranch, currentPath) - loop (rootBranch, currentPath) +ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar changeSignal = do + signalChanges <- Signal.subscribe changeSignal + loop signalChanges Nothing where + loop :: STM PP.ProjectPathIds -> Maybe (Branch.Branch IO) -> Lsp a + loop signalChanges currentBranch = do + Env {codebase, completionsVar} <- ask + getChanges signalChanges currentBranch >>= \case + (_newPP, Nothing) -> loop signalChanges currentBranch + (newPP, Just newBranch) -> do + let newBranch0 = Branch.head newBranch + let newNames = Branch.toNames newBranch0 + hl <- liftIO $ Codebase.runTransaction codebase Codebase.hashLength + let pped = PPED.makePPED (PPE.hqNamer hl newNames) (PPE.suffixifyByHash newNames) + atomically $ do + writeTMVar currentPathVar newPP + writeTMVar currentNamesVar newNames + writeTMVar ppedVar pped + writeTMVar nameSearchCacheVar (NameSearch.makeNameSearch hl newNames) + -- Re-check everything with the new names and ppe + VFS.markAllFilesDirty + atomically do + writeTMVar completionsVar (namesToCompletionTree newNames) + loop signalChanges (Just newBranch) + -- Waits for a possible change, then checks if there's actually any difference to the branches we care about. + -- If so, returns the new branch, otherwise Nothing. + getChanges :: STM PP.ProjectPathIds -> Maybe (Branch.Branch IO) -> Lsp (ProjectPath, Maybe (Branch.Branch IO)) + getChanges signalChanges currentBranch = do + Env {codebase} <- ask + ppIds <- atomically signalChanges + pp <- liftIO . Codebase.runTransaction codebase $ Codebase.resolveProjectPathIds ppIds + atomically $ writeTMVar currentPathVar pp + newBranch <- fmap (fromMaybe Branch.empty) . liftIO $ Codebase.getBranchAtProjectPath codebase pp + pure $ (pp, if Just newBranch == currentBranch then Nothing else Just newBranch) -- This is added in stm-2.5.1, remove this if we upgrade. writeTMVar :: TMVar a -> a -> STM () writeTMVar var a = diff --git a/unison-cli/src/Unison/LSP/Util/IntersectionMap.hs b/unison-cli/src/Unison/LSP/Util/IntersectionMap.hs new file mode 100644 index 0000000000..6122b7a6e4 --- /dev/null +++ b/unison-cli/src/Unison/LSP/Util/IntersectionMap.hs @@ -0,0 +1,111 @@ +module Unison.LSP.Util.IntersectionMap + ( -- * Intersection map + intersectionsFromList, + intersectionsSingleton, + IntersectionRange (..), + IntersectionMap, + smallestIntersection, + + -- * Keyed intersection map + KeyedIntersectionMap, + keyedFromList, + keyedSingleton, + keyedSmallestIntersection, + ) +where + +import Data.List qualified as List +import Data.Map qualified as Map +import Language.LSP.Protocol.Types qualified as LSP +import Unison.Prelude +import Unison.Util.List (safeHead) + +-- | An intersection map where intersections are partitioned by a key. +newtype KeyedIntersectionMap k pos a = KeyedIntersectionMap (Map k (IntersectionMap pos a)) + deriving stock (Show, Eq) + +instance (Ord k, Ord pos) => Semigroup (KeyedIntersectionMap k pos a) where + KeyedIntersectionMap a <> KeyedIntersectionMap b = KeyedIntersectionMap (Map.unionWith (<>) a b) + +instance (Ord k, Ord pos) => Monoid (KeyedIntersectionMap k pos a) where + mempty = KeyedIntersectionMap Map.empty + +keyedFromList :: (Ord k, IntersectionRange pos) => [(k, ((pos, pos), a))] -> KeyedIntersectionMap k pos a +keyedFromList elems = + KeyedIntersectionMap $ + elems + & fmap (\(k, (range, v)) -> (k, intersectionsSingleton range v)) + & Map.fromListWith (<>) + +keyedSingleton :: (Ord k, IntersectionRange pos) => k -> (pos, pos) -> a -> KeyedIntersectionMap k pos a +keyedSingleton k range a = keyedFromList [(k, (range, a))] + +-- | NOTE: Assumes that ranges only NEST and never overlap, which is an invariant that should +-- be maintained by the ABT annotations. +-- +-- Returns the value associated with the tightest span which intersects with the given position. +keyedSmallestIntersection :: (Ord k, IntersectionRange pos) => k -> pos -> KeyedIntersectionMap k pos a -> Maybe ((pos, pos), a) +keyedSmallestIntersection k p (KeyedIntersectionMap m) = do + intersections <- Map.lookup k m + smallestIntersection p intersections + +newtype IntersectionMap pos a = IntersectionMap (Map (pos, pos) a) + deriving stock (Show, Eq) + +instance (Ord pos) => Semigroup (IntersectionMap pos a) where + IntersectionMap a <> IntersectionMap b = IntersectionMap (a <> b) + +instance (Ord pos) => Monoid (IntersectionMap pos a) where + mempty = IntersectionMap mempty + +-- | Class for types that can be used as ranges for intersection maps. +class Ord pos => IntersectionRange pos where + intersects :: pos -> (pos, pos) -> Bool + + -- Returns true if the first bound is tighter than the second. + isTighterThan :: (pos, pos) -> (pos, pos) -> Bool + +instance IntersectionRange LSP.Position where + intersects (LSP.Position l c) ((LSP.Position lStart cStart), (LSP.Position lEnd cEnd)) = + (l >= lStart && l <= lEnd) + && if + | l == lStart && l == lEnd -> c >= cStart && c <= cEnd + | l == lStart -> c >= cStart + | l == lEnd -> c <= cEnd + | otherwise -> True + + ((LSP.Position lStartA cStartA), (LSP.Position lEndA cEndA)) `isTighterThan` ((LSP.Position lStartB cStartB), (LSP.Position lEndB cEndB)) = + if lStartA == lStartB && lEndA == lEndB + then cStartA >= cStartB && cEndA <= cEndB + else lStartA >= lStartB && lEndA <= lEndB + +-- | Construct an intersection map from a list of ranges and values. +-- Duplicates are dropped. +intersectionsFromList :: (Ord pos) => [((pos, pos), a)] -> IntersectionMap pos a +intersectionsFromList elems = + IntersectionMap $ Map.fromList elems + +intersectionsSingleton :: (pos, pos) -> a -> IntersectionMap pos a +intersectionsSingleton range a = IntersectionMap $ Map.singleton range a + +-- | NOTE: Assumes that ranges only NEST and never overlap, which is an invariant that should +-- be maintained by the ABT annotations. +-- +-- Returns the value associated with the tightest span which intersects with the given position. +-- +-- >>> smallestIntersection (LSP.Position 5 1) (intersectionsFromList [((LSP.Position 1 1, LSP.Position 3 1), "a"), ((LSP.Position 2 1, LSP.Position 8 1), "b"), ((LSP.Position 4 1, LSP.Position 6 1), "c")]) +-- Just ((Position {_line = 4, _character = 1},Position {_line = 6, _character = 1}),"c") +-- >>> smallestIntersection (LSP.Position 5 3) (intersectionsFromList [((LSP.Position 1 1, LSP.Position 3 1), "a"), ((LSP.Position 4 2, LSP.Position 6 5), "b"), ((LSP.Position 4 1, LSP.Position 6 6), "c"), ((LSP.Position 7 1, LSP.Position 9 1), "d")]) +-- Just ((Position {_line = 4, _character = 2},Position {_line = 6, _character = 5}),"b") +smallestIntersection :: IntersectionRange pos => pos -> IntersectionMap pos a -> Maybe ((pos, pos), a) +smallestIntersection p (IntersectionMap bounds) = + bounds + & Map.filterWithKey (\b _ -> p `intersects` b) + & Map.toList + & List.sortBy cmp + & safeHead + where + cmp (a, _) (b, _) = + if a `isTighterThan` b + then LT + else GT diff --git a/unison-cli/src/Unison/LSP/Util/Signal.hs b/unison-cli/src/Unison/LSP/Util/Signal.hs new file mode 100644 index 0000000000..e06dfca111 --- /dev/null +++ b/unison-cli/src/Unison/LSP/Util/Signal.hs @@ -0,0 +1,74 @@ +-- | A transactional signal type. +-- Similar to a broadcast channel, but with better memory characteristics when you only care about the latest value. +-- +-- Allows multiple consumers to detect the latest value of a signal, and to be notified when the signal changes. +module Unison.LSP.Util.Signal + ( newSignalIO, + writeSignal, + writeSignalIO, + subscribe, + Signal, + ) +where + +import Control.Monad.STM qualified as STM +import Unison.Prelude +import UnliftIO.STM + +newtype Signal a = Signal (TVar (Maybe a, Int)) + +-- | Create a new signal with an optional initial value. +newSignalIO :: (MonadIO m) => Maybe a -> m (Signal a) +newSignalIO a = do + tvar <- newTVarIO (a, 0) + pure (Signal tvar) + +-- | Update the value of a signal, notifying all subscribers (even if the value didn't change) +writeSignal :: Signal a -> a -> STM () +writeSignal (Signal signalVar) a = do + (_, n) <- readTVar signalVar + writeTVar signalVar (Just a, succ n) + +-- | Update the value of a signal, notifying all subscribers (even if the value didn't change) +writeSignalIO :: (MonadIO m) => Signal a -> a -> m () +writeSignalIO signal a = liftIO $ STM.atomically (writeSignal signal a) + +-- | Subscribe to a signal, returning an STM action which will read the latest NEW value, +-- after successfully reading a new value, subsequent reads will retry until there's a new value written to the signal. +-- +-- Each independent reader should have its own subscription. +-- +-- >>> signal <- newSignalIO (Just "initial") +-- >>> subscriber1 <- subscribe signal +-- >>> subscriber2 <- subscribe signal +-- >>> -- Should return the initial value +-- >>> atomically (optional subscriber1) +-- >>> -- Should retry, since the signal hasn't changed. +-- >>> atomically (optional subscriber1) +-- >>> writeSignalIO signal "new value" +-- >>> -- Each subscriber should return the newest value +-- >>> ("sub1",) <$> atomically (optional subscriber1) +-- >>> ("sub2",) <$> atomically (optional subscriber2) +-- >>> -- Both should now retry +-- >>> ("sub1",) <$> atomically (optional subscriber1) +-- >>> ("sub2",) <$> atomically (optional subscriber2) +-- Just "initial" +-- Nothing +-- ("sub1",Just "new value") +-- ("sub2",Just "new value") +-- ("sub1",Nothing) +-- ("sub2",Nothing) +subscribe :: (MonadIO m) => Signal a -> m (STM a) +subscribe (Signal signalVar) = do + (_, n) <- readTVarIO signalVar + -- Start with a different n, so the subscriber will trigger on its first read. + latestNVar <- newTVarIO (pred n) + pure $ do + (mayA, newN) <- readTVar signalVar + latestN <- readTVar latestNVar + guard (newN /= latestN) + writeTVar latestNVar newN + -- Retry until we have a value. + case mayA of + Nothing -> STM.retry + Just a -> pure a diff --git a/unison-cli/src/Unison/LSP/VFS.hs b/unison-cli/src/Unison/LSP/VFS.hs index 4be5573a45..8244d64615 100644 --- a/unison-cli/src/Unison/LSP/VFS.hs +++ b/unison-cli/src/Unison/LSP/VFS.hs @@ -81,7 +81,11 @@ identifierSplitAtPosition uri pos = do vf <- getVirtualFile uri PosPrefixInfo {fullLine, cursorPos} <- MaybeT (VFS.getCompletionPrefix pos vf) let (before, after) = Text.splitAt (cursorPos ^. character . to fromIntegral) fullLine - pure (Text.takeWhileEnd isIdentifierChar before, Text.takeWhile isIdentifierChar after) + pure + ( Text.takeWhileEnd isIdentifierChar before, + -- names can end with '!', and it's not a force, so we include it in the identifier if it's at the end. + Text.takeWhile (\c -> isIdentifierChar c || c == '!') after + ) where isIdentifierChar c = -- Manually exclude '!' and apostrophe, since those are usually just forces and diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index 32e829c0b1..59845f0608 100644 --- a/unison-cli/src/Unison/Main.hs +++ b/unison-cli/src/Unison/Main.hs @@ -25,10 +25,8 @@ import ArgParse ) import Compat (defaultInterruptHandler, withInterruptHandler) import Control.Concurrent (newEmptyMVar, runInUnboundThread, takeMVar) -import Control.Concurrent.STM import Control.Exception (displayException, evaluate) import Data.ByteString.Lazy qualified as BL -import Data.Configurator.Types (Config) import Data.Either.Validation (Validation (..)) import Data.List.NonEmpty (NonEmpty) import Data.Text qualified as Text @@ -48,6 +46,7 @@ import System.Directory ) import System.Environment (getExecutablePath, getProgName, withArgs) import System.Exit qualified as Exit +import System.Exit qualified as System import System.FilePath ( replaceExtension, takeDirectory, @@ -57,11 +56,11 @@ import System.FilePath ) import System.IO (stderr) import System.IO.CodePage (withCP65001) -import System.IO.Error (catchIOError) import System.IO.Temp qualified as Temp import System.Path qualified as Path -import U.Codebase.HashTags (CausalHash) +import Text.Megaparsec qualified as MP import U.Codebase.Sqlite.Queries qualified as Queries +import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase (Codebase, CodebasePath) import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Input qualified as Input @@ -70,16 +69,20 @@ import Unison.Codebase.Init (CodebaseInitOptions (..), InitError (..), InitResul import Unison.Codebase.Init qualified as CodebaseInit import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..)) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime qualified as Rt import Unison.Codebase.SqliteCodebase qualified as SC -import Unison.Codebase.TranscriptParser qualified as TR +import Unison.Codebase.Transcript.Parser qualified as Transcript +import Unison.Codebase.Transcript.Runner qualified as Transcript import Unison.Codebase.Verbosity qualified as Verbosity -import Unison.CommandLine (plural', watchConfig) +import Unison.CommandLine.Helpers (plural') import Unison.CommandLine.Main qualified as CommandLine import Unison.CommandLine.Types qualified as CommandLine import Unison.CommandLine.Welcome (CodebaseInitStatus (..)) import Unison.CommandLine.Welcome qualified as Welcome +import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..)) import Unison.LSP qualified as LSP +import Unison.LSP.Util.Signal qualified as Signal import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal qualified as PT @@ -91,7 +94,6 @@ import Unison.Symbol (Symbol) import Unison.Util.Pretty qualified as P import Unison.Version (Version) import Unison.Version qualified as Version -import UnliftIO qualified import UnliftIO.Directory (getHomeDirectory) type Runtimes = @@ -138,220 +140,216 @@ main version = do (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName (Text.unpack (Version.gitDescribeWithDate version)) nrtp <- fixNativeRuntimePath (nativeRuntimePath globalOptions) let GlobalOptions {codebasePathOption = mCodePathOption, exitOption, lspFormattingConfig} = globalOptions - withConfig mCodePathOption \config -> do - currentDir <- getCurrentDirectory - case command of - PrintVersion -> - Text.putStrLn $ Text.pack progName <> " version: " <> Version.gitDescribeWithDate version - Init -> do - exitError - ( P.lines - [ "The Init command has been removed", - P.newline, - P.wrap "Use --codebase-create to create a codebase at a specified location and open it:", - P.indentN 2 (P.hiBlue "$ ucm --codebase-create myNewCodebase"), - "Running UCM without the --codebase-create flag: ", - P.indentN 2 (P.hiBlue "$ ucm"), - P.wrap ("will " <> P.bold "always" <> " create a codebase in your home directory if one does not already exist.") + currentDir <- getCurrentDirectory + case command of + PrintVersion -> + Text.putStrLn $ Text.pack progName <> " version: " <> Version.gitDescribeWithDate version + Init -> do + exitError + ( P.lines + [ "The Init command has been removed", + P.newline, + P.wrap "Use --codebase-create to create a codebase at a specified location and open it:", + P.indentN 2 (P.hiBlue "$ ucm --codebase-create myNewCodebase"), + "Running UCM without the --codebase-create flag: ", + P.indentN 2 (P.hiBlue "$ ucm"), + P.wrap ("will " <> P.bold "always" <> " create a codebase in your home directory if one does not already exist.") + ] + ) + Run (RunFromSymbol mainName) args -> do + getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, _, theCodebase) -> do + RTI.withRuntime False RTI.OneOff (Version.gitDescribeWithDate version) \runtime -> do + withArgs args (execute theCodebase runtime mainName) >>= \case + Left err -> exitError err + Right () -> pure () + Run (RunFromFile file mainName) args + | not (isDotU file) -> exitError "Files must have a .u extension." + | otherwise -> do + e <- safeReadUtf8 file + case e of + Left _ -> exitError "I couldn't find that file or it is for some reason unreadable." + Right contents -> do + getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do + withRuntimes nrtp RTI.OneOff \(rt, sbrt, nrt) -> do + let fileEvent = Input.UnisonFileChanged (Text.pack file) contents + let noOpCheckForChanges _ = pure () + let serverUrl = Nothing + startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath + launch + version + currentDir + rt + sbrt + nrt + theCodebase + [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] + serverUrl + (PP.toIds startProjectPath) + initRes + noOpCheckForChanges + CommandLine.ShouldNotWatchFiles + Run (RunFromPipe mainName) args -> do + e <- safeReadUtf8StdIn + case e of + Left _ -> exitError "I had trouble reading this input." + Right contents -> do + getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do + withRuntimes nrtp RTI.OneOff \(rt, sbrt, nrt) -> do + let fileEvent = Input.UnisonFileChanged (Text.pack "") contents + let noOpCheckForChanges _ = pure () + let serverUrl = Nothing + startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath + launch + version + currentDir + rt + sbrt + nrt + theCodebase + [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] + serverUrl + (PP.toIds startProjectPath) + initRes + noOpCheckForChanges + CommandLine.ShouldNotWatchFiles + Run (RunCompiled file) args -> + BL.readFile file >>= \bs -> + try (evaluate $ RTI.decodeStandalone bs) >>= \case + Left (PE _cs err) -> do + exitError . P.lines $ + [ P.wrap . P.text $ + "I was unable to parse this file as a compiled\ + \ program. The parser generated the following error:", + "", + P.indentN 2 $ err ] - ) - Run (RunFromSymbol mainName) args -> do - getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, _, theCodebase) -> do - RTI.withRuntime False RTI.OneOff (Version.gitDescribeWithDate version) \runtime -> do - withArgs args (execute theCodebase runtime mainName) >>= \case - Left err -> exitError err - Right () -> pure () - Run (RunFromFile file mainName) args - | not (isDotU file) -> exitError "Files must have a .u extension." - | otherwise -> do - e <- safeReadUtf8 file - case e of - Left _ -> exitError "I couldn't find that file or it is for some reason unreadable." - Right contents -> do - getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do - withRuntimes nrtp RTI.OneOff \(rt, sbrt, nrt) -> do - let fileEvent = Input.UnisonFileChanged (Text.pack file) contents - let noOpRootNotifier _ = pure () - let noOpPathNotifier _ = pure () - let serverUrl = Nothing - let startPath = Nothing + Right (Left err) -> + exitError . P.lines $ + [ P.wrap . P.text $ + "I was unable to parse this file as a compiled\ + \ program. The parser generated the following error:", + "", + P.indentN 2 . P.wrap $ P.string err + ] + Left _ -> do + exitError . P.wrap . P.text $ + "I was unable to parse this file as a compiled\ + \ program. The parser generated an unrecognized error." + Right (Right (v, rf, combIx, sto)) + | not vmatch -> mismatchMsg + | otherwise -> + withArgs args (RTI.runStandalone False sto combIx) >>= \case + Left err -> exitError err + Right () -> pure () + where + vmatch = v == Version.gitDescribeWithDate version + ws s = P.wrap (P.text s) + ifile + | 'c' : 'u' : '.' : rest <- reverse file = reverse rest + | otherwise = file + mismatchMsg = + PT.putPrettyLn . P.lines $ + [ ws + "I can't run this compiled program since \ + \it works with a different version of Unison \ + \than the one you're running.", + "", + "Compiled file version", + P.indentN 4 $ P.text v, + "", + "Your version", + P.indentN 4 $ P.text $ Version.gitDescribeWithDate version, + "", + P.wrap $ + "The program was compiled from hash " + <> (P.text $ "`" <> rf <> "`.") + <> "If you have that hash in your codebase," + <> "you can do:", + "", + P.indentN 4 $ + ".> compile " + <> P.text rf + <> " " + <> P.string ifile, + "", + P.wrap + "to produce a new compiled program \ + \that matches your version of Unison." + ] + Transcript shouldFork shouldSaveCodebase mrtsStatsFp transcriptFiles -> do + let action = runTranscripts version Verbosity.Verbose renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption nrtp transcriptFiles + case mrtsStatsFp of + Nothing -> action + Just fp -> recordRtsStats fp action + Launch isHeadless codebaseServerOpts mayStartingProject shouldWatchFiles -> do + getCodebaseOrExit mCodePathOption (SC.MigrateAfterPrompt SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do + withRuntimes nrtp RTI.Persistent \(runtime, sbRuntime, nRuntime) -> do + startingProjectPath <- do + -- If the user didn't provide a starting path on the command line, put them in the most recent + -- path they cd'd to + case mayStartingProject of + Just startingProject -> do + Codebase.runTransaction theCodebase (ProjectUtils.getProjectAndBranchByNames startingProject) >>= \case + Nothing -> do + PT.putPrettyLn $ + P.callout + "❓" + ( P.lines + [ P.indentN 2 "I couldn't find the project branch: " <> P.text (into @Text startingProject) + ] + ) + System.exitFailure + Just pab -> do + pure $ PP.fromProjectAndBranch pab Path.absoluteEmpty + Nothing -> do + Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath + currentPP <- Codebase.runTransaction theCodebase do + PP.toIds <$> Codebase.expectCurrentProjectPath + changeSignal <- Signal.newSignalIO (Just currentPP) + let lspCheckForChanges pp = Signal.writeSignalIO changeSignal pp + -- Unfortunately, the windows IO manager on GHC 8.* is prone to just hanging forever + -- when waiting for input on handles, so if we listen for LSP connections it will + -- prevent UCM from shutting down properly. Hopefully we can re-enable LSP on + -- Windows when we move to GHC 9.* + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1224 + void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime changeSignal + Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do + case exitOption of + DoNotExit -> do + case isHeadless of + Headless -> do + PT.putPrettyLn $ + P.lines + [ "I've started the Codebase API server at", + P.text $ Server.urlFor Server.Api baseUrl, + "and the Codebase UI at", + P.text $ Server.urlFor (Server.ProjectBranchUI (ProjectAndBranch (UnsafeProjectName "scratch") (UnsafeProjectBranchName "main")) Path.absoluteEmpty Nothing) baseUrl + ] + PT.putPrettyLn $ + P.string "Running the codebase manager headless with " + <> P.shown GHC.Conc.numCapabilities + <> " " + <> plural' GHC.Conc.numCapabilities "cpu" "cpus" + <> "." + mvar <- newEmptyMVar + takeMVar mvar + WithCLI -> do + PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..." + launch version currentDir - config - rt - sbrt - nrt + runtime + sbRuntime + nRuntime theCodebase - [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] - serverUrl - startPath + [] + (Just baseUrl) + (PP.toIds startingProjectPath) initRes - noOpRootNotifier - noOpPathNotifier - CommandLine.ShouldNotWatchFiles - Run (RunFromPipe mainName) args -> do - e <- safeReadUtf8StdIn - case e of - Left _ -> exitError "I had trouble reading this input." - Right contents -> do - getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do - withRuntimes nrtp RTI.OneOff \(rt, sbrt, nrt) -> do - let fileEvent = Input.UnisonFileChanged (Text.pack "") contents - let noOpRootNotifier _ = pure () - let noOpPathNotifier _ = pure () - let serverUrl = Nothing - let startPath = Nothing - launch - version - currentDir - config - rt - sbrt - nrt - theCodebase - [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] - serverUrl - startPath - initRes - noOpRootNotifier - noOpPathNotifier - CommandLine.ShouldNotWatchFiles - Run (RunCompiled file) args -> - BL.readFile file >>= \bs -> - try (evaluate $ RTI.decodeStandalone bs) >>= \case - Left (PE _cs err) -> do - exitError . P.lines $ - [ P.wrap . P.text $ - "I was unable to parse this file as a compiled\ - \ program. The parser generated the following error:", - "", - P.indentN 2 $ err - ] - Right (Left err) -> - exitError . P.lines $ - [ P.wrap . P.text $ - "I was unable to parse this file as a compiled\ - \ program. The parser generated the following error:", - "", - P.indentN 2 . P.wrap $ P.string err - ] - Left _ -> do - exitError . P.wrap . P.text $ - "I was unable to parse this file as a compiled\ - \ program. The parser generated an unrecognized error." - Right (Right (v, rf, w, sto)) - | not vmatch -> mismatchMsg - | otherwise -> - withArgs args (RTI.runStandalone sto w) >>= \case - Left err -> exitError err - Right () -> pure () - where - vmatch = v == Version.gitDescribeWithDate version - ws s = P.wrap (P.text s) - ifile - | 'c' : 'u' : '.' : rest <- reverse file = reverse rest - | otherwise = file - mismatchMsg = - PT.putPrettyLn . P.lines $ - [ ws - "I can't run this compiled program since \ - \it works with a different version of Unison \ - \than the one you're running.", - "", - "Compiled file version", - P.indentN 4 $ P.text v, - "", - "Your version", - P.indentN 4 $ P.text $ Version.gitDescribeWithDate version, - "", - P.wrap $ - "The program was compiled from hash " - <> (P.text $ "`" <> rf <> "`.") - <> "If you have that hash in your codebase," - <> "you can do:", - "", - P.indentN 4 $ - ".> compile " - <> P.text rf - <> " " - <> P.string ifile, - "", - P.wrap - "to produce a new compiled program \ - \that matches your version of Unison." - ] - Transcript shouldFork shouldSaveCodebase mrtsStatsFp transcriptFiles -> do - let action = runTranscripts version Verbosity.Verbose renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption nrtp transcriptFiles - case mrtsStatsFp of - Nothing -> action - Just fp -> recordRtsStats fp action - Launch isHeadless codebaseServerOpts mayStartingPath shouldWatchFiles -> do - getCodebaseOrExit mCodePathOption (SC.MigrateAfterPrompt SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do - withRuntimes nrtp RTI.Persistent \(runtime, sbRuntime, nRuntime) -> do - startingPath <- case isHeadless of - WithCLI -> do - -- If the user didn't provide a starting path on the command line, put them in the most recent - -- path they cd'd to - case mayStartingPath of - Just startingPath -> pure startingPath - Nothing -> do - segments <- Codebase.runTransaction theCodebase Queries.expectMostRecentNamespace - pure (Path.Absolute (Path.fromList segments)) - Headless -> pure $ fromMaybe defaultInitialPath mayStartingPath - rootCausalHash <- Codebase.runTransaction theCodebase (Queries.expectNamespaceRoot >>= Queries.expectCausalHash) - rootCausalHashVar <- newTVarIO rootCausalHash - pathVar <- newTVarIO startingPath - let notifyOnRootChanges :: CausalHash -> STM () - notifyOnRootChanges b = do - writeTVar rootCausalHashVar b - let notifyOnPathChanges :: Path.Absolute -> STM () - notifyOnPathChanges = writeTVar pathVar - -- Unfortunately, the windows IO manager on GHC 8.* is prone to just hanging forever - -- when waiting for input on handles, so if we listen for LSP connections it will - -- prevent UCM from shutting down properly. Hopefully we can re-enable LSP on - -- Windows when we move to GHC 9.* - -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1224 - void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar rootCausalHashVar) (readTVar pathVar) - Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do - case exitOption of - DoNotExit -> do - case isHeadless of - Headless -> do - PT.putPrettyLn $ - P.lines - [ "I've started the Codebase API server at", - P.text $ Server.urlFor Server.Api baseUrl, - "and the Codebase UI at", - P.text $ Server.urlFor (Server.LooseCodeUI Path.absoluteEmpty Nothing) baseUrl - ] - PT.putPrettyLn $ - P.string "Running the codebase manager headless with " - <> P.shown GHC.Conc.numCapabilities - <> " " - <> plural' GHC.Conc.numCapabilities "cpu" "cpus" - <> "." - mvar <- newEmptyMVar - takeMVar mvar - WithCLI -> do - PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..." - - launch - version - currentDir - config - runtime - sbRuntime - nRuntime - theCodebase - [] - (Just baseUrl) - (Just startingPath) - initRes - notifyOnRootChanges - notifyOnPathChanges - shouldWatchFiles - Exit -> do Exit.exitSuccess + lspCheckForChanges + shouldWatchFiles + Exit -> do Exit.exitSuccess where -- (runtime, sandboxed runtime) withRuntimes :: FilePath -> RTI.RuntimeHost -> (Runtimes -> IO a) -> IO a @@ -361,17 +359,6 @@ main version = do action . (runtime,sbRuntime,) -- startNativeRuntime saves the path to `unison-runtime` =<< RTI.startNativeRuntime (Version.gitDescribeWithDate version) nrtp - withConfig :: Maybe CodebasePathOption -> (Config -> IO a) -> IO a - withConfig mCodePathOption action = do - UnliftIO.bracket - ( do - let mcodepath = fmap codebasePathOptionToPath mCodePathOption - configFilePath <- getConfigFilePath mcodepath - catchIOError (watchConfig configFilePath) $ \_ -> - exitError "Your .unisonConfig could not be loaded. Check that it's correct!" - ) - (\(_config, cancel) -> cancel) - (\(config, _cancel) -> action config) -- | Set user agent and configure TLS on global http client. -- Note that the authorized http client is distinct from the global http client. @@ -411,57 +398,61 @@ prepareTranscriptDir verbosity shouldFork mCodePathOption shouldSaveCodebase = d runTranscripts' :: Version -> String -> - Maybe FilePath -> FilePath -> FilePath -> NonEmpty MarkdownFile -> IO Bool -runTranscripts' version progName mcodepath nativeRtp transcriptDir markdownFiles = do +runTranscripts' version progName nativeRtp transcriptDir markdownFiles = do currentDir <- getCurrentDirectory - configFilePath <- getConfigFilePath mcodepath -- We don't need to create a codebase through `getCodebaseOrExit` as we've already done so previously. - and <$> getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, codebasePath, theCodebase) -> do - TR.withTranscriptRunner Verbosity.Verbose (Version.gitDescribeWithDate version) nativeRtp (Just configFilePath) $ \runTranscript -> do - for markdownFiles $ \(MarkdownFile fileName) -> do - transcriptSrc <- readUtf8 fileName - result <- runTranscript fileName transcriptSrc (codebasePath, theCodebase) - let outputFile = replaceExtension (currentDir fileName) ".output.md" - (output, succeeded) <- case result of - Left err -> case err of - TR.TranscriptParseError err -> do - PT.putPrettyLn $ - P.callout - "❓" - ( P.lines - [ P.indentN 2 "An error occurred while parsing the following file: " <> P.string fileName, - "", - P.indentN 2 $ P.text err - ] - ) - pure (err, False) - TR.TranscriptRunFailure err -> do - PT.putPrettyLn $ - P.callout - "❓" - ( P.lines - [ P.indentN 2 "An error occurred while running the following file: " <> P.string fileName, - "", - P.indentN 2 $ P.text err, - P.text $ - "Run `" - <> Text.pack progName - <> " --codebase " - <> Text.pack codebasePath - <> "` " - <> "to do more work with it." - ] + and + <$> getCodebaseOrExit + (Just (DontCreateCodebaseWhenMissing transcriptDir)) + (SC.MigrateAutomatically SC.Backup SC.Vacuum) + \(_, codebasePath, theCodebase) -> do + let isTest = False + Transcript.withRunner + isTest + Verbosity.Verbose + (Version.gitDescribeWithDate version) + nativeRtp + \runTranscript -> do + for markdownFiles $ \(MarkdownFile fileName) -> do + transcriptSrc <- readUtf8 fileName + result <- runTranscript fileName transcriptSrc (codebasePath, theCodebase) + let outputFile = replaceExtension (currentDir fileName) ".output.md" + output <- + either + ( uncurry ($>) . first (PT.putPrettyLn . P.callout "❓" . P.lines) . \case + Transcript.ParseError err -> + let msg = MP.errorBundlePretty err + in ( [ P.indentN 2 $ + "An error occurred while parsing the following file: " <> P.string fileName, + "", + P.indentN 2 $ P.string msg + ], + Text.pack msg + ) + Transcript.RunFailure msg -> + ( [ P.indentN 2 $ "An error occurred while running the following file: " <> P.string fileName, + "", + P.indentN 2 (P.text . Transcript.formatStanzas $ toList msg), + P.string $ + "Run `" + <> progName + <> " --codebase " + <> codebasePath + <> "` " + <> "to do more work with it." + ], + Transcript.formatStanzas $ toList msg + ) ) - pure (err, False) - Right mdOut -> do - pure (mdOut, True) - writeUtf8 outputFile output - putStrLn $ "💾 Wrote " <> outputFile - pure succeeded + (pure . Transcript.formatStanzas . toList) + result + writeUtf8 outputFile output + putStrLn $ "💾 Wrote " <> outputFile + pure $ isRight result runTranscripts :: Version -> @@ -491,7 +482,7 @@ runTranscripts version verbosity renderUsageInfo shouldFork shouldSaveTempCodeba progName <- getProgName transcriptDir <- prepareTranscriptDir verbosity shouldFork mCodePathOption shouldSaveTempCodebase completed <- - runTranscripts' version progName (Just transcriptDir) nativeRtp transcriptDir markdownFiles + runTranscripts' version progName nativeRtp transcriptDir markdownFiles case shouldSaveTempCodebase of DontSaveCodebase -> removeDirectoryRecursive transcriptDir SaveCodebase _ -> @@ -512,26 +503,21 @@ runTranscripts version verbosity renderUsageInfo shouldFork shouldSaveTempCodeba ) when (not completed) $ Exit.exitWith (Exit.ExitFailure 1) -defaultInitialPath :: Path.Absolute -defaultInitialPath = Path.absoluteEmpty - launch :: Version -> FilePath -> - Config -> Rt.Runtime Symbol -> Rt.Runtime Symbol -> Rt.Runtime Symbol -> Codebase.Codebase IO Symbol Ann -> [Either Input.Event Input.Input] -> Maybe Server.BaseUrl -> - Maybe Path.Absolute -> + PP.ProjectPathIds -> InitResult -> - (CausalHash -> STM ()) -> - (Path.Absolute -> STM ()) -> + (PP.ProjectPathIds -> IO ()) -> CommandLine.ShouldWatchFiles -> IO () -launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl mayStartingPath initResult notifyRootChange notifyPathChange shouldWatchFiles = do +launch version dir runtime sbRuntime nRuntime codebase inputs serverBaseUrl startingPath initResult lspCheckForChanges shouldWatchFiles = do showWelcomeHint <- Codebase.runTransaction codebase Queries.doProjectsExist let isNewCodebase = case initResult of CreatedCodebase -> NewlyCreatedCodebase @@ -541,8 +527,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU in CommandLine.main dir welcome - (fromMaybe defaultInitialPath mayStartingPath) - config + startingPath inputs runtime sbRuntime @@ -550,8 +535,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU codebase serverBaseUrl ucmVersion - notifyRootChange - notifyPathChange + lspCheckForChanges shouldWatchFiles newtype MarkdownFile = MarkdownFile FilePath @@ -565,13 +549,11 @@ markdownFile md = case takeExtension md of isDotU :: String -> Bool isDotU file = takeExtension file == ".u" -getConfigFilePath :: Maybe FilePath -> IO FilePath -getConfigFilePath mcodepath = ( ".unisonConfig") <$> Codebase.getCodebaseDir mcodepath - getCodebaseOrExit :: Maybe CodebasePathOption -> SC.MigrationStrategy -> ((InitResult, CodebasePath, Codebase IO Symbol Ann) -> IO r) -> IO r getCodebaseOrExit codebasePathOption migrationStrategy action = do initOptions <- argsToCodebaseInitOptions codebasePathOption - result <- CodebaseInit.withOpenOrCreateCodebase SC.init "main" initOptions SC.DoLock migrationStrategy \case + let cbInit = SC.init + result <- CodebaseInit.withOpenOrCreateCodebase cbInit "main" initOptions SC.DoLock migrationStrategy \case cbInit@(CreatedCodebase, dir, _) -> do pDir <- prettyDir dir PT.putPrettyLn' "" diff --git a/unison-cli/src/Unison/Share/Codeserver.hs b/unison-cli/src/Unison/Share/Codeserver.hs index a1617a4411..ea7aee4b73 100644 --- a/unison-cli/src/Unison/Share/Codeserver.hs +++ b/unison-cli/src/Unison/Share/Codeserver.hs @@ -1,4 +1,10 @@ -module Unison.Share.Codeserver where +module Unison.Share.Codeserver + ( isCustomCodeserver, + defaultCodeserver, + resolveCodeserver, + CodeserverURI (..), + ) +where import Network.URI (parseURI) import System.IO.Unsafe (unsafePerformIO) @@ -8,18 +14,24 @@ import Unison.Share.Types import Unison.Share.Types qualified as Share import UnliftIO.Environment (lookupEnv) +shareProd :: CodeserverURI +shareProd = + CodeserverURI + { codeserverScheme = Share.Https, + codeserverUserInfo = "", + codeserverRegName = "api.unison-lang.org", + codeserverPort = Nothing, + codeserverPath = [] + } + +isCustomCodeserver :: CodeserverURI -> Bool +isCustomCodeserver = (/=) shareProd + -- | This is the URI where the share API is based. defaultCodeserver :: CodeserverURI defaultCodeserver = unsafePerformIO $ do lookupEnv "UNISON_SHARE_HOST" <&> \case - Nothing -> - CodeserverURI - { codeserverScheme = Share.Https, - codeserverUserInfo = "", - codeserverRegName = "api.unison-lang.org", - codeserverPort = Nothing, - codeserverPath = [] - } + Nothing -> shareProd Just shareHost -> fromMaybe (error $ "Share Host is not a valid URI: " <> shareHost) $ do uri <- parseURI shareHost diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 8df14b8f99..aa08d01875 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -6,14 +6,10 @@ module Unison.Share.Sync getCausalHashByPath, GetCausalHashByPathError (..), - -- ** Push - checkAndSetPush, - CheckAndSetPushError (..), - fastForwardPush, - FastForwardPushError (..), + -- ** Upload uploadEntities, - -- ** Pull + -- ** Pull/Download pull, PullError (..), downloadEntities, @@ -26,16 +22,10 @@ import Control.Monad.Except import Control.Monad.Reader (ask) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad.Trans.Reader qualified as Reader -import Data.Foldable qualified as Foldable (find) -import Data.List.NonEmpty (pattern (:|)) -import Data.List.NonEmpty qualified as List (NonEmpty) -import Data.List.NonEmpty qualified as List.NonEmpty import Data.Map qualified as Map import Data.Map.NonEmpty (NEMap) import Data.Map.NonEmpty qualified as NEMap import Data.Proxy -import Data.Sequence.NonEmpty (NESeq ((:<||))) -import Data.Sequence.NonEmpty qualified as NESeq (fromList, nonEmptySeq, (><|)) import Data.Set qualified as Set import Data.Set.NonEmpty (NESet) import Data.Set.NonEmpty qualified as NESet @@ -65,7 +55,7 @@ import Unison.Share.ExpectedHashMismatches (expectedCausalHashMismatches, expect import Unison.Share.Sync.Types import Unison.Sqlite qualified as Sqlite import Unison.Sync.API qualified as Share (API) -import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash) +import Unison.Sync.Common (entityToTempEntity, expectEntity, hash32ToCausalHash) import Unison.Sync.EntityValidation qualified as EV import Unison.Sync.Types qualified as Share import Unison.Util.Monoid (foldMapM) @@ -98,300 +88,6 @@ syncChunkSize = unsafePerformIO $ do Nothing -> 50 {-# NOINLINE syncChunkSize #-} ------------------------------------------------------------------------------------------------------------------------- --- Push - --- | Perform a check-and-set push (initially of just a causal hash, but ultimately all of its dependencies that the --- server is missing, too) to Unison Share. --- --- This flavor of push takes the expected state of the server, and the desired state we want to set; if our expectation --- is off, we won't proceed with the push. -checkAndSetPush :: - -- | The Unison Share URL. - BaseUrl -> - -- | The repo+path to push to. - Share.Path -> - -- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error. - -- This prevents accidentally pushing over data that we didn't know was there. - Maybe Hash32 -> - -- | The hash of our local causal to push. - CausalHash -> - -- | Callback that's given a number of entities we just uploaded. - (Int -> IO ()) -> - Cli (Either (SyncError CheckAndSetPushError) ()) -checkAndSetPush unisonShareUrl path expectedHash causalHash uploadedCallback = do - Cli.Env {authHTTPClient} <- ask - - Cli.label \done -> do - let failed :: SyncError CheckAndSetPushError -> Cli void - failed = done . Left - - let updatePathError :: Share.UpdatePathError -> Cli void - updatePathError err = - failed (SyncError (CheckAndSetPushError'UpdatePath (Share.pathRepoInfo path) err)) - - let updatePath :: Cli Share.UpdatePathResponse - updatePath = do - liftIO request & onLeftM \err -> failed (TransportError err) - where - request :: IO (Either CodeserverTransportError Share.UpdatePathResponse) - request = - httpUpdatePath - authHTTPClient - unisonShareUrl - Share.UpdatePathRequest - { path, - expectedHash, - newHash = causalHashToHash32 causalHash - } - - -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it - -- needs this causal (UpdatePathMissingDependencies). - dependencies <- - updatePath >>= \case - Share.UpdatePathSuccess -> done (Right ()) - Share.UpdatePathFailure err -> - case err of - Share.UpdatePathError'MissingDependencies (Share.NeedDependencies dependencies) -> pure dependencies - _ -> updatePathError err - - -- Upload the causal and all of its dependencies. - uploadEntities unisonShareUrl (Share.pathRepoInfo path) dependencies uploadedCallback & onLeftM \err -> - failed (CheckAndSetPushError'UploadEntities <$> err) - - -- After uploading the causal and all of its dependencies, try setting the remote path again. - updatePath >>= \case - Share.UpdatePathSuccess -> pure (Right ()) - Share.UpdatePathFailure err -> updatePathError err - --- | Perform a fast-forward push (initially of just a causal hash, but ultimately all of its dependencies that the --- server is missing, too) to Unison Share. --- --- This flavor of push provides the server with a chain of causal hashes leading from its current state to our desired --- state. -fastForwardPush :: - -- | The Unison Share URL. - BaseUrl -> - -- | The repo+path to push to. - Share.Path -> - -- | The hash of our local causal to push. - CausalHash -> - -- | Callback that's given a number of entities we just uploaded. - (Int -> IO ()) -> - Cli (Either (SyncError FastForwardPushError) ()) -fastForwardPush unisonShareUrl path localHeadHash uploadedCallback = do - Cli.label \done -> do - let succeeded :: Cli void - succeeded = - done (Right ()) - - let failed :: SyncError FastForwardPushError -> Cli void - failed = done . Left - - let fastForwardPathError :: Share.FastForwardPathError -> Cli void - fastForwardPathError err = - failed (SyncError (FastForwardPushError'FastForwardPath path err)) - - remoteHeadHash <- - getCausalHashByPath unisonShareUrl path >>= \case - Left err -> failed (FastForwardPushError'GetCausalHash <$> err) - Right Nothing -> fastForwardPathError Share.FastForwardPathError'NoHistory - Right (Just remoteHeadHash) -> pure (Share.hashJWTHash remoteHeadHash) - - let doLoadCausalSpineBetween = do - -- (Temporary?) optimization - perform the "is ancestor?" check within sqlite before reconstructing the - -- actual path. - let isBefore :: Sqlite.Transaction Bool - isBefore = do - maybeHashIds <- - runMaybeT $ - (,) - <$> MaybeT (Q.loadCausalHashIdByCausalHash (hash32ToCausalHash remoteHeadHash)) - <*> MaybeT (Q.loadCausalHashIdByCausalHash localHeadHash) - case maybeHashIds of - Nothing -> pure False - Just (remoteHeadHashId, localHeadHashId) -> Q.before remoteHeadHashId localHeadHashId - isBefore >>= \case - False -> pure Nothing - True -> loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash) - - let doUpload :: List.NonEmpty CausalHash -> Cli () - -- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes", - -- but we don't have that API yet. So, we only upload the head causal entity (which we don't even know for sure - -- the server doesn't have yet), and will (eventually) end up uploading the casuals in the tail that the server - -- needs. - doUpload (headHash :| _tailHashes) = - request & onLeftM \err -> failed (FastForwardPushError'UploadEntities <$> err) - where - request = - uploadEntities - unisonShareUrl - (Share.pathRepoInfo path) - (NESet.singleton (causalHashToHash32 headHash)) - uploadedCallback - - localInnerHashes <- - Cli.runTransaction doLoadCausalSpineBetween >>= \case - -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a - -- fast-forward push, so we don't bother trying - just report the error now. - Nothing -> failed (SyncError (FastForwardPushError'NotFastForward path)) - -- The path from remote-to-local, excluding local, was empty. So, remote == local; there's nothing to push. - Just [] -> succeeded - -- drop remote hash - Just (_ : localInnerHashes) -> pure (map hash32ToCausalHash localInnerHashes) - - doUpload (localHeadHash :| localInnerHashes) - - let doFastForwardPath :: Cli Share.FastForwardPathResponse - doFastForwardPath = do - Cli.Env {authHTTPClient} <- ask - let request = - httpFastForwardPath - authHTTPClient - unisonShareUrl - Share.FastForwardPathRequest - { expectedHash = remoteHeadHash, - hashes = - causalHashToHash32 <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), - path - } - liftIO request & onLeftM \err -> failed (TransportError err) - - doFastForwardPath >>= \case - Share.FastForwardPathSuccess -> succeeded - Share.FastForwardPathFailure err -> fastForwardPathError err - --- Return a list (in oldest-to-newest order) of hashes along the causal spine that connects the given arguments, --- excluding the newest hash (second argument). -loadCausalSpineBetween :: Hash32 -> Hash32 -> Sqlite.Transaction (Maybe [Hash32]) -loadCausalSpineBetween earlierHash laterHash = - dagbfs (== earlierHash) Q.loadCausalParentsByHash laterHash - -data Step a - = DeadEnd - | KeepSearching (List.NonEmpty a) - | FoundGoal a - --- | @dagbfs goal children root@ searches breadth-first through the monadic tree formed by applying @chilred@ to each --- node (initially @root@), until it finds a goal node (i.e. when @goal@ returns True). --- --- Returns the nodes along a path from root to goal in bottom-up or goal-to-root order, excluding the root node (because --- it was provided as an input ;)) --- --- For example, when searching a tree that looks like --- --- 1 --- / \ --- 2 3 --- / \ \ --- 4 [5] 6 --- --- (where the goal is marked [5]), we'd return --- --- Just [5,2] --- --- And (as another example), if the root node is the goal, --- --- [1] --- / \ --- 2 3 --- / \ \ --- 4 5 6 --- --- we'd return --- --- Just [] -dagbfs :: forall a m. (Monad m) => (a -> Bool) -> (a -> m [a]) -> a -> m (Maybe [a]) -dagbfs goal children = - let -- The loop state: all distinct paths from the root to the frontier (not including the root, because it's implied, - -- as an input to this function), in reverse order, with the invariant that we haven't found a goal state yet. - -- (Otherwise, we wouldn't still be in this loop, we'd return!). - -- - -- For example, say we are exploring the tree - -- - -- 1 - -- / \ - -- 2 3 - -- / \ \ - -- 4 5 6 - -- - -- Graphically, the frontier here is the nodes 4, 5, and 6; we know that, because we haven't drawn any nodes below - -- them. (This is a BFS algorithm that discovers children on-the-fly, so maybe node 5 (for example) has children, - -- and maybe it doesn't). - -- - -- The loop state, in this case, would be these three paths: - -- - -- [ 4, 2 ] - -- [ 5, 2 ] - -- [ 6, 3 ] - -- - -- (Note, again, that we do not include the root). - go :: NESeq (List.NonEmpty a) -> m (Maybe (List.NonEmpty a)) - go (path :<|| paths) = - -- Step forward from the first path in our loop state (in the example above, [4, 2]). - step (List.NonEmpty.head path) >>= \case - -- If node 4 had no more children, we can toss that whole path: it didn't end in a goal. Now we either keep - -- searching (as we would in the example, since we have two more paths to continue from), or we don't, because - -- this was the only remaining path. - DeadEnd -> - case NESeq.nonEmptySeq paths of - Nothing -> pure Nothing - Just paths' -> go paths' - -- If node 4 did have children, then maybe the search tree now looks like this. - -- - -- 1 - -- / \ - -- 2 3 - -- / \ \ - -- 4 5 6 - -- / \ - -- 7 8 - -- - -- There are two cases to handle: - -- - -- 1. One of the children we just discovered (say 7) is a goal node. So we're done, and we'd return the path - -- - -- [ 7, 4, 2 ] - -- - -- 2. No child we just discovered (7 nor 8) were a goal node. So we loop, putting our new path(s) at the end - -- of the list (so we search paths fairly). In this case, we'd re-enter the loop with the following four - -- paths: - -- - -- [ 5, 2 ] \ these two are are variable 'paths', the tail of the loop state. - -- [ 6, 3 ] / - -- [ 7, 4, 2 ] \ these two are new, just constructed by prepending each of [ 4, 2, 1 ]'s children - -- [ 8, 4, 2 ] / to itself, making two new paths to search - KeepSearching ys -> go (append paths ((\y -> List.NonEmpty.cons y path) <$> NESeq.fromList ys)) - FoundGoal y -> pure (Just (List.NonEmpty.cons y path)) - - -- Step forward from a single node. There are 3 possible outcomes: - -- - -- 1. We discover it has no children. (return DeadEnd) - -- 2. We discover is has children, none of which are a goal. (return KeepSearching) - -- 3. We discover it has children, (at least) one of which is a goal. (return FoundGoal) - step :: a -> m (Step a) - step x = do - ys0 <- children x - pure case List.NonEmpty.nonEmpty ys0 of - Nothing -> DeadEnd - Just ys -> - case Foldable.find goal ys of - Nothing -> KeepSearching ys - Just y -> FoundGoal y - in \root -> - if goal root - then pure (Just []) - else - step root >>= \case - DeadEnd -> pure Nothing - -- lts-18.28 doesn't have List.NonEmpty.singleton - KeepSearching xs -> fmap List.NonEmpty.toList <$> go (NESeq.fromList ((:| []) <$> xs)) - FoundGoal x -> pure (Just [x]) - where - -- Concatenate a seq and a non-empty seq. - append :: Seq x -> NESeq x -> NESeq x - append = (NESeq.><|) - ------------------------------------------------------------------------------------------------------------------------ -- Pull @@ -977,16 +673,6 @@ httpGetCausalHashByPath :: BaseUrl -> Share.GetCausalHashByPathRequest -> IO (Either CodeserverTransportError Share.GetCausalHashByPathResponse) -httpFastForwardPath :: - Auth.AuthenticatedHttpClient -> - BaseUrl -> - Share.FastForwardPathRequest -> - IO (Either CodeserverTransportError Share.FastForwardPathResponse) -httpUpdatePath :: - Auth.AuthenticatedHttpClient -> - BaseUrl -> - Share.UpdatePathRequest -> - IO (Either CodeserverTransportError Share.UpdatePathResponse) httpDownloadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> @@ -998,14 +684,10 @@ httpUploadEntities :: Share.UploadEntitiesRequest -> IO (Either CodeserverTransportError Share.UploadEntitiesResponse) ( httpGetCausalHashByPath, - httpFastForwardPath, - httpUpdatePath, httpDownloadEntities, httpUploadEntities ) = let ( httpGetCausalHashByPath - Servant.:<|> httpFastForwardPath - Servant.:<|> httpUpdatePath Servant.:<|> httpDownloadEntities Servant.:<|> httpUploadEntities ) = @@ -1013,8 +695,6 @@ httpUploadEntities :: pp = Proxy in Servant.hoistClient pp hoist (Servant.client pp) in ( go httpGetCausalHashByPath, - go httpFastForwardPath, - go httpUpdatePath, go httpDownloadEntities, go httpUploadEntities ) @@ -1053,8 +733,10 @@ httpUploadEntities :: { Servant.makeClientRequest = \url request -> -- Disable client-side timeouts (Servant.defaultMakeClientRequest url request) - { Http.Client.responseTimeout = Http.Client.responseTimeoutNone - } + <&> \r -> + r + { Http.Client.responseTimeout = Http.Client.responseTimeoutNone + } } & runReaderT (f req) & runExceptT diff --git a/unison-cli/src/Unison/Share/Sync/Types.hs b/unison-cli/src/Unison/Share/Sync/Types.hs index 1d14c32207..a53d14acbb 100644 --- a/unison-cli/src/Unison/Share/Sync/Types.hs +++ b/unison-cli/src/Unison/Share/Sync/Types.hs @@ -1,8 +1,6 @@ -- | Types used by the UCM client during sync. module Unison.Share.Sync.Types - ( CheckAndSetPushError (..), - CodeserverTransportError (..), - FastForwardPushError (..), + ( CodeserverTransportError (..), GetCausalHashByPathError (..), PullError (..), SyncError (..), @@ -13,29 +11,6 @@ import Servant.Client qualified as Servant import Unison.Prelude import Unison.Sync.Types qualified as Share --- | Error used by the client when pushing code to Unison Share. -data CheckAndSetPushError - = CheckAndSetPushError'UpdatePath - -- The repo we are pushing to. This is only necessary because an UpdatePathError does not have enough context to - -- print the entire error message we want to print, but it really should, at which point maybe this can go away. - Share.RepoInfo - Share.UpdatePathError - | CheckAndSetPushError'UploadEntities Share.UploadEntitiesError - deriving stock (Show) - --- | An error occurred while fast-forward pushing code to Unison Share. -data FastForwardPushError - = FastForwardPushError'FastForwardPath - -- The path we are fast forwarding. This is only necessary because a FastForwardPathError does not have enough - -- context to print the entire error message we want to print, but it really should, at which point maybe this can - -- go away. - Share.Path - Share.FastForwardPathError - | FastForwardPushError'GetCausalHash GetCausalHashByPathError - | FastForwardPushError'NotFastForward Share.Path - | FastForwardPushError'UploadEntities Share.UploadEntitiesError - deriving stock (Show) - -- | An error occurred while pulling code from Unison Share. data PullError = PullError'DownloadEntities Share.DownloadEntitiesError diff --git a/unison-cli/tests/Unison/Test/ClearCache.hs b/unison-cli/tests/Unison/Test/ClearCache.hs index 655bd6d91a..8c49f10389 100644 --- a/unison-cli/tests/Unison/Test/ClearCache.hs +++ b/unison-cli/tests/Unison/Test/ClearCache.hs @@ -22,10 +22,10 @@ test = scope "clearWatchCache" $ Ucm.runTranscript c [i| - ```ucm - .> alias.term ##Nat.+ + + ``` ucm + scratch/main> alias.term ##Nat.+ + ``` - ```unison + ``` unison > 1 + 1 ``` |] @@ -37,8 +37,8 @@ test = scope "clearWatchCache" $ Ucm.runTranscript c [i| - ```ucm - .> debug.clear-cache + ``` ucm + scratch/main> debug.clear-cache ``` |] diff --git a/unison-cli/tests/Unison/Test/Cli/Monad.hs b/unison-cli/tests/Unison/Test/Cli/Monad.hs index 712b6c083b..ba541e49f8 100644 --- a/unison-cli/tests/Unison/Test/Cli/Monad.hs +++ b/unison-cli/tests/Unison/Test/Cli/Monad.hs @@ -36,12 +36,10 @@ dummyEnv = undefined dummyLoopState :: Cli.LoopState dummyLoopState = Cli.LoopState - { currentPathStack = undefined, - lastInput = Nothing, - lastRunResult = Nothing, - lastSavedRootHash = undefined, + { projectPathStack = undefined, latestFile = Nothing, latestTypecheckedFile = Nothing, + lastInput = Nothing, numberedArgs = [], - root = undefined + lastRunResult = Nothing } diff --git a/unison-cli/tests/Unison/Test/LSP.hs b/unison-cli/tests/Unison/Test/LSP.hs index 5b42467905..02af644740 100644 --- a/unison-cli/tests/Unison/Test/LSP.hs +++ b/unison-cli/tests/Unison/Test/LSP.hs @@ -10,6 +10,8 @@ import Data.String.Here.Uninterpolated (here) import Data.Text import Data.Text qualified as Text import EasyTest +import Language.LSP.Protocol.Lens qualified as LSP +import Language.LSP.Protocol.Types qualified as LSP import System.IO.Temp qualified as Temp import Unison.ABT qualified as ABT import Unison.Builtin.Decls (unitRef) @@ -20,6 +22,8 @@ import Unison.Codebase.Init qualified as Codebase.Init import Unison.Codebase.SqliteCodebase qualified as SC import Unison.ConstructorReference (GConstructorReference (..)) import Unison.FileParsers qualified as FileParsers +import Unison.LSP.Conversions qualified as Cv +import Unison.LSP.FileAnalysis.UnusedBindings qualified as UnusedBindings import Unison.LSP.Queries qualified as LSPQ import Unison.Lexer.Pos qualified as Lexer import Unison.Parser.Ann (Ann (..)) @@ -35,6 +39,7 @@ import Unison.Term qualified as Term import Unison.Type qualified as Type import Unison.UnisonFile qualified as UF import Unison.Util.Monoid (foldMapM) +import Unison.Util.Recursion test :: Test () test = do @@ -43,6 +48,10 @@ test = do [ refFinding, annotationNesting ] + scope "diagnostics" $ + tests + [ unusedBindingLocations + ] trm :: Term.F Symbol () () (ABT.Term (Term.F Symbol () ()) Symbol ()) -> LSPQ.SourceNode () trm = LSPQ.TermNode . ABT.tm @@ -239,15 +248,39 @@ term = let ) ] --- | Test helper which lets you specify a cursor position inline with source text as a '|'. +-- | Test helper which lets you specify a cursor position inline with source text as a '^'. extractCursor :: Text -> Test (Lexer.Pos, Text) extractCursor txt = - case Text.splitOn "^" txt of + case splitOnDelimiter '^' txt of + Nothing -> crash "expected exactly one cursor" + Just (before, pos, after) -> pure (pos, before <> after) + +-- | Splits a text on a delimiter, returning the text before and after the delimiter, along with the position of the delimiter. +-- +-- >>> splitOnDelimiter '^' "foo b^ar baz" +-- Just ("foo b",Pos {line = 0, column = 5},"ar baz") +splitOnDelimiter :: Char -> Text -> Maybe (Text, Lexer.Pos, Text) +splitOnDelimiter sym txt = + case Text.splitOn (Text.singleton sym) txt of [before, after] -> - let col = Text.length $ Text.takeWhileEnd (/= '\n') before - line = Prelude.length $ Text.lines before - in pure $ (Lexer.Pos line col, before <> after) - _ -> crash "expected exactly one cursor" + let col = (Text.length $ Text.takeWhileEnd (/= '\n') before) + 1 + line = Text.count "\n" before + 1 + in Just $ (before, Lexer.Pos line col, after) + _ -> Nothing + +-- | Test helper which lets you specify a cursor position inline with source text as a '^'. +-- +-- >>> extractDelimitedBlock ('{', '}') "foo {bar} baz" +-- Just (Ann {start = Pos {line = 1, column = 4}, end = Pos {line = 1, column = 7}},"bar","foo bar baz") +-- +-- >>> extractDelimitedBlock ('{', '}') "term =\n {foo} = 12345" +-- Just (Ann {start = Pos {line = 2, column = 2}, end = Pos {line = 2, column = 5}},"foo","term =\n foo = 12345") +extractDelimitedBlock :: (Char, Char) -> Text -> Maybe (Ann {- ann spanning the inside of the delimiters -}, Text {- Text within the delimiters -}, Text {- entire source text with the delimiters stripped -}) +extractDelimitedBlock (startDelim, endDelim) txt = do + (beforeStart, startPos, afterStart) <- splitOnDelimiter startDelim txt + (beforeEnd, endPos, afterEnd) <- splitOnDelimiter endDelim (beforeStart <> afterStart) + let ann = Ann startPos endPos + pure (ann, Text.takeWhile (/= endDelim) afterStart, beforeEnd <> afterEnd) makeNodeSelectionTest :: (String, Text, Bool, LSPQ.SourceNode ()) -> Test () makeNodeSelectionTest (name, testSrc, testTypechecked, expected) = scope name $ do @@ -308,23 +341,30 @@ annotationNestingTest (name, src) = scope name do & traverse_ \(_fileAnn, _refId, _wk, trm, _typ) -> assertAnnotationsAreNested trm --- | Asserts that for all nodes in the provided ABT, the annotations of all child nodes are +-- | Asserts that for all nodes in the provided ABT EXCEPT Abs nodes, the annotations of all child nodes are -- within the span of the parent node. assertAnnotationsAreNested :: forall f. (Foldable f, Functor f, Show (f (Either String Ann))) => ABT.Term f Symbol Ann -> Test () assertAnnotationsAreNested term = do - case ABT.cata alg term of + case cata alg term of Right _ -> pure () Left err -> crash err where - alg :: Ann -> ABT.ABT f Symbol (Either String Ann) -> Either String Ann - alg ann abt = do + alg :: Algebra (ABT.Term' f Symbol Ann) (Either String Ann) + alg (ABT.Term' _ ann abt) = do childSpan <- abt & foldMapM id - case ann `Ann.encompasses` childSpan of - -- one of the annotations isn't in the file, don't bother checking. - Nothing -> pure (ann <> childSpan) - Just isInFile - | isInFile -> pure ann - | otherwise -> Left $ "Containment breach: children aren't contained with the parent:" <> show (ann, abt) + case abt of + -- Abs nodes are the only nodes whose annotations are allowed to not contain their children, + -- they represet the location of the variable being bound instead. Ideally we'd have a separate child + -- node for that, but we can't add it without editing the ABT or Term types. + ABT.Abs _ _ -> + pure (ann <> childSpan) + _ -> do + case ann `Ann.encompasses` childSpan of + -- one of the annotations isn't in the file, don't bother checking. + Nothing -> pure (ann <> childSpan) + Just isInFile + | isInFile -> pure ann + | otherwise -> Left $ "Containment breach: children aren't contained with the parent:" <> show (ann, abt) typecheckSrc :: String -> @@ -345,7 +385,9 @@ typecheckSrc name src = do Parser.ParsingEnv { uniqueNames = uniqueName, uniqueTypeGuid = \_ -> pure Nothing, - names = parseNames + names = parseNames, + maybeNamespace = Nothing, + localNamespacePrefixedTypesAndConstructors = mempty } Codebase.runTransaction codebase do Parsers.parseFile name (Text.unpack src) parsingEnv >>= \case @@ -374,3 +416,54 @@ withTestCodebase action = do tmpDir <- Temp.createTempDirectory tmp "lsp-test" Codebase.Init.withCreatedCodebase SC.init "lsp-test" tmpDir SC.DontLock action either (crash . show) pure r + +makeDiagnosticRangeTest :: (String, Text) -> Test () +makeDiagnosticRangeTest (testName, testSrc) = scope testName $ do + let (cleanSrc, mayExpectedDiagnostic) = case extractDelimitedBlock ('«', '»') testSrc of + Nothing -> (testSrc, Nothing) + Just (ann, block, clean) -> (clean, Just (ann, block)) + (pf, _mayTypecheckedFile) <- typecheckSrc testName cleanSrc + UF.terms pf + & Map.elems + & \case + [(_a, trm)] -> do + case (mayExpectedDiagnostic, UnusedBindings.analyseTerm (LSP.Uri "test") trm) of + (Just (ann, _block), [diag]) -> do + let expectedRange = Cv.annToRange ann + let actualRange = Just (diag ^. LSP.range) + when (expectedRange /= actualRange) do + crash $ "Expected diagnostic at range: " <> show expectedRange <> ", got: " <> show actualRange + (Nothing, []) -> pure () + (expected, actual) -> case expected of + Nothing -> crash $ "Expected no diagnostics, got: " <> show actual + Just _ -> crash $ "Expected exactly one diagnostic, but got " <> show actual + _ -> crash "Expected exactly one term" + +unusedBindingLocations :: Test () +unusedBindingLocations = + scope "unused bindings" . tests . fmap makeDiagnosticRangeTest $ + [ ( "Unused binding in let block", + [here|term = + usedOne = true + «unused = "unused"» + usedTwo = false + usedOne && usedTwo + |] + ), + ( "Unused argument", + [here|term «unused» = 1|] + ), + ( "Unused binding in cases block", + [here|term = cases + -- Note: the diagnostic _should_ only wrap the unused bindings, but right now it just wraps the whole pattern. + («unused, used») + | used > 0 -> true + | otherwise -> false + |] + ), + ( "Ignored unused binding in cases block shouldn't error", + [here|term = cases + (used, _ignored) -> used + |] + ) + ] diff --git a/unison-cli/tests/Unison/Test/Ucm.hs b/unison-cli/tests/Unison/Test/Ucm.hs index 54655cfe29..9b2019c71b 100644 --- a/unison-cli/tests/Unison/Test/Ucm.hs +++ b/unison-cli/tests/Unison/Test/Ucm.hs @@ -24,10 +24,11 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Init qualified as Codebase.Init import Unison.Codebase.Init.CreateCodebaseError (CreateCodebaseError (..)) import Unison.Codebase.SqliteCodebase qualified as SC -import Unison.Codebase.TranscriptParser qualified as TR +import Unison.Codebase.Transcript.Parser qualified as Transcript +import Unison.Codebase.Transcript.Runner qualified as Transcript import Unison.Codebase.Verbosity qualified as Verbosity import Unison.Parser.Ann (Ann) -import Unison.Prelude (traceM) +import Unison.Prelude (toList, traceM) import Unison.PrettyTerminal qualified as PT import Unison.Symbol (Symbol) import Unison.Util.Pretty qualified as P @@ -66,18 +67,19 @@ runTranscript :: Codebase -> Transcript -> IO TranscriptOutput runTranscript (Codebase codebasePath fmt) transcript = do let err e = fail $ "Parse error: \n" <> show e cbInit = case fmt of CodebaseFormat2 -> SC.init - TR.withTranscriptRunner Verbosity.Silent "Unison.Test.Ucm.runTranscript Invalid Version String" rtp configFile $ \runner -> do - result <- Codebase.Init.withOpenCodebase cbInit "transcript" codebasePath SC.DoLock SC.DontMigrate \codebase -> do - Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase) - let transcriptSrc = stripMargin . Text.pack $ unTranscript transcript - output <- either err Text.unpack <$> runner "transcript" transcriptSrc (codebasePath, codebase) - when debugTranscriptOutput $ traceM output - pure output - case result of - Left e -> fail $ P.toANSI 80 (P.shown e) - Right x -> pure x + isTest = True + Transcript.withRunner isTest Verbosity.Silent "Unison.Test.Ucm.runTranscript Invalid Version String" rtp $ + \runner -> do + result <- Codebase.Init.withOpenCodebase cbInit "transcript" codebasePath SC.DoLock SC.DontMigrate \codebase -> do + Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase) + let transcriptSrc = stripMargin . Text.pack $ unTranscript transcript + output <- + either err (Text.unpack . Transcript.formatStanzas . toList) + <$> runner "transcript" transcriptSrc (codebasePath, codebase) + when debugTranscriptOutput $ traceM output + pure output + either (fail . P.toANSI 80 . P.shown) pure result where - configFile = Nothing -- Note: this needs to be properly configured if these tests ever -- need to do native compiles. But I suspect they won't. rtp = "native-compiler/bin" diff --git a/unison-cli/tests/Unison/Test/UriParser.hs b/unison-cli/tests/Unison/Test/UriParser.hs index 1a896f4bae..4c64958f0e 100644 --- a/unison-cli/tests/Unison/Test/UriParser.hs +++ b/unison-cli/tests/Unison/Test/UriParser.hs @@ -8,11 +8,6 @@ import EasyTest import Text.Megaparsec qualified as P import Unison.Codebase.Editor.RemoteRepo ( ReadRemoteNamespace (..), - ShareCodeserver (..), - ShareUserHandle (..), - WriteRemoteNamespace (..), - WriteShareRemoteNamespace (..), - pattern ReadShareLooseCode, ) import Unison.Codebase.Editor.UriParser qualified as UriParser import Unison.Codebase.Path qualified as Path @@ -27,8 +22,7 @@ test = [ parserTests "repoPath" (UriParser.readRemoteNamespaceParser ProjectBranchSpecifier'Name <* P.eof) - [ ("unisonweb.base._releases.M4", looseR "unisonweb" ["base", "_releases", "M4"]), - ("project", branchR (This "project")), + [ ("project", branchR (This "project")), ("/branch", branchR (That "branch")), ("project/branch", branchR (These "project" "branch")) ] @@ -36,8 +30,7 @@ test = parserTests "writeRemoteNamespace" (UriParser.writeRemoteNamespace <* P.eof) - [ ("unisonweb.base._releases.M4", looseW "unisonweb" ["base", "_releases", "M4"]), - ("project", branchW (This "project")), + [ ("project", branchW (This "project")), ("/branch", branchW (That "branch")), ("project/branch", branchW (These "project" "branch")) ] @@ -48,14 +41,6 @@ test = mkPath :: [Text] -> Path.Path mkPath = Path.fromList . fmap NameSegment -looseR :: Text -> [Text] -> ReadRemoteNamespace void -looseR user path = - ReadShare'LooseCode (ReadShareLooseCode DefaultCodeserver (ShareUserHandle user) (mkPath path)) - -looseW :: Text -> [Text] -> WriteRemoteNamespace void -looseW user path = - WriteRemoteNamespaceShare (WriteShareRemoteNamespace DefaultCodeserver (ShareUserHandle user) (mkPath path)) - branchR :: These Text Text -> ReadRemoteNamespace (These ProjectName ProjectBranchName) branchR = ReadShare'ProjectBranch . \case @@ -63,9 +48,9 @@ branchR = That branch -> That (UnsafeProjectBranchName branch) These project branch -> These (UnsafeProjectName project) (UnsafeProjectBranchName branch) -branchW :: These Text Text -> WriteRemoteNamespace (These ProjectName ProjectBranchName) +branchW :: These Text Text -> (These ProjectName ProjectBranchName) branchW = - WriteRemoteProjectBranch . \case + \case This project -> This (UnsafeProjectName project) That branch -> That (UnsafeProjectBranchName branch) These project branch -> These (UnsafeProjectName project) (UnsafeProjectBranchName branch) diff --git a/unison-cli/transcripts/Transcripts.hs b/unison-cli/transcripts/Transcripts.hs index 56a3394086..9b54be7a20 100644 --- a/unison-cli/transcripts/Transcripts.hs +++ b/unison-cli/transcripts/Transcripts.hs @@ -22,9 +22,11 @@ import System.FilePath ) import System.IO.CodePage (withCP65001) import System.IO.Silently (silence) +import Text.Megaparsec qualified as MP import Unison.Codebase.Init (withTemporaryUcmCodebase) import Unison.Codebase.SqliteCodebase qualified as SC -import Unison.Codebase.TranscriptParser (TranscriptError (..), withTranscriptRunner) +import Unison.Codebase.Transcript.Parser as Transcript +import Unison.Codebase.Transcript.Runner as Transcript import Unison.Codebase.Verbosity qualified as Verbosity import Unison.Prelude import UnliftIO.STM qualified as STM @@ -35,68 +37,108 @@ data TestConfig = TestConfig } deriving (Show) -type TestBuilder = FilePath -> FilePath -> [String] -> String -> Test () +type TestBuilder = + -- | path to the native runtime + FilePath -> + -- | directory containing prelude & transcript `FilePath`s + FilePath -> + -- | directory to write output files to (often the same as the previous argument) + FilePath -> + -- | prelude files (relative to previous directory `FilePath`) + [FilePath] -> + -- | transcript file (relative to earlier directory `FilePath`) + FilePath -> + Test () testBuilder :: + Bool -> Bool -> ((FilePath, Text) -> IO ()) -> FilePath -> FilePath -> - [String] -> - String -> + FilePath -> + [FilePath] -> + FilePath -> Test () -testBuilder expectFailure recordFailure runtimePath dir prelude transcript = scope transcript $ do - outputs <- io . withTemporaryUcmCodebase SC.init Verbosity.Silent "transcript" SC.DoLock $ \(codebasePath, codebase) -> do - withTranscriptRunner Verbosity.Silent "TODO: pass version here" runtimePath Nothing \runTranscript -> do - for files \filePath -> do - transcriptSrc <- readUtf8 filePath - out <- silence $ runTranscript filePath transcriptSrc (codebasePath, codebase) - pure (filePath, out) - for_ outputs \case - (filePath, Left err) -> do - let outputFile = outputFileForTranscript filePath - case err of - TranscriptParseError msg -> do - when (not expectFailure) $ do - let errMsg = "Error parsing " <> filePath <> ": " <> Text.unpack msg - io $ recordFailure (filePath, Text.pack errMsg) - crash errMsg - TranscriptRunFailure errOutput -> do - io $ writeUtf8 outputFile errOutput - when (not expectFailure) $ do - io $ Text.putStrLn errOutput - io $ recordFailure (filePath, errOutput) - crash $ "Failure in " <> filePath - (filePath, Right out) -> do - let outputFile = outputFileForTranscript filePath - io $ writeUtf8 outputFile out - when expectFailure $ do - let errMsg = "Expected a failure, but transcript was successful." - io $ recordFailure (filePath, Text.pack errMsg) - crash errMsg - ok +testBuilder expectFailure replaceOriginal recordFailure runtimePath inputDir outputDir prelude transcript = + scope transcript do + outputs <- + io $ withTemporaryUcmCodebase SC.init Verbosity.Silent "transcript" SC.DoLock \(codebasePath, codebase) -> + let isTest = True + in Transcript.withRunner isTest Verbosity.Silent "TODO: pass version here" runtimePath \runTranscript -> + for files \filePath -> do + transcriptSrc <- readUtf8 $ inputDir filePath + out <- silence $ runTranscript filePath transcriptSrc (codebasePath, codebase) + pure (filePath, out) + for_ outputs \case + (filePath, Left err) -> do + let outputFile = outputDir outputFileForTranscript filePath + case err of + Transcript.ParseError errors -> do + let bundle = MP.errorBundlePretty errors + errMsg = "Error parsing " <> filePath <> ": " <> bundle + -- Drop the file name, to avoid POSIX/Windows conflicts + io . writeUtf8 outputFile . Text.dropWhile (/= ':') $ Text.pack bundle + when (not expectFailure) $ do + io $ recordFailure (inputDir filePath, Text.pack errMsg) + crash errMsg + Transcript.RunFailure errOutput -> do + let errText = Transcript.formatStanzas $ toList errOutput + io $ writeUtf8 outputFile errText + when (not expectFailure) $ do + io $ Text.putStrLn errText + io $ recordFailure (inputDir filePath, errText) + crash $ "Failure in " <> filePath + (filePath, Right out) -> do + let outputFile = outputDir if replaceOriginal then filePath else outputFileForTranscript filePath + io . createDirectoryIfMissing True $ takeDirectory outputFile + io . writeUtf8 outputFile . Transcript.formatStanzas $ toList out + when expectFailure $ do + let errMsg = "Expected a failure, but transcript was successful." + io $ recordFailure (filePath, Text.pack errMsg) + crash errMsg + ok where - files = fmap (dir ) (prelude ++ [transcript]) + files = prelude ++ [transcript] outputFileForTranscript :: FilePath -> FilePath outputFileForTranscript filePath = replaceExtension filePath ".output.md" -buildTests :: TestConfig -> TestBuilder -> FilePath -> Test () -buildTests TestConfig {..} testBuilder dir = do - io - . putStrLn - . unlines - $ [ "", - "Searching for transcripts to run in: " ++ dir - ] - files <- io $ listDirectory dir +enumerateTests :: TestConfig -> TestBuilder -> [FilePath] -> Test () +enumerateTests TestConfig {..} testBuilder files = do + io . putStrLn . unlines $ + [ "", + "Running explicitly-named transcripts" + ] + -- Any files that start with _ are treated as prelude + let (prelude, transcripts) = + files + & sort + & partition (isPrefixOf "_" . snd . splitFileName) + -- if there is a matchPrefix set, filter non-prelude files by that prefix - or return True + & second (filter (\f -> maybe True (`isPrefixOf` f) matchPrefix)) + + case length transcripts of + 0 -> pure () + -- EasyTest exits early with "no test results recorded" if you don't give it any tests, this keeps it going till the + -- end so we can search all transcripts for prefix matches. + _ -> + tests (testBuilder runtimePath "." ("unison-src" "transcripts" "project-outputs") prelude <$> transcripts) + +buildTests :: TestConfig -> TestBuilder -> FilePath -> Maybe FilePath -> Test () +buildTests TestConfig {..} testBuilder inputDir outputDir = do + io . putStrLn . unlines $ + [ "", + "Searching for transcripts to run in: " ++ inputDir + ] + files <- io $ listDirectory inputDir -- Any files that start with _ are treated as prelude let (prelude, transcripts) = files & sort - & filter (\f -> takeExtensions f == ".md") - & partition ((isPrefixOf "_") . snd . splitFileName) + & filter (\f -> let ext = takeExtensions f in ext == ".md" || ext == ".markdown") + & partition (isPrefixOf "_" . snd . splitFileName) -- if there is a matchPrefix set, filter non-prelude files by that prefix - or return True & second (filter (\f -> maybe True (`isPrefixOf` f) matchPrefix)) @@ -106,7 +148,7 @@ buildTests TestConfig {..} testBuilder dir = do -- if you don't give it any tests, this keeps it going -- till the end so we can search all transcripts for -- prefix matches. - _ -> tests (testBuilder runtimePath dir prelude <$> transcripts) + _ -> tests (testBuilder runtimePath inputDir (fromMaybe inputDir outputDir) prelude <$> transcripts) -- Transcripts that exit successfully get cleaned-up by the transcript parser. -- Any remaining folders matching "transcript-.*" are output directories @@ -120,13 +162,11 @@ cleanup = do unless (null dirs) $ do io $ createDirectoryIfMissing True "test-output" io $ for_ dirs (\d -> renameDirectory d ("test-output" d)) - io - . putStrLn - . unlines - $ [ "", - "NOTE: All transcript codebases have been moved into", - "the `test-output` directory. Feel free to delete it." - ] + io . putStrLn . unlines $ + [ "", + "NOTE: All transcript codebases have been moved into", + "the `test-output` directory. Feel free to delete it." + ] test :: TestConfig -> Test () test config = do @@ -134,12 +174,16 @@ test config = do -- what went wrong in CI failuresVar <- io $ STM.newTVarIO [] let recordFailure failure = STM.atomically $ STM.modifyTVar' failuresVar (failure :) - buildTests config (testBuilder False recordFailure) $ - "unison-src" "transcripts" - buildTests config (testBuilder False recordFailure) $ - "unison-src" "transcripts-using-base" - buildTests config (testBuilder True recordFailure) $ - "unison-src" "transcripts" "errors" + buildTests config (testBuilder False False recordFailure) ("unison-src" "transcripts") Nothing + buildTests config (testBuilder False True recordFailure) ("unison-src" "transcripts" "idempotent") Nothing + buildTests config (testBuilder False False recordFailure) ("unison-src" "transcripts-using-base") Nothing + buildTests config (testBuilder True False recordFailure) ("unison-src" "transcripts" "errors") Nothing + buildTests config (testBuilder False False recordFailure) "docs" . Just $ + "unison-src" "transcripts" "project-outputs" "docs" + enumerateTests config (testBuilder False False recordFailure) $ + [ ".github/ISSUE_TEMPLATE/bug_report.md", + ".github/pull_request_template.md" + ] failures <- io $ STM.readTVarIO failuresVar -- Print all aggregated failures when (not $ null failures) . io $ Text.putStrLn $ "Failures:" @@ -150,8 +194,7 @@ test config = do cleanup handleArgs :: TestConfig -> [String] -> TestConfig -handleArgs acc ("--runtime-path" : p : rest) = - handleArgs (acc {runtimePath = p}) rest +handleArgs acc ("--runtime-path" : p : rest) = handleArgs (acc {runtimePath = p}) rest handleArgs acc [prefix] = acc {matchPrefix = Just prefix} handleArgs acc _ = acc @@ -163,7 +206,4 @@ defaultConfig = TestConfig Nothing <$> defaultRTP pure (takeDirectory ucm "runtime" "unison-runtime" <.> exeExtension) main :: IO () -main = withCP65001 do - dcfg <- defaultConfig - testConfig <- handleArgs dcfg <$> getArgs - run (test testConfig) +main = withCP65001 $ run . test =<< handleArgs <$> defaultConfig <*> getArgs diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index d530ed68b2..b1e8689789 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -17,10 +17,6 @@ source-repository head type: git location: https://github.com/unisonweb/unison -flag optimized - manual: True - default: False - library exposed-modules: ArgParse @@ -38,16 +34,16 @@ library Unison.Cli.MergeTypes Unison.Cli.Monad Unison.Cli.MonadUtils + Unison.Cli.NameResolutionUtils Unison.Cli.NamesUtils Unison.Cli.Pretty - Unison.Cli.PrettyPrintUtils Unison.Cli.ProjectUtils Unison.Cli.ServantClientUtils Unison.Cli.Share.Projects Unison.Cli.Share.Projects.Types Unison.Cli.TypeCheck Unison.Cli.UniqueTypeGuidLookup - Unison.Cli.UnisonConfigUtils + Unison.Cli.UpdateUtils Unison.Codebase.Editor.AuthorInfo Unison.Codebase.Editor.HandleInput Unison.Codebase.Editor.HandleInput.AddRun @@ -59,13 +55,20 @@ library Unison.Codebase.Editor.HandleInput.CommitUpgrade Unison.Codebase.Editor.HandleInput.DebugDefinition Unison.Codebase.Editor.HandleInput.DebugFoldRanges + Unison.Codebase.Editor.HandleInput.DebugSynhashTerm Unison.Codebase.Editor.HandleInput.DeleteBranch + Unison.Codebase.Editor.HandleInput.DeleteNamespace Unison.Codebase.Editor.HandleInput.DeleteProject + Unison.Codebase.Editor.HandleInput.Dependents + Unison.Codebase.Editor.HandleInput.EditDependents Unison.Codebase.Editor.HandleInput.EditNamespace Unison.Codebase.Editor.HandleInput.FindAndReplace Unison.Codebase.Editor.HandleInput.FormatFile + Unison.Codebase.Editor.HandleInput.Global Unison.Codebase.Editor.HandleInput.InstallLib Unison.Codebase.Editor.HandleInput.Load + Unison.Codebase.Editor.HandleInput.Ls + Unison.Codebase.Editor.HandleInput.LSPDebug Unison.Codebase.Editor.HandleInput.Merge2 Unison.Codebase.Editor.HandleInput.MoveAll Unison.Codebase.Editor.HandleInput.MoveBranch @@ -80,12 +83,14 @@ library Unison.Codebase.Editor.HandleInput.ProjectSwitch Unison.Codebase.Editor.HandleInput.Pull Unison.Codebase.Editor.HandleInput.Push + Unison.Codebase.Editor.HandleInput.Reflogs Unison.Codebase.Editor.HandleInput.ReleaseDraft Unison.Codebase.Editor.HandleInput.Run Unison.Codebase.Editor.HandleInput.RuntimeUtils Unison.Codebase.Editor.HandleInput.ShowDefinition Unison.Codebase.Editor.HandleInput.TermResolution Unison.Codebase.Editor.HandleInput.Tests + Unison.Codebase.Editor.HandleInput.Todo Unison.Codebase.Editor.HandleInput.UI Unison.Codebase.Editor.HandleInput.Update Unison.Codebase.Editor.HandleInput.Update2 @@ -100,10 +105,11 @@ library Unison.Codebase.Editor.SlurpComponent Unison.Codebase.Editor.SlurpResult Unison.Codebase.Editor.StructuredArgument - Unison.Codebase.Editor.TodoOutput Unison.Codebase.Editor.UCMVersion Unison.Codebase.Editor.UriParser - Unison.Codebase.TranscriptParser + Unison.Codebase.Transcript + Unison.Codebase.Transcript.Parser + Unison.Codebase.Transcript.Runner Unison.Codebase.Watch Unison.CommandLine Unison.CommandLine.BranchRelativePath @@ -111,6 +117,7 @@ library Unison.CommandLine.DisplayValues Unison.CommandLine.FuzzySelect Unison.CommandLine.FZFResolvers + Unison.CommandLine.Helpers Unison.CommandLine.InputPattern Unison.CommandLine.InputPatterns Unison.CommandLine.Main @@ -127,6 +134,7 @@ library Unison.LSP.Conversions Unison.LSP.Diagnostics Unison.LSP.FileAnalysis + Unison.LSP.FileAnalysis.UnusedBindings Unison.LSP.FoldingRange Unison.LSP.Formatting Unison.LSP.HandlerUtils @@ -136,6 +144,8 @@ library Unison.LSP.Queries Unison.LSP.Types Unison.LSP.UCMWorker + Unison.LSP.Util.IntersectionMap + Unison.LSP.Util.Signal Unison.LSP.VFS Unison.Main Unison.Share.Codeserver @@ -182,37 +192,34 @@ library ViewPatterns ghc-options: -Wall build-depends: - IntervalMap + Diff + , IntervalMap , ListLike , aeson >=2.0.0.0 , aeson-pretty , ansi-terminal , async , base - , bytes , bytestring + , cmark , co-log-core , code-page , concurrent-output - , configurator , containers >=0.6.3 , cryptonite , directory , either , errors - , exceptions , extra , filepath , free , friendly-time , fsnotify - , fuzzyfind , generic-lens , haskeline , http-client >=0.7.6 , http-client-tls , http-types - , jwt , ki , lens , lock-file @@ -221,33 +228,27 @@ library , megaparsec , memory , mtl - , network , network-simple - , network-udp , network-uri , nonempty-containers + , numerals , open-browser , optparse-applicative >=0.16.1.0 , pretty-simple , process - , random >=1.2.0 , random-shuffle , recover-rtti , regex-tdfa , semialign - , semigroups , servant , servant-client - , shellmet , stm - , template-haskell , temporary , text , text-ansi , text-builder , text-rope , these - , these-lens , time , transformers , unison-codebase @@ -260,16 +261,15 @@ library , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-runtime , unison-share-api , unison-share-projects-api , unison-sqlite , unison-syntax , unison-util-base32hex - , unison-util-nametree + , unison-util-recursion , unison-util-relation , unliftio - , unordered-containers - , uri-encode , uuid , vector , wai @@ -277,8 +277,6 @@ library , witch , witherable default-language: Haskell2010 - if flag(optimized) - ghc-options: -O2 -funbox-strict-fields if !os(windows) build-depends: unix @@ -323,106 +321,19 @@ executable transcripts ViewPatterns ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-I0 -N -qn4 -qg1" -v0 build-depends: - IntervalMap - , ListLike - , aeson >=2.0.0.0 - , aeson-pretty - , ansi-terminal - , async - , base - , bytes - , bytestring - , co-log-core + base , code-page - , concurrent-output - , configurator - , containers >=0.6.3 - , cryptonite , directory , easytest - , either - , errors - , exceptions - , extra , filepath - , free - , friendly-time - , fsnotify - , fuzzyfind - , generic-lens - , haskeline - , http-client >=0.7.6 - , http-client-tls - , http-types - , jwt - , ki - , lens - , lock-file - , lsp >=2.2.0.0 - , lsp-types >=2.0.2.0 , megaparsec - , memory - , mtl - , network - , network-simple - , network-udp - , network-uri - , nonempty-containers - , open-browser - , optparse-applicative >=0.16.1.0 - , pretty-simple - , process - , random >=1.2.0 - , random-shuffle - , recover-rtti - , regex-tdfa - , semialign - , semigroups - , servant - , servant-client - , shellmet , silently - , stm - , template-haskell - , temporary , text - , text-ansi - , text-builder - , text-rope - , these - , these-lens - , time - , transformers , unison-cli - , unison-codebase - , unison-codebase-sqlite - , unison-codebase-sqlite-hashing-v2 - , unison-core - , unison-core1 - , unison-hash - , unison-merge , unison-parser-typechecker , unison-prelude - , unison-pretty-printer - , unison-share-api - , unison-share-projects-api - , unison-sqlite - , unison-syntax - , unison-util-base32hex - , unison-util-nametree - , unison-util-relation , unliftio - , unordered-containers - , uri-encode - , uuid - , vector - , wai - , warp - , witch - , witherable default-language: Haskell2010 - if flag(optimized) - ghc-options: -O2 -funbox-strict-fields test-suite cli-tests type: exitcode-stdio-1.0 @@ -471,103 +382,26 @@ test-suite cli-tests ViewPatterns ghc-options: -Wall build-depends: - IntervalMap - , ListLike - , aeson >=2.0.0.0 - , aeson-pretty - , ansi-terminal - , async - , base - , bytes - , bytestring - , co-log-core + base , code-page - , concurrent-output - , configurator - , containers >=0.6.3 + , containers , cryptonite , directory , easytest - , either - , errors - , exceptions , extra - , filepath - , free - , friendly-time - , fsnotify - , fuzzyfind - , generic-lens - , haskeline , here - , http-client >=0.7.6 - , http-client-tls - , http-types - , jwt - , ki , lens - , lock-file - , lsp >=2.2.0.0 - , lsp-types >=2.0.2.0 + , lsp-types , megaparsec - , memory - , mtl - , network - , network-simple - , network-udp - , network-uri - , nonempty-containers - , open-browser - , optparse-applicative >=0.16.1.0 - , pretty-simple - , process - , random >=1.2.0 - , random-shuffle - , recover-rtti - , regex-tdfa - , semialign - , semigroups - , servant - , servant-client - , shellmet - , stm - , template-haskell , temporary , text - , text-ansi - , text-builder - , text-rope , these - , these-lens - , time - , transformers , unison-cli - , unison-codebase - , unison-codebase-sqlite - , unison-codebase-sqlite-hashing-v2 , unison-core , unison-core1 - , unison-hash - , unison-merge , unison-parser-typechecker , unison-prelude , unison-pretty-printer - , unison-share-api - , unison-share-projects-api - , unison-sqlite , unison-syntax - , unison-util-base32hex - , unison-util-nametree - , unison-util-relation - , unliftio - , unordered-containers - , uri-encode - , uuid - , vector - , wai - , warp - , witch - , witherable + , unison-util-recursion default-language: Haskell2010 - if flag(optimized) - ghc-options: -O2 -funbox-strict-fields diff --git a/unison-core/package.yaml b/unison-core/package.yaml index 210367d234..1b9f2d996e 100644 --- a/unison-core/package.yaml +++ b/unison-core/package.yaml @@ -14,7 +14,6 @@ library: - containers >= 0.6.3 - nonempty-containers - cryptonite - - either - extra - fuzzyfind - generic-lens @@ -23,17 +22,15 @@ library: - memory - mtl - rfc5051 - - safe + - semialign + - semigroups - text - text-builder - these - - transformers - unison-core - unison-hash - unison-prelude - - unison-util-base32hex - unison-util-relation - - vector - witch tests: @@ -54,7 +51,7 @@ tests: source-dirs: test default-extensions: - - ApplicativeDo + - BangPatterns - BlockArguments - DeriveAnyClass - DeriveFoldable @@ -62,29 +59,25 @@ default-extensions: - DeriveGeneric - DeriveTraversable - DerivingStrategies + - DerivingVia - DoAndIfThenElse + - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost + - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - NamedFieldPuns + - OverloadedLabels - OverloadedStrings + - OverloadedRecordDot - PatternSynonyms - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - ViewPatterns - -flags: - optimized: - manual: true - default: false - -when: - - condition: flag(optimized) - ghc-options: -O2 -funbox-strict-fields diff --git a/unison-core/src/Unison/ABT.hs b/unison-core/src/Unison/ABT.hs index fe9a8f930e..d838b2a730 100644 --- a/unison-core/src/Unison/ABT.hs +++ b/unison-core/src/Unison/ABT.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} --- Based on: http://semantic-domain.blogspot.com/2015/03/abstract-binding-trees.html {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} @@ -12,10 +11,12 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +-- | Based on: http://semantic-domain.blogspot.com/2015/03/abstract-binding-trees.html module Unison.ABT ( -- * Types ABT (..), Term (..), + Term' (..), Var (..), V (..), Subst (..), @@ -41,8 +42,6 @@ module Unison.ABT rebuildUp', reannotateUp, rewriteDown, - cata, - para, transform, transformM, foreachSubterm, @@ -111,12 +110,11 @@ import Data.Set qualified as Set import U.Core.ABT ( ABT (..), Term (..), + Term' (..), allVars, - cata, foreachSubterm, freshInBoth, freshenS, - para, rename, subst', substInheritAnnotation, diff --git a/unison-core/src/Unison/ABT/Normalized.hs b/unison-core/src/Unison/ABT/Normalized.hs index b04bb439d3..1fc0316048 100644 --- a/unison-core/src/Unison/ABT/Normalized.hs +++ b/unison-core/src/Unison/ABT/Normalized.hs @@ -17,16 +17,18 @@ module Unison.ABT.Normalized renames, rename, transform, + visit, + visitPure, ) where import Data.Bifoldable import Data.Bifunctor import Data.Foldable (toList) --- import Data.Bitraversable - +import Data.Functor.Identity (Identity (..)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.Set qualified as Set import Unison.ABT (Var (..)) @@ -103,7 +105,7 @@ class (Bifoldable f, Bifunctor f) => Align f where alphaErr :: (Align f) => (Var v) => Map v v -> Term f v -> Term f v -> Either (Term f v, Term f v) a -alphaErr un tml tmr = Left (tml, renames count un tmr) +alphaErr un tml tmr = Left (tml, renames0 count un tmr) where count = Map.fromListWith (+) . flip zip [1, 1 ..] $ toList un @@ -133,21 +135,21 @@ pattern TAbss vs bd <- {-# COMPLETE TAbss #-} --- Simultaneous variable renaming. +-- Simultaneous variable renaming implementation. -- -- subvs0 counts the number of variables being renamed to a particular -- variable -- -- rnv0 is the variable renaming map. -renames :: +renames0 :: (Var v, Ord v, Bifunctor f, Bifoldable f) => Map v Int -> Map v v -> Term f v -> Term f v -renames subvs0 rnv0 tm = case tm of +renames0 subvs0 rnv0 tm = case tm of TAbs u body - | not $ Map.null rnv' -> TAbs u' (renames subvs' rnv' body) + | not $ Map.null rnv' -> TAbs u' (renames0 subvs' rnv' body) where rnv' = Map.alter (const $ adjustment) u rnv -- if u is in the set of variables we're substituting in, it @@ -164,7 +166,7 @@ renames subvs0 rnv0 tm = case tm of | otherwise = (Nothing, subvs) TTm body | not $ Map.null rnv -> - TTm $ bimap (\u -> Map.findWithDefault u u rnv) (renames subvs rnv) body + TTm $ bimap (\u -> Map.findWithDefault u u rnv) (renames0 subvs rnv) body _ -> tm where fvs = freeVars tm @@ -179,13 +181,23 @@ renames subvs0 rnv0 tm = case tm of | n <= 1 = Nothing | otherwise = Just (n - 1) +-- Simultaneous variable renaming. +renames :: + (Var v, Ord v, Bifunctor f, Bifoldable f) => + Map v v -> + Term f v -> + Term f v +renames rnv tm = renames0 subvs rnv tm + where + subvs = Map.fromListWith (+) . fmap (,1) $ Map.elems rnv + rename :: (Var v, Ord v, Bifunctor f, Bifoldable f) => v -> v -> Term f v -> Term f v -rename old new = renames (Map.singleton new 1) (Map.singleton old new) +rename old new = renames0 (Map.singleton new 1) (Map.singleton old new) transform :: (Var v, Bifunctor g, Bifoldable f, Bifoldable g) => @@ -194,3 +206,19 @@ transform :: Term g v transform phi (TTm body) = TTm . second (transform phi) $ phi body transform phi (TAbs u body) = TAbs u $ transform phi body + +visit :: + (Applicative g, Bifoldable f, Traversable (f v), Var v) => + (Term f v -> Maybe (g (Term f v))) -> + Term f v -> + g (Term f v) +visit h t = flip fromMaybe (h t) $ case out t of + Abs x e -> TAbs x <$> visit h e + Tm body -> TTm <$> traverse (visit h) body + +visitPure :: + (Bifoldable f, Traversable (f v), Var v) => + (Term f v -> Maybe (Term f v)) -> + Term f v -> + Term f v +visitPure h = runIdentity . visit (fmap pure . h) diff --git a/unison-core/src/Unison/ConstructorReference.hs b/unison-core/src/Unison/ConstructorReference.hs index 20fc68a9c5..32985c69b8 100644 --- a/unison-core/src/Unison/ConstructorReference.hs +++ b/unison-core/src/Unison/ConstructorReference.hs @@ -4,6 +4,7 @@ module Unison.ConstructorReference ConstructorReference, ConstructorReferenceId, reference_, + toId, toShortHash, ) where @@ -29,6 +30,10 @@ reference_ :: Lens (GConstructorReference r) (GConstructorReference s) r s reference_ = lens (\(ConstructorReference r _) -> r) \(ConstructorReference _ i) r -> ConstructorReference r i +toId :: ConstructorReference -> Maybe ConstructorReferenceId +toId (ConstructorReference typeRef conId) = + ConstructorReference <$> Reference.toId typeRef <*> pure conId + toShortHash :: ConstructorReference -> ShortHash toShortHash (ConstructorReference r i) = case Reference.toShortHash r of diff --git a/unison-core/src/Unison/DataDeclaration.hs b/unison-core/src/Unison/DataDeclaration.hs index b6c9776dc7..5972bd9abe 100644 --- a/unison-core/src/Unison/DataDeclaration.hs +++ b/unison-core/src/Unison/DataDeclaration.hs @@ -49,10 +49,10 @@ import Unison.LabeledDependency qualified as LD import Unison.Name qualified as Name import Unison.Names.ResolutionResult qualified as Names import Unison.Prelude -import Unison.Reference (Reference) +import Unison.Reference (Reference, TypeReference) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent -import Unison.Referent' qualified as Referent' +import Unison.ReferentPrime qualified as Referent' import Unison.Type (Type) import Unison.Type qualified as Type import Unison.Var (Var) @@ -108,7 +108,7 @@ data DataDeclaration v a = DataDeclaration bound :: [v], constructors' :: [(a, v, Type v a)] } - deriving (Eq, Ord, Show, Functor) + deriving (Eq, Ord, Show, Functor, Generic) constructorCount :: DataDeclaration v a -> Int constructorCount DataDeclaration {constructors'} = length constructors' @@ -211,7 +211,7 @@ bindReferences :: Set v -> Map Name.Name Reference -> DataDeclaration v a -> - Names.ResolutionResult v a (DataDeclaration v a) + Names.ResolutionResult a (DataDeclaration v a) bindReferences unsafeVarToName keepFree names (DataDeclaration m a bound constructors) = do constructors <- for constructors $ \(a, v, ty) -> (a,v,) <$> Type.bindReferences unsafeVarToName keepFree names ty @@ -222,7 +222,7 @@ bindReferences unsafeVarToName keepFree names (DataDeclaration m a bound constru -- (unless the decl is self-referential) -- Note: Does NOT include the referents for fields and field accessors. -- Those must be computed separately because we need access to the typechecker to do so. -typeDependencies :: (Ord v) => DataDeclaration v a -> Set Reference +typeDependencies :: (Ord v) => DataDeclaration v a -> Set TypeReference typeDependencies dd = Set.unions (Type.dependencies <$> constructorTypes dd) diff --git a/unison-core/src/Unison/DataDeclaration/Names.hs b/unison-core/src/Unison/DataDeclaration/Names.hs index e1e7549308..5cc2c297f1 100644 --- a/unison-core/src/Unison/DataDeclaration/Names.hs +++ b/unison-core/src/Unison/DataDeclaration/Names.hs @@ -1,28 +1,30 @@ {-# LANGUAGE RecordWildCards #-} -module Unison.DataDeclaration.Names (bindNames, dataDeclToNames', effectDeclToNames') where - -import Data.Map qualified as Map -import Data.Set qualified as Set -import Unison.ABT qualified as ABT +module Unison.DataDeclaration.Names + ( bindNames, + dataDeclToNames', + effectDeclToNames', + ) +where + +import Control.Lens (traverseOf, _3) import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorType qualified as CT -import Unison.DataDeclaration (DataDeclaration (DataDeclaration), EffectDeclaration) +import Unison.DataDeclaration (DataDeclaration (..), EffectDeclaration) import Unison.DataDeclaration qualified as DD -import Unison.Name qualified as Name +import Unison.Name (Name) import Unison.Names (Names (Names)) import Unison.Names.ResolutionResult qualified as Names import Unison.Prelude import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent -import Unison.Type qualified as Type import Unison.Type.Names qualified as Type.Names import Unison.Util.Relation qualified as Rel import Unison.Var (Var) import Prelude hiding (cycle) -- implementation of dataDeclToNames and effectDeclToNames -toNames :: (Var v) => (v -> Name.Name) -> CT.ConstructorType -> v -> Reference.Id -> DataDeclaration v a -> Names +toNames :: (Var v) => (v -> Name) -> CT.ConstructorType -> v -> Reference.Id -> DataDeclaration v a -> Names toNames varToName ct typeSymbol (Reference.DerivedId -> r) dd = -- constructor names foldMap names (DD.constructorVars dd `zip` [0 ..]) @@ -32,29 +34,25 @@ toNames varToName ct typeSymbol (Reference.DerivedId -> r) dd = names (ctor, i) = Names (Rel.singleton (varToName ctor) (Referent.Con (ConstructorReference r i) ct)) mempty -dataDeclToNames :: (Var v) => (v -> Name.Name) -> v -> Reference.Id -> DataDeclaration v a -> Names +dataDeclToNames :: (Var v) => (v -> Name) -> v -> Reference.Id -> DataDeclaration v a -> Names dataDeclToNames varToName = toNames varToName CT.Data -effectDeclToNames :: (Var v) => (v -> Name.Name) -> v -> Reference.Id -> EffectDeclaration v a -> Names +effectDeclToNames :: (Var v) => (v -> Name) -> v -> Reference.Id -> EffectDeclaration v a -> Names effectDeclToNames varToName typeSymbol r ed = toNames varToName CT.Effect typeSymbol r $ DD.toDataDecl ed -dataDeclToNames' :: (Var v) => (v -> Name.Name) -> (v, (Reference.Id, DataDeclaration v a)) -> Names +dataDeclToNames' :: (Var v) => (v -> Name) -> (v, (Reference.Id, DataDeclaration v a)) -> Names dataDeclToNames' varToName (v, (r, d)) = dataDeclToNames varToName v r d -effectDeclToNames' :: (Var v) => (v -> Name.Name) -> (v, (Reference.Id, EffectDeclaration v a)) -> Names +effectDeclToNames' :: (Var v) => (v -> Name) -> (v, (Reference.Id, EffectDeclaration v a)) -> Names effectDeclToNames' varToName (v, (r, d)) = effectDeclToNames varToName v r d bindNames :: (Var v) => - (v -> Name.Name) -> - Map v v -> + (v -> Name) -> + (Name -> v) -> + Set v -> Names -> DataDeclaration v a -> - Names.ResolutionResult v a (DataDeclaration v a) -bindNames varToName localNames names (DataDeclaration m a bound constructors) = do - constructors <- for constructors $ \(a, v, ty) -> - (a,v,) <$> Type.Names.bindNames varToName keepFree names (ABT.substsInheritAnnotation subs ty) - pure $ DataDeclaration m a bound constructors - where - keepFree = Set.fromList (Map.elems localNames) - subs = Map.toList $ Map.map (Type.var ()) localNames + Names.ResolutionResult a (DataDeclaration v a) +bindNames unsafeVarToName nameToVar localNames namespaceNames = + traverseOf (#constructors' . traverse . _3) (Type.Names.bindNames unsafeVarToName nameToVar localNames namespaceNames) diff --git a/unison-core/src/Unison/DataDeclaration/Records.hs b/unison-core/src/Unison/DataDeclaration/Records.hs index ac12dfb08c..cdbd13fa3e 100644 --- a/unison-core/src/Unison/DataDeclaration/Records.hs +++ b/unison-core/src/Unison/DataDeclaration/Records.hs @@ -41,7 +41,7 @@ generateRecordAccessors namespaced generatedAnn fields typename typ = -- point -> case point of Point _ y _ -> y get = - Term.lam ann argname $ + Term.lam ann (ann, argname) $ Term.match ann (Term.var ann argname) @@ -57,7 +57,7 @@ generateRecordAccessors namespaced generatedAnn fields typename typ = -- y' point -> case point of Point x _ z -> Point x y' z set = - Term.lam' ann [fname', argname] $ + Term.lam' ann [(ann, fname'), (ann, argname)] $ Term.match ann (Term.var ann argname) @@ -86,7 +86,7 @@ generateRecordAccessors namespaced generatedAnn fields typename typ = -- example: `f point -> case point of Point x y z -> Point x (f y) z` modify = - Term.lam' ann [fname', argname] $ + Term.lam' ann [(ann, fname'), (ann, argname)] $ Term.match ann (Term.var ann argname) diff --git a/unison-merge/src/Unison/Merge/DeclNameLookup.hs b/unison-core/src/Unison/DeclNameLookup.hs similarity index 89% rename from unison-merge/src/Unison/Merge/DeclNameLookup.hs rename to unison-core/src/Unison/DeclNameLookup.hs index 08611a944c..70543061fc 100644 --- a/unison-merge/src/Unison/Merge/DeclNameLookup.hs +++ b/unison-core/src/Unison/DeclNameLookup.hs @@ -1,4 +1,4 @@ -module Unison.Merge.DeclNameLookup +module Unison.DeclNameLookup ( DeclNameLookup (..), expectDeclName, expectConstructorNames, @@ -40,13 +40,13 @@ data DeclNameLookup = DeclNameLookup deriving stock (Generic) deriving (Semigroup) via (GenericSemigroupMonoid DeclNameLookup) -expectDeclName :: HasCallStack => DeclNameLookup -> Name -> Name +expectDeclName :: (HasCallStack) => DeclNameLookup -> Name -> Name expectDeclName DeclNameLookup {constructorToDecl} x = case Map.lookup x constructorToDecl of Nothing -> error (reportBug "E246726" ("Expected constructor name key " <> show x <> " in decl name lookup")) Just y -> y -expectConstructorNames :: HasCallStack => DeclNameLookup -> Name -> [Name] +expectConstructorNames :: (HasCallStack) => DeclNameLookup -> Name -> [Name] expectConstructorNames DeclNameLookup {declToConstructors} x = case Map.lookup x declToConstructors of Nothing -> error (reportBug "E077058" ("Expected decl name key " <> show x <> " in decl name lookup")) diff --git a/unison-core/src/Unison/HashQualified'.hs b/unison-core/src/Unison/HashQualified'.hs deleted file mode 100644 index 48bacfc6d1..0000000000 --- a/unison-core/src/Unison/HashQualified'.hs +++ /dev/null @@ -1,126 +0,0 @@ -module Unison.HashQualified' where - -import Data.Text qualified as Text -import Unison.HashQualified qualified as HQ -import Unison.Name (Convert, Name, Parse) -import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment) -import Unison.Prelude -import Unison.Reference (Reference) -import Unison.Reference qualified as Reference -import Unison.Referent (Referent) -import Unison.Referent qualified as Referent -import Unison.ShortHash (ShortHash) -import Unison.ShortHash qualified as SH -import Prelude hiding (take) - --- | Like Unison.HashQualified, but doesn't support a HashOnly variant -data HashQualified n = NameOnly n | HashQualified n ShortHash - deriving stock (Eq, Functor, Generic, Foldable, Ord, Show, Traversable) - -type HQSegment = HashQualified NameSegment - -toHQ :: HashQualified n -> HQ.HashQualified n -toHQ = \case - NameOnly n -> HQ.NameOnly n - HashQualified n sh -> HQ.HashQualified n sh - -fromHQ :: HQ.HashQualified n -> Maybe (HashQualified n) -fromHQ = \case - HQ.NameOnly n -> Just $ NameOnly n - HQ.HashQualified n sh -> Just $ HashQualified n sh - HQ.HashOnly {} -> Nothing - --- | Like 'fromHQ', but if the 'HQ.HashQualified' is just a 'ShortHash', return it on the 'Left', rather than as a --- 'Nothing'. -fromHQ2 :: HQ.HashQualified n -> Either ShortHash (HashQualified n) -fromHQ2 = \case - HQ.NameOnly n -> Right $ NameOnly n - HQ.HashQualified n sh -> Right $ HashQualified n sh - HQ.HashOnly sh -> Left sh - -toName :: HashQualified n -> n -toName = \case - NameOnly name -> name - HashQualified name _ -> name - -nameLength :: (Name -> Text) -> HashQualified Name -> Int -nameLength nameToText = Text.length . toTextWith nameToText - -take :: Int -> HashQualified n -> HashQualified n -take i = \case - n@(NameOnly _) -> n - HashQualified n s -> if i == 0 then NameOnly n else HashQualified n (SH.shortenTo i s) - -toNameOnly :: HashQualified n -> HashQualified n -toNameOnly = fromName . toName - -toHash :: HashQualified n -> Maybe ShortHash -toHash = \case - NameOnly _ -> Nothing - HashQualified _ sh -> Just sh - -toStringWith :: (n -> String) -> HashQualified n -> String -toStringWith f = Text.unpack . toTextWith (Text.pack . f) - -toTextWith :: (n -> Text) -> HashQualified n -> Text -toTextWith f = \case - NameOnly name -> f name - HashQualified name hash -> f name <> SH.toText hash - --- Returns the full referent in the hash. Use HQ.take to just get a prefix -fromNamedReferent :: n -> Referent -> HashQualified n -fromNamedReferent n r = HashQualified n (Referent.toShortHash r) - --- Returns the full reference in the hash. Use HQ.take to just get a prefix -fromNamedReference :: n -> Reference -> HashQualified n -fromNamedReference n r = HashQualified n (Reference.toShortHash r) - -fromName :: n -> HashQualified n -fromName = NameOnly - -fromNameHash :: n -> Maybe ShortHash -> HashQualified n -fromNameHash name = \case - Nothing -> NameOnly name - Just hash -> HashQualified name hash - -matchesNamedReferent :: (Eq n) => n -> Referent -> HashQualified n -> Bool -matchesNamedReferent n r = \case - NameOnly n' -> n' == n - HashQualified n' sh -> n' == n && sh `SH.isPrefixOf` Referent.toShortHash r - -matchesNamedReference :: (Eq n) => n -> Reference -> HashQualified n -> Bool -matchesNamedReference n r = \case - NameOnly n' -> n' == n - HashQualified n' sh -> n' == n && sh `SH.isPrefixOf` Reference.toShortHash r - --- Use `requalify hq . Referent.Ref` if you want to pass in a `Reference`. -requalify :: HashQualified Name -> Referent -> HashQualified Name -requalify hq r = case hq of - NameOnly n -> fromNamedReferent n r - HashQualified n _ -> fromNamedReferent n r - --- | Sort the list of names by length of segments: smaller number of segments is listed first. NameOnly < HashQualified -sortByLength :: [HashQualified Name] -> [HashQualified Name] -sortByLength = - sortOn \case - NameOnly name -> (length (Name.reverseSegments name), Nothing, Name.isAbsolute name) - HashQualified name hash -> (length (Name.reverseSegments name), Just hash, Name.isAbsolute name) - -instance (Name.Alphabetical n) => Name.Alphabetical (HashQualified n) where - compareAlphabetical (NameOnly n) (NameOnly n2) = Name.compareAlphabetical n n2 - -- NameOnly comes first - compareAlphabetical NameOnly {} HashQualified {} = LT - compareAlphabetical HashQualified {} NameOnly {} = GT - compareAlphabetical (HashQualified n sh) (HashQualified n2 sh2) = Name.compareAlphabetical n n2 <> compare sh sh2 - -instance (Convert n n2) => Parse (HashQualified n) n2 where - parse = \case - NameOnly n -> Just (Name.convert n) - _ -> Nothing - -instance Convert (HashQualified n) (HQ.HashQualified n) where - convert = toHQ - -instance Parse (HQ.HashQualified n) (HashQualified n) where - parse = fromHQ diff --git a/unison-core/src/Unison/HashQualified.hs b/unison-core/src/Unison/HashQualified.hs index cc1a0aa548..d143dc4740 100644 --- a/unison-core/src/Unison/HashQualified.hs +++ b/unison-core/src/Unison/HashQualified.hs @@ -3,7 +3,7 @@ module Unison.HashQualified where import Data.Text qualified as Text import Unison.ConstructorReference (ConstructorReference) import Unison.ConstructorReference qualified as ConstructorReference -import Unison.Name (Convert, Name) +import Unison.Name (Name) import Unison.Name qualified as Name import Unison.Prelude hiding (fromString) import Unison.Reference (Reference) @@ -139,9 +139,3 @@ instance (Name.Alphabetical n) => Name.Alphabetical (HashQualified n) where (Nothing, Just _) -> LT -- prefer NameOnly to HashQualified (Just _, Nothing) -> GT (Just sh, Just sh2) -> compare sh sh2 - -instance (Convert n n2) => Convert (HashQualified n) (HashQualified n2) where - convert = fmap Name.convert - -instance Convert n (HashQualified n) where - convert = NameOnly diff --git a/unison-core/src/Unison/HashQualifiedPrime.hs b/unison-core/src/Unison/HashQualifiedPrime.hs new file mode 100644 index 0000000000..19c341f4d6 --- /dev/null +++ b/unison-core/src/Unison/HashQualifiedPrime.hs @@ -0,0 +1,115 @@ +module Unison.HashQualifiedPrime where + +import Data.Text qualified as Text +import Unison.HashQualified qualified as HQ +import Unison.Name (Name) +import Unison.Name qualified as Name +import Unison.NameSegment (NameSegment) +import Unison.Prelude +import Unison.Reference (Reference) +import Unison.Reference qualified as Reference +import Unison.Referent (Referent) +import Unison.Referent qualified as Referent +import Unison.ShortHash (ShortHash) +import Unison.ShortHash qualified as SH +import Prelude hiding (take) + +-- | Like Unison.HashQualified, but doesn't support a HashOnly variant +data HashQualified n = NameOnly n | HashQualified n ShortHash + deriving stock (Eq, Functor, Generic, Foldable, Ord, Show, Traversable) + +type HQSegment = HashQualified NameSegment + +toHQ :: HashQualified n -> HQ.HashQualified n +toHQ = \case + NameOnly n -> HQ.NameOnly n + HashQualified n sh -> HQ.HashQualified n sh + +fromHQ :: HQ.HashQualified n -> Maybe (HashQualified n) +fromHQ = \case + HQ.NameOnly n -> Just $ NameOnly n + HQ.HashQualified n sh -> Just $ HashQualified n sh + HQ.HashOnly {} -> Nothing + +-- | Like 'fromHQ', but if the 'HQ.HashQualified' is just a 'ShortHash', return it on the 'Left', rather than as a +-- 'Nothing'. +fromHQ2 :: HQ.HashQualified n -> Either ShortHash (HashQualified n) +fromHQ2 = \case + HQ.NameOnly n -> Right $ NameOnly n + HQ.HashQualified n sh -> Right $ HashQualified n sh + HQ.HashOnly sh -> Left sh + +toName :: HashQualified n -> n +toName = \case + NameOnly name -> name + HashQualified name _ -> name + +nameLength :: (Name -> Text) -> HashQualified Name -> Int +nameLength nameToText = Text.length . toTextWith nameToText + +take :: Int -> HashQualified n -> HashQualified n +take i = \case + n@(NameOnly _) -> n + HashQualified n s -> if i == 0 then NameOnly n else HashQualified n (SH.shortenTo i s) + +toNameOnly :: HashQualified n -> HashQualified n +toNameOnly = fromName . toName + +toHash :: HashQualified n -> Maybe ShortHash +toHash = \case + NameOnly _ -> Nothing + HashQualified _ sh -> Just sh + +toStringWith :: (n -> String) -> HashQualified n -> String +toStringWith f = Text.unpack . toTextWith (Text.pack . f) + +toTextWith :: (n -> Text) -> HashQualified n -> Text +toTextWith f = \case + NameOnly name -> f name + HashQualified name hash -> f name <> SH.toText hash + +-- Returns the full referent in the hash. Use HQ.take to just get a prefix +fromNamedReferent :: n -> Referent -> HashQualified n +fromNamedReferent n r = HashQualified n (Referent.toShortHash r) + +-- Returns the full reference in the hash. Use HQ.take to just get a prefix +fromNamedReference :: n -> Reference -> HashQualified n +fromNamedReference n r = HashQualified n (Reference.toShortHash r) + +fromName :: n -> HashQualified n +fromName = NameOnly + +fromNameHash :: n -> Maybe ShortHash -> HashQualified n +fromNameHash name = \case + Nothing -> NameOnly name + Just hash -> HashQualified name hash + +matchesNamedReferent :: (Eq n) => n -> Referent -> HashQualified n -> Bool +matchesNamedReferent n r = \case + NameOnly n' -> n' == n + HashQualified n' sh -> n' == n && sh `SH.isPrefixOf` Referent.toShortHash r + +matchesNamedReference :: (Eq n) => n -> Reference -> HashQualified n -> Bool +matchesNamedReference n r = \case + NameOnly n' -> n' == n + HashQualified n' sh -> n' == n && sh `SH.isPrefixOf` Reference.toShortHash r + +-- Use `requalify hq . Referent.Ref` if you want to pass in a `Reference`. +requalify :: HashQualified Name -> Referent -> HashQualified Name +requalify hq r = case hq of + NameOnly n -> fromNamedReferent n r + HashQualified n _ -> fromNamedReferent n r + +-- | Sort the list of names by length of segments: smaller number of segments is listed first. NameOnly < HashQualified +sortByLength :: [HashQualified Name] -> [HashQualified Name] +sortByLength = + sortOn \case + NameOnly name -> (length (Name.reverseSegments name), Nothing, Name.isAbsolute name) + HashQualified name hash -> (length (Name.reverseSegments name), Just hash, Name.isAbsolute name) + +instance (Name.Alphabetical n) => Name.Alphabetical (HashQualified n) where + compareAlphabetical (NameOnly n) (NameOnly n2) = Name.compareAlphabetical n n2 + -- NameOnly comes first + compareAlphabetical NameOnly {} HashQualified {} = LT + compareAlphabetical HashQualified {} NameOnly {} = GT + compareAlphabetical (HashQualified n sh) (HashQualified n2 sh2) = Name.compareAlphabetical n n2 <> compare sh sh2 diff --git a/unison-core/src/Unison/Hashable.hs b/unison-core/src/Unison/Hashable.hs index b0d32ce2a9..69f7173bef 100644 --- a/unison-core/src/Unison/Hashable.hs +++ b/unison-core/src/Unison/Hashable.hs @@ -31,6 +31,7 @@ data Token h | Double !Double | Hashed !h | Nat !Word64 + deriving stock (Show) class Accumulate h where accumulate :: [Token h] -> h diff --git a/unison-core/src/Unison/Name.hs b/unison-core/src/Unison/Name.hs index 30f4f6d59a..2b8cb8f83d 100644 --- a/unison-core/src/Unison/Name.hs +++ b/unison-core/src/Unison/Name.hs @@ -1,7 +1,5 @@ module Unison.Name ( Name, - Convert (..), - Parse (..), -- * Basic construction cons, @@ -34,14 +32,18 @@ module Unison.Name parent, stripNamePrefix, unqualified, + isUnqualified, -- * To organize later commonPrefix, preferShallowLibDepth, searchByRankedSuffix, searchBySuffix, + filterBySuffix, + filterByRankedSuffix, suffixifyByName, suffixifyByHash, + suffixifyByHashName, sortByText, sortNamed, sortNames, @@ -335,6 +337,13 @@ searchBySuffix suffix rel = where orElse s1 s2 = if Set.null s1 then s2 else s1 +-- | Like 'searchBySuffix', but also keeps the names around. +filterBySuffix :: (Ord r) => Name -> R.Relation Name r -> R.Relation Name r +filterBySuffix suffix rel = + case Map.lookup suffix (R.domain rel) of + Just refs -> R.fromManyRan suffix refs + Nothing -> R.searchDomG R.fromManyRan (compareSuffix suffix) rel + -- Like `searchBySuffix`, but prefers local (outside `lib`) and direct (one `lib` deep) names to indirect (two or more -- `lib` deep) names. searchByRankedSuffix :: (Ord r) => Name -> R.Relation Name r -> Set r @@ -347,6 +356,19 @@ searchByRankedSuffix suffix rel = withNames = map (\r -> (filter ok (toList (R.lookupRan r rel)), r)) (toList rs) in preferShallowLibDepth withNames +-- | Like 'searchByRankedSuffix', but also keeps the names around. +filterByRankedSuffix :: (Ord r) => Name -> R.Relation Name r -> R.Relation Name r +filterByRankedSuffix suffix rel = + let matches = filterBySuffix suffix rel + highestNamePriority = foldMap prio (R.dom matches) + keep (name, _) = prio name <= highestNamePriority + in -- Keep only names that are at or less than the highest name priority. This effectively throws out all indirect + -- dependencies (NamePriorityTwo) if there are any direct dependencies (NamePriorityOne) or local definitions + -- (also NamePriorityOne). + R.filter keep matches + where + prio = nameLocationPriority . classifyNameLocation + -- | precondition: input list is deduped, and so is the Name list in -- the tuple preferShallowLibDepth :: (Ord r) => [([Name], r)] -> Set r @@ -355,29 +377,48 @@ preferShallowLibDepth = \case [x] -> Set.singleton (snd x) rs -> let byPriority = List.multimap (map (first minLibs) rs) - minLibs [] = NamePriorityOne - minLibs ns = minimum (map classifyNamePriority ns) - in case Map.lookup NamePriorityOne byPriority <|> Map.lookup NamePriorityTwo byPriority of + minLibs [] = NamePriorityOne () + minLibs ns = minimum (map (nameLocationPriority . classifyNameLocation) ns) + in case Map.lookup (NamePriorityOne ()) byPriority <|> Map.lookup (NamePriorityTwo ()) byPriority of Nothing -> Set.fromList (map snd rs) Just rs -> Set.fromList rs -data NamePriority - = NamePriorityOne -- highest priority: local names and direct dep names - | NamePriorityTwo -- lowest priority: indirect dep names - deriving stock (Eq, Ord) - -classifyNamePriority :: Name -> NamePriority -classifyNamePriority name = - case isIndirectDependency (List.NonEmpty.toList (segments name)) of - False -> NamePriorityOne - True -> NamePriorityTwo - where - -- isIndirectDependency foo = False - -- isIndirectDependency lib.bar.honk = False - -- isIndirectDependency lib.baz.lib.qux.flonk = True - isIndirectDependency = \case - ((== NameSegment.libSegment) -> True) : _ : ((== NameSegment.libSegment) -> True) : _ -> True - _ -> False +data NameLocation + = NameLocation'Local -- outside lib + | NameLocation'DirectDep -- inside lib, but outside lib.*.lib + | NameLocation'IndirectDep -- inside lib.*.lib + +classifyNameLocation :: Name -> NameLocation +classifyNameLocation name = + case segments name of + ((== NameSegment.libSegment) -> True) :| _ : ((== NameSegment.libSegment) -> True) : _ -> NameLocation'IndirectDep + ((== NameSegment.libSegment) -> True) :| _ -> NameLocation'DirectDep + _ -> NameLocation'Local + +data NamePriority a + = NamePriorityOne !a -- highest priority: local names and direct dep names + | NamePriorityTwo !a -- lowest priority: indirect dep names + deriving stock (Eq, Functor, Ord) + +instance (Monoid a) => Monoid (NamePriority a) where + mempty = NamePriorityTwo mempty + +instance (Semigroup a) => Semigroup (NamePriority a) where + NamePriorityOne x <> NamePriorityOne y = NamePriorityOne (x <> y) + NamePriorityOne x <> NamePriorityTwo _ = NamePriorityOne x + NamePriorityTwo _ <> NamePriorityOne y = NamePriorityOne y + NamePriorityTwo x <> NamePriorityTwo y = NamePriorityTwo (x <> y) + +unNamePriority :: NamePriority a -> a +unNamePriority = \case + NamePriorityOne x -> x + NamePriorityTwo x -> x + +nameLocationPriority :: NameLocation -> NamePriority () +nameLocationPriority = \case + NameLocation'Local -> NamePriorityOne () + NameLocation'DirectDep -> NamePriorityOne () + NameLocation'IndirectDep -> NamePriorityTwo () sortByText :: (a -> Text) -> [a] -> [a] sortByText by as = @@ -445,7 +486,7 @@ stripNamePrefix (Name p0 ss0) (Name p1 ss1) = do s : ss <- List.stripPrefix (reverse (toList ss0)) (reverse (toList ss1)) pure (Name Relative (List.NonEmpty.reverse (s :| ss))) --- | Return all relative suffixes of a name, in descending-length order. The returned list will always be non-empty. +-- | Return all relative suffixes of a name, in ascending-length order. The returned list will always be non-empty. -- -- >>> suffixes "a.b.c" -- ["a.b.c", "a.b", "c"] @@ -453,13 +494,7 @@ stripNamePrefix (Name p0 ss0) (Name p1 ss1) = do -- >>> suffixes ".a.b.c" -- ["a.b.c", "a.b", "c"] suffixes :: Name -> [Name] -suffixes = - reverse . suffixes' - --- Like `suffixes`, but returns names in ascending-length order. Currently unexported, as it's only used in the --- implementation of `shortestUniqueSuffix`. -suffixes' :: Name -> [Name] -suffixes' (Name _ ss0) = do +suffixes (Name _ ss0) = do ss <- List.NonEmpty.tail (List.NonEmpty.inits ss0) -- fromList is safe here because all elements of `tail . inits` are non-empty pure (Name Relative (List.NonEmpty.fromList ss)) @@ -506,28 +541,49 @@ unqualified :: Name -> Name unqualified (Name _ (s :| _)) = Name Relative (s :| []) --- Tries to shorten `fqn` to the smallest suffix that still unambiguously refers to the same name. Uses an efficient --- logarithmic lookup in the provided relation. +isUnqualified :: Name -> Bool +isUnqualified = \case + Name Relative (_ :| []) -> True + Name _ (_ :| _) -> False + +-- Tries to shorten `fqn` to the smallest suffix that still unambiguously refers to the same name. +-- +-- Indirect dependency names don't cause ambiguity in the presence of one or more non-indirect-dependency names. For +-- example, if there are two names "lib.base.List.map" and "lib.something.lib.base.Set.map", then "map" would +-- unambiguously refer to "lib.base.List.map". +-- +-- Uses an efficient logarithmic lookup in the provided relation. -- -- NB: Only works if the `Ord` instance for `Name` orders based on `Name.reverseSegments`. suffixifyByName :: forall r. (Ord r) => Name -> R.Relation Name r -> Name suffixifyByName fqn rel = - fromMaybe fqn (List.find isOk (suffixes' fqn)) + fromMaybe fqn (List.find isOk (suffixes fqn)) where isOk :: Name -> Bool isOk suffix = matchingNameCount == 1 where matchingNameCount :: Int matchingNameCount = - getSum (R.searchDomG (\_ _ -> Sum 1) (compareSuffix suffix) rel) + getSum (unNamePriority (R.searchDomG f (compareSuffix suffix) rel)) + where + f :: Name -> Set r -> NamePriority (Sum Int) + f name _refs = + case nameLocationPriority (classifyNameLocation name) of + NamePriorityOne () -> NamePriorityOne (Sum 1) + NamePriorityTwo () -> NamePriorityTwo (Sum 1) --- Tries to shorten `fqn` to the smallest suffix that still refers the same references. Uses an efficient logarithmic --- lookup in the provided relation. The returned `Name` may refer to multiple hashes if the original FQN did as well. +-- Tries to shorten `fqn` to the smallest suffix that still refers the same references. +-- +-- Like `suffixifyByName`, indirect dependency names don't cause ambiguity in the presence of one or more +-- non-indirect-dependency names. +-- +-- Uses an efficient logarithmic lookup in the provided relation. The returned `Name` may refer to multiple hashes if +-- the original FQN did as well. -- -- NB: Only works if the `Ord` instance for `Name` orders based on `Name.reverseSegments`. suffixifyByHash :: forall r. (Ord r) => Name -> R.Relation Name r -> Name suffixifyByHash fqn rel = - fromMaybe fqn (List.find isOk (suffixes' fqn)) + fromMaybe fqn (List.find isOk (suffixes fqn)) where allRefs :: Set r allRefs = @@ -535,11 +591,57 @@ suffixifyByHash fqn rel = isOk :: Name -> Bool isOk suffix = - Set.size refs == 1 || refs == allRefs + matchingRefs == allRefs where - refs :: Set r - refs = - R.searchDom (compareSuffix suffix) rel + matchingRefs :: Set r + matchingRefs = + unNamePriority (R.searchDomG f (compareSuffix suffix) rel) + where + f :: Name -> Set r -> NamePriority (Set r) + f name refs = + refs <$ nameLocationPriority (classifyNameLocation name) + +-- Like `suffixifyByHash`, but "keeps going" (i.e. keeps adding more segments, looking for the best name) if the current +-- suffix could refer to a local definition (i.e. outside lib). This is because such definitions could end up being +-- edited in a scratch file, where "suffixify by hash" doesn't work. +suffixifyByHashName :: forall r. (Ord r) => Name -> R.Relation Name r -> Name +suffixifyByHashName fqn rel = + fromMaybe fqn (List.find isOk (suffixes fqn)) + where + allRefs :: Set r + allRefs = + R.lookupDom fqn rel + + isOk :: Name -> Bool + isOk suffix = + matchingRefs == allRefs + -- Don't use a suffix of 2+ aliases if any of then are non-local names + && case numLocalNames of + 0 -> True + 1 -> numNonLocalNames == 0 + _ -> False + where + numLocalNames :: Int + numNonLocalNames :: Int + matchingRefs :: Set r + (getSum -> numLocalNames, getSum -> numNonLocalNames, unNamePriority -> matchingRefs) = + R.searchDomG f (compareSuffix suffix) rel + where + f :: Name -> Set r -> (Sum Int, Sum Int, NamePriority (Set r)) + f name refs = + (numLocal, numNonLocal, refs <$ nameLocationPriority location) + where + location = classifyNameLocation name + numLocal = + case location of + NameLocation'Local -> Sum 1 + NameLocation'DirectDep -> Sum 0 + NameLocation'IndirectDep -> Sum 0 + numNonLocal = + case location of + NameLocation'Local -> Sum 0 + NameLocation'DirectDep -> Sum 1 + NameLocation'IndirectDep -> Sum 1 -- | Returns the common prefix of two names as segments -- @@ -570,12 +672,3 @@ commonPrefix x@(Name p1 _) y@(Name p2 _) commonPrefix' (a : as) (b : bs) | a == b = a : commonPrefix' as bs commonPrefix' _ _ = [] - -class Convert a b where - convert :: a -> b - -class Parse a b where - parse :: a -> Maybe b - -instance (Parse a a2, Parse b b2) => Parse (a, b) (a2, b2) where - parse (a, b) = (,) <$> parse a <*> parse b diff --git a/unison-core/src/Unison/Name/Internal.hs b/unison-core/src/Unison/Name/Internal.hs index fcd855001e..4e00652456 100644 --- a/unison-core/src/Unison/Name/Internal.hs +++ b/unison-core/src/Unison/Name/Internal.hs @@ -21,20 +21,21 @@ import Unison.Position (Position (..)) import Unison.Prelude import Unison.Util.Alphabetical --- | A name is an absolute-or-relative non-empty list of name segments. +-- | A name is an absolute-or-relative non-empty list of name segments. It is used to represent the path to a +-- definition. +-- +-- A few example names: +-- +-- - "foo.bar" --> Name Relative ("bar" :| ["foo"]) +-- - ".foo.bar" --> Name Absolute ("bar" :| ["foo"]) +-- - "|>.<|" --> Name Relative ("<|" :| ["|>"]) +-- - "." --> Name Relative ("." :| []) +-- - ".." --> Name Absolute (".." :| []) data Name - = -- A few example names: - -- - -- "foo.bar" --> Name Relative ["bar", "foo"] - -- ".foo.bar" --> Name Absolute ["bar", "foo"] - -- "|>.<|" --> Name Relative ["<|", "|>"] - -- "." --> Name Relative ["."] - -- ".." --> Name Absolute ["."] - -- - Name - -- whether the name is positioned absolutely (to some arbitrary root namespace), or relatively + = Name + -- | whether the name is positioned absolutely (to some arbitrary root namespace), or relatively Position - -- the name segments in reverse order + -- | the name segments in reverse order (List.NonEmpty NameSegment) deriving stock (Eq, Generic, Show) @@ -48,10 +49,11 @@ instance Alphabetical Name where _ -> compareAlphabetical (segments n1) (segments n2) instance - TypeError - ( 'TypeError.Text - "You cannot make a Name from a string literal because there may (some day) be more than one syntax" - ) => + ( TypeError + ( 'TypeError.Text + "You cannot make a Name from a string literal because there may (some day) be more than one syntax" + ) + ) => IsString Name where fromString = undefined diff --git a/unison-core/src/Unison/Names.hs b/unison-core/src/Unison/Names.hs index b21b761927..d0613f1411 100644 --- a/unison-core/src/Unison/Names.hs +++ b/unison-core/src/Unison/Names.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} module Unison.Names @@ -12,6 +13,8 @@ module Unison.Names filterByHQs, filterBySHs, filterTypes, + fromReferenceIds, + fromUnconflictedReferenceIds, map, makeAbsolute, makeRelative, @@ -36,9 +39,9 @@ module Unison.Names typeReferences, termsNamed, typesNamed, - unionLeft, - unionLeftName, - unionLeftRef, + shadowing, + shadowing1, + preferring, namesForReference, namesForReferent, shadowTerms, @@ -49,28 +52,39 @@ module Unison.Names hashQualifyTypesRelation, hashQualifyTermsRelation, fromTermsAndTypes, + lenientToNametree, + resolveName, + resolveNameIncludingNames, ) where +import Control.Lens (_2) +import Data.List qualified as List import Data.Map qualified as Map +import Data.Semialign (alignWith) import Data.Set qualified as Set import Data.Text qualified as Text +import Data.These (These (..)) import Text.FuzzyFind qualified as FZF import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorType qualified as CT import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.LabeledDependency (LabeledDependency) import Unison.LabeledDependency qualified as LD import Unison.Name (Name) import Unison.Name qualified as Name +import Unison.NameSegment (NameSegment) +import Unison.Names.ResolvesTo (ResolvesTo (..)) import Unison.Prelude -import Unison.Reference (Reference, TermReference, TypeReference) +import Unison.Reference (Reference, TermReference, TermReferenceId, TypeReference, TypeReferenceId) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as SH +import Unison.Util.Defns (Defns (..), DefnsF) +import Unison.Util.Nametree (Nametree, unflattenNametree) import Unison.Util.Relation (Relation) import Unison.Util.Relation qualified as R import Unison.Util.Relation qualified as Relation @@ -85,7 +99,7 @@ data Names = Names { terms :: Relation Name Referent, types :: Relation Name TypeReference } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) instance Semigroup (Names) where Names e1 t1 <> Names e2 t2 = @@ -95,7 +109,23 @@ instance Monoid (Names) where mempty = Names mempty mempty isEmpty :: Names -> Bool -isEmpty n = R.null (terms n) && R.null (types n) +isEmpty n = R.null n.terms && R.null n.types + +-- | Construct a 'Names' from unconflicted reference ids. +fromReferenceIds :: DefnsF (Relation Name) TermReferenceId TypeReferenceId -> Names +fromReferenceIds defns = + Names + { terms = Relation.mapRan Referent.fromTermReferenceId defns.terms, + types = Relation.mapRan Reference.fromId defns.types + } + +-- | Construct a 'Names' from unconflicted reference ids. +fromUnconflictedReferenceIds :: DefnsF (Map Name) TermReferenceId TypeReferenceId -> Names +fromUnconflictedReferenceIds defns = + Names + { terms = Relation.fromMap (Map.map Referent.fromTermReferenceId defns.terms), + types = Relation.fromMap (Map.map Reference.fromId defns.types) + } map :: (Name -> Name) -> Names -> Names map f (Names {terms, types}) = Names terms' types' @@ -122,8 +152,8 @@ fuzzyFind nameToText query names = . Prelude.filter prefilter . Map.toList -- `mapMonotonic` is safe here and saves a log n factor - $ (Set.mapMonotonic Left <$> R.toMultimap (terms names)) - <> (Set.mapMonotonic Right <$> R.toMultimap (types names)) + $ (Set.mapMonotonic Left <$> R.toMultimap names.terms) + <> (Set.mapMonotonic Right <$> R.toMultimap names.types) where lowerqueryt = Text.toLower . Text.pack <$> query -- For performance, case-insensitive substring matching as a pre-filter @@ -181,86 +211,38 @@ restrictReferences refs Names {..} = Names terms' types' terms' = R.filterRan ((`Set.member` refs) . Referent.toReference) terms types' = R.filterRan (`Set.member` refs) types --- | Guide to unionLeft* --- Is it ok to create new aliases for parsing? --- Sure. +-- | Construct names from a left-biased map union of the domains of the input names. That is, for each distinct name, +-- if it refers to *any* references in the left argument, use those (ignoring the right). -- --- Is it ok to create name conflicts for parsing? --- It's okay but not great. The user will have to hash-qualify to disambiguate. +-- This is appropriate for shadowing names in the codebase with names in a Unison file, for instance: -- --- Is it ok to create new aliases for pretty-printing? --- Not helpful, we need to choose a name to show. --- We'll just have to choose one at random if there are aliases. --- Is it ok to create name conflicts for pretty-printing? --- Still okay but not great. The pretty-printer will have to hash-qualify --- to disambiguate. --- --- Thus, for parsing: --- unionLeftName is good if the name `n` on the left is the only `n` the --- user will want to reference. It allows the rhs to add aliases. --- unionLeftRef allows new conflicts but no new aliases. Lame? --- (<>) is ok for parsing if we expect to add some conflicted names, --- e.g. from history --- --- For pretty-printing: --- Probably don't want to add new aliases, unless we don't know which --- `Names` is higher priority. So if we do have a preferred `Names`, --- don't use `unionLeftName` or (<>). --- You don't want to create new conflicts either if you have a preferred --- `Names`. So in this case, don't use `unionLeftRef` either. --- I guess that leaves `unionLeft`. --- --- Not sure if the above is helpful or correct! - --- unionLeft two Names, including new aliases, but excluding new name conflicts. --- e.g. unionLeftName [foo -> #a, bar -> #a, cat -> #c] --- [foo -> #b, baz -> #c] --- = [foo -> #a, bar -> #a, baz -> #c, cat -> #c)] --- Btw, it's ok to create name conflicts for parsing environments, if you don't --- mind disambiguating. -unionLeftName :: Names -> Names -> Names -unionLeftName = unionLeft' $ const . R.memberDom - --- unionLeft two Names, including new name conflicts, but excluding new aliases. --- e.g. unionLeftRef [foo -> #a, bar -> #a, cat -> #c] --- [foo -> #b, baz -> #c] --- = [foo -> #a, bar -> #a, foo -> #b, cat -> #c] -unionLeftRef :: Names -> Names -> Names -unionLeftRef (Names priorityTerms priorityTypes) (Names fallbackTerms fallbackTypes) = - Names (restricter priorityTerms fallbackTerms) (restricter priorityTypes fallbackTypes) - where - restricter priorityRel fallbackRel = - let refsExclusiveToFallback = (Relation.ran fallbackRel) `Set.difference` (Relation.ran priorityRel) - in priorityRel <> Relation.restrictRan fallbackRel refsExclusiveToFallback - --- unionLeft two Names, but don't create new aliases or new name conflicts. --- e.g. unionLeft [foo -> #a, bar -> #a, cat -> #c] --- [foo -> #b, baz -> #c] --- = [foo -> #a, bar -> #a, cat -> #c] -unionLeft :: Names -> Names -> Names -unionLeft = unionLeft' go - where - go n r acc = R.memberDom n acc || R.memberRan r acc +-- @shadowing scratchFileNames codebaseNames@ +shadowing :: Names -> Names -> Names +shadowing a b = + Names (shadowing1 a.terms b.terms) (shadowing1 a.types b.types) --- implementation detail of the above -unionLeft' :: - (forall a b. (Ord a, Ord b) => a -> b -> Relation a b -> Bool) -> - Names -> - Names -> - Names -unionLeft' shouldOmit a b = Names terms' types' +shadowing1 :: (Ord a, Ord b) => Relation a b -> Relation a b -> Relation a b +shadowing1 = + Relation.unionDomainWith (\_ x _ -> x) + +-- | Construct names from a left-biased map union of the ranges of the input names. That is, for each distinct +-- reference, if it is referred to by *any* names in the left argument, use those (ignoring the right). +-- +-- This is appropriate for biasing a PPE towards picking names in the left argument. +preferring :: Names -> Names -> Names +preferring xs ys = + Names (preferring1 xs.terms ys.terms) (preferring1 xs.types ys.types) where - terms' = foldl' go (terms a) (R.toList $ terms b) - types' = foldl' go (types a) (R.toList $ types b) - go :: (Ord a, Ord b) => Relation a b -> (a, b) -> Relation a b - go acc (n, r) = if shouldOmit n r acc then acc else R.insert n r acc + preferring1 :: (Ord a, Ord b) => Relation a b -> Relation a b -> Relation a b + preferring1 = + Relation.unionRangeWith (\_ x _ -> x) -- | TODO: get this from database. For now it's a constant. numHashChars :: Int numHashChars = 3 termsNamed :: Names -> Name -> Set Referent -termsNamed = flip R.lookupDom . terms +termsNamed = flip R.lookupDom . (.terms) -- | Get all terms with a specific name. refTermsNamed :: Names -> Name -> Set TermReference @@ -281,13 +263,13 @@ refTermsHQNamed names = \case in Set.mapMaybe f (termsNamed names name) typesNamed :: Names -> Name -> Set TypeReference -typesNamed = flip R.lookupDom . types +typesNamed = flip R.lookupDom . (.types) namesForReferent :: Names -> Referent -> Set Name -namesForReferent names r = R.lookupRan r (terms names) +namesForReferent names r = R.lookupRan r names.terms namesForReference :: Names -> TypeReference -> Set Name -namesForReference names r = R.lookupRan r (types names) +namesForReference names r = R.lookupRan r names.types termAliases :: Names -> Name -> Referent -> Set Name termAliases names n r = Set.delete n $ namesForReferent names r @@ -422,20 +404,20 @@ filterTypes f (Names terms types) = Names terms (R.filterDom f types) difference :: Names -> Names -> Names difference a b = Names - (R.difference (terms a) (terms b)) - (R.difference (types a) (types b)) + (R.difference a.terms b.terms) + (R.difference a.types b.types) contains :: Names -> Reference -> Bool contains names = -- We want to compute `termsReferences` only once, if `contains` is partially applied to a `Names`, and called over -- and over for different references. GHC would probably float `termsReferences` out without the explicit lambda, but -- it's written like this just to be sure. - \r -> Set.member r termsReferences || R.memberRan r (types names) + \r -> Set.member r termsReferences || R.memberRan r names.types where -- this check makes `contains` O(n) instead of O(log n) termsReferences :: Set TermReference termsReferences = - Set.map Referent.toReference (R.ran (terms names)) + Set.map Referent.toReference (R.ran names.terms) -- | filters out everything from the domain except what's conflicted conflicts :: Names -> Names @@ -448,9 +430,9 @@ conflicts Names {..} = Names (R.filterManyDom terms) (R.filterManyDom types) -- See usage in `FileParser` for handling precendence of symbol -- resolution where local names are preferred to codebase names. shadowTerms :: [Name] -> Names -> Names -shadowTerms ns n0 = Names terms' (types n0) +shadowTerms ns n0 = Names terms' n0.types where - terms' = foldl' go (terms n0) ns + terms' = foldl' go n0.terms ns go ts name = R.deleteDom name ts -- | Given a mapping from name to qualified name, update a `Names`, @@ -461,8 +443,8 @@ shadowTerms ns n0 = Names terms' (types n0) importing :: [(Name, Name)] -> Names -> Names importing shortToLongName ns = Names - (foldl' go (terms ns) shortToLongName) - (foldl' go (types ns) shortToLongName) + (foldl' go ns.terms shortToLongName) + (foldl' go ns.types shortToLongName) where go :: (Ord r) => Relation Name r -> (Name, Name) -> Relation Name r go m (shortname, qname) = case Name.searchByRankedSuffix qname m of @@ -476,8 +458,8 @@ importing shortToLongName ns = -- `[(foo, io.foo), (bar, io.bar)]`. expandWildcardImport :: Name -> Names -> [(Name, Name)] expandWildcardImport prefix ns = - [(suffix, full) | Just (suffix, full) <- go <$> R.toList (terms ns)] - <> [(suffix, full) | Just (suffix, full) <- go <$> R.toList (types ns)] + [(suffix, full) | Just (suffix, full) <- go <$> R.toList ns.terms] + <> [(suffix, full) | Just (suffix, full) <- go <$> R.toList ns.types] where go :: (Name, a) -> Maybe (Name, Name) go (full, _) = do @@ -498,7 +480,7 @@ constructorsForType r ns = possibleDatas = [Referent.Con (ConstructorReference r cid) CT.Data | cid <- [0 ..]] possibleEffects = [Referent.Con (ConstructorReference r cid) CT.Effect | cid <- [0 ..]] trim [] = [] - trim (h : t) = case R.lookupRan h (terms ns) of + trim (h : t) = case R.lookupRan h ns.terms of s | Set.null s -> [] | otherwise -> [(n, h) | n <- toList s] ++ trim t @@ -517,3 +499,89 @@ hashQualifyRelation fromNamedRef rel = R.map go rel if Set.size (R.lookupDom n rel) > 1 then (HQ.take numHashChars $ fromNamedRef n r, r) else (HQ.NameOnly n, r) + +-- | "Leniently" view a Names as a NameTree +-- +-- This function is "lenient" in the sense that it does not handle conflicted names with any smarts whatsoever. The +-- resulting nametree will simply contain one of the associated references of a conflicted name - we don't specify +-- which. +lenientToNametree :: Names -> Nametree (DefnsF (Map NameSegment) Referent TypeReference) +lenientToNametree names = + alignWith + ( \case + This terms -> Defns {terms, types = Map.empty} + That types -> Defns {terms = Map.empty, types} + These terms types -> Defns {terms, types} + ) + (lenientRelationToNametree names.terms) + (lenientRelationToNametree names.types) + where + lenientRelationToNametree :: (Ord a) => Relation Name a -> Nametree (Map NameSegment a) + lenientRelationToNametree = + -- The partial `Set.findMin` is fine here because Relation.domain only has non-empty Set values. A NESet would be + -- better. + unflattenNametree . Map.map Set.findMin . Relation.domain + +-- Given a namespace and locally-bound names that shadow it (i.e. from a Unison file that hasn't been typechecked yet), +-- determine what the name resolves to, per the usual suffix-matching rules (where local defnintions and direct +-- dependencies are preferred to indirect dependencies). +resolveName :: forall ref. (Ord ref, Show ref) => Relation Name ref -> Set Name -> Name -> Set (ResolvesTo ref) +resolveName namespace locals = + \name -> + let exactNamespaceMatches :: Set ref + exactNamespaceMatches = + Relation.lookupDom name namespace + localsPlusNamespaceSuffixMatches :: Set (ResolvesTo ref) + localsPlusNamespaceSuffixMatches = + Name.searchByRankedSuffix name localsPlusNamespace + in if + | Set.member name locals -> Set.singleton (ResolvesToLocal name) + | Set.size exactNamespaceMatches == 1 -> Set.mapMonotonic ResolvesToNamespace exactNamespaceMatches + | otherwise -> localsPlusNamespaceSuffixMatches + where + localsPlusNamespace :: Relation Name (ResolvesTo ref) + localsPlusNamespace = + shadowing1 + ( List.foldl' + (\acc name -> Relation.insert name (ResolvesToLocal name) acc) + Relation.empty + (Set.toList locals) + ) + ( Relation.map + (over _2 ResolvesToNamespace) + namespace + ) + +-- | Like 'resolveName', but include the names in the output. +resolveNameIncludingNames :: + forall ref. + (Ord ref, Show ref) => + Relation Name ref -> + Set Name -> + Name -> + Relation Name (ResolvesTo ref) +resolveNameIncludingNames namespace locals = + \name -> + let exactNamespaceMatches :: Set ref + exactNamespaceMatches = + Relation.lookupDom name namespace + localsPlusNamespaceSuffixMatches :: Relation Name (ResolvesTo ref) + localsPlusNamespaceSuffixMatches = + Name.filterByRankedSuffix name localsPlusNamespace + in if + | Set.member name locals -> Relation.singleton name (ResolvesToLocal name) + | Set.size exactNamespaceMatches == 1 -> Relation.singleton name (ResolvesToNamespace (Set.findMin exactNamespaceMatches)) + | otherwise -> localsPlusNamespaceSuffixMatches + where + localsPlusNamespace :: Relation Name (ResolvesTo ref) + localsPlusNamespace = + shadowing1 + ( List.foldl' + (\acc name -> Relation.insert name (ResolvesToLocal name) acc) + Relation.empty + (Set.toList locals) + ) + ( Relation.map + (over _2 ResolvesToNamespace) + namespace + ) diff --git a/unison-core/src/Unison/Names/ResolutionResult.hs b/unison-core/src/Unison/Names/ResolutionResult.hs index e86bf2ac0b..081e3b5eae 100644 --- a/unison-core/src/Unison/Names/ResolutionResult.hs +++ b/unison-core/src/Unison/Names/ResolutionResult.hs @@ -1,32 +1,39 @@ -module Unison.Names.ResolutionResult where +module Unison.Names.ResolutionResult + ( ResolutionError (..), + ResolutionFailure (..), + ResolutionResult, + getAnnotation, + ) +where -import Data.Set.NonEmpty +import Unison.HashQualified (HashQualified) +import Unison.Name (Name) import Unison.Names (Names) import Unison.Prelude -import Unison.Reference as Reference (Reference) -import Unison.Referent as Referent (Referent) +import Unison.Reference (TypeReference) +import Unison.Referent (Referent) data ResolutionError ref = NotFound - | -- Contains the names which were in scope and which refs were possible options - -- The NonEmpty set of refs must contain 2 or more refs (otherwise what is ambiguous?). - Ambiguous Names (NESet ref) + | -- Contains: + -- + -- 1. The namespace names + -- 2. The refs among those that we could be referring to + -- 3. The local names that we could be referring to + -- + -- The size of set (2.) + the size of set (3.) is at least 2 (otherwise there wouldn't be any ambiguity). + Ambiguous Names (Set ref) (Set Name) deriving (Eq, Ord, Show) --- | ResolutionFailure represents the failure to resolve a given variable. -data ResolutionFailure var annotation - = TypeResolutionFailure var annotation (ResolutionError Reference) - | TermResolutionFailure var annotation (ResolutionError Referent) +-- | ResolutionFailure represents the failure to resolve a given name. +data ResolutionFailure annotation + = TypeResolutionFailure (HashQualified Name) annotation (ResolutionError TypeReference) + | TermResolutionFailure (HashQualified Name) annotation (ResolutionError Referent) deriving (Eq, Ord, Show, Functor, Foldable, Traversable) -getAnnotation :: ResolutionFailure v a -> a +getAnnotation :: ResolutionFailure a -> a getAnnotation = \case TypeResolutionFailure _ a _ -> a TermResolutionFailure _ a _ -> a -getVar :: ResolutionFailure v a -> v -getVar = \case - TypeResolutionFailure v _ _ -> v - TermResolutionFailure v _ _ -> v - -type ResolutionResult v a r = Either (Seq (ResolutionFailure v a)) r +type ResolutionResult a r = Either (Seq (ResolutionFailure a)) r diff --git a/unison-core/src/Unison/Names/ResolvesTo.hs b/unison-core/src/Unison/Names/ResolvesTo.hs new file mode 100644 index 0000000000..378b4af486 --- /dev/null +++ b/unison-core/src/Unison/Names/ResolvesTo.hs @@ -0,0 +1,21 @@ +module Unison.Names.ResolvesTo + ( ResolvesTo (..), + partitionResolutions, + ) +where + +import Unison.Name (Name) +import Unison.Prelude + +data ResolvesTo ref + = ResolvesToNamespace ref + | ResolvesToLocal Name + deriving stock (Eq, Ord, Show) + +partitionResolutions :: [(v, ResolvesTo ref)] -> ([(v, ref)], [(v, Name)]) +partitionResolutions = + partitionEithers . map f + where + f = \case + (v, ResolvesToNamespace ref) -> Left (v, ref) + (v, ResolvesToLocal name) -> Right (v, name) diff --git a/unison-core/src/Unison/NamesWithHistory.hs b/unison-core/src/Unison/NamesWithHistory.hs index 5ba7ea72fa..4ec19c2788 100644 --- a/unison-core/src/Unison/NamesWithHistory.hs +++ b/unison-core/src/Unison/NamesWithHistory.hs @@ -6,7 +6,6 @@ module Unison.NamesWithHistory ( diff, push, - shadowing, lookupHQType, lookupHQType', lookupHQTerm, @@ -34,7 +33,7 @@ import Unison.ConstructorReference (ConstructorReference) import Unison.ConstructorType qualified as CT import Unison.HashQualified (HashQualified) import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.Names (Names (..)) @@ -104,16 +103,10 @@ push n0 ns = unionLeft0 n1 ns uniqueTerms = [(n, ref) | (n, nubOrd -> [ref]) <- Map.toList terms'] uniqueTypes = [(n, ref) | (n, nubOrd -> [ref]) <- Map.toList types'] --- | Prefer names in the first argument, falling back to names in the second. --- This can be used to shadow names in the codebase with names in a unison file for instance: --- e.g. @shadowing scratchFileNames codebaseNames@ -shadowing :: Names -> Names -> Names -shadowing = Names.unionLeft - -- Find all types whose name has a suffix matching the provided `HashQualified`, -- returning types with relative names if they exist, and otherwise -- returning types with absolute names. -lookupRelativeHQType :: SearchType -> HashQualified Name -> Names -> Set Reference +lookupRelativeHQType :: SearchType -> HashQualified Name -> Names -> Set TypeReference lookupRelativeHQType searchType hq ns = let rs = lookupHQType searchType hq ns keep r = any (not . Name.isAbsolute) (R.lookupRan r (Names.types ns)) @@ -122,17 +115,17 @@ lookupRelativeHQType searchType hq ns = | Set.null rs' -> rs | otherwise -> rs' -lookupRelativeHQType' :: SearchType -> HQ'.HashQualified Name -> Names -> Set Reference +lookupRelativeHQType' :: SearchType -> HQ'.HashQualified Name -> Names -> Set TypeReference lookupRelativeHQType' searchType = lookupRelativeHQType searchType . HQ'.toHQ -- | Find all types whose name has a suffix matching the provided 'HashQualified'. -lookupHQType :: SearchType -> HashQualified Name -> Names -> Set Reference +lookupHQType :: SearchType -> HashQualified Name -> Names -> Set TypeReference lookupHQType searchType = lookupHQRef searchType Names.types Reference.isPrefixOf -- | Find all types whose name has a suffix matching the provided 'HashQualified''. See 'lookupHQType'. -lookupHQType' :: SearchType -> HQ'.HashQualified Name -> Names -> Set Reference +lookupHQType' :: SearchType -> HQ'.HashQualified Name -> Names -> Set TypeReference lookupHQType' searchType = lookupHQType searchType . HQ'.toHQ @@ -225,7 +218,7 @@ longestTermName :: Int -> Referent -> Names -> HQ.HashQualified Name longestTermName length r ns = case reverse (termNamesByLength length r ns) of [] -> HQ.take length (HQ.fromReferent r) - (h : _) -> Name.convert h + (h : _) -> HQ'.toHQ h termName :: Int -> Referent -> Names -> Set (HQ'.HashQualified Name) termName length r names = @@ -236,10 +229,6 @@ termName length r names = hq n = HQ'.take length (HQ'.fromNamedReferent n r) isConflicted n = R.manyDom n (Names.terms names) --- Set HashQualified -> Branch m -> Action' m v Names --- Set HashQualified -> Branch m -> Free (Command m i v) Names --- Set HashQualified -> Branch m -> Command m i v Names --- populate historical names lookupHQPattern :: SearchType -> HQ.HashQualified Name -> diff --git a/unison-core/src/Unison/Project.hs b/unison-core/src/Unison/Project.hs index 77a96a448a..73070e7a1d 100644 --- a/unison-core/src/Unison/Project.hs +++ b/unison-core/src/Unison/Project.hs @@ -17,6 +17,7 @@ module Unison.Project ProjectBranchSpecifier (..), ProjectAndBranch (..), projectAndBranchNamesParser, + fullyQualifiedProjectAndBranchNamesParser, projectAndOptionalBranchParser, branchWithOptionalProjectParser, ProjectAndBranchNames (..), @@ -414,6 +415,20 @@ projectAndBranchNamesParser specifier = do Just branch -> These project branch else pure (This project) +-- | Parse a fully specified myproject/mybranch name. +-- +-- >>> import Text.Megaparsec (parseMaybe) +-- >>> parseMaybe fullyQualifiedProjectAndBranchNamesParser ("myproject/mybranch" :: Text) +-- Just (ProjectAndBranch {project = UnsafeProjectName "myproject", branch = UnsafeProjectBranchName "mybranch"}) +fullyQualifiedProjectAndBranchNamesParser :: Megaparsec.Parsec Void Text (ProjectAndBranch ProjectName ProjectBranchName) +fullyQualifiedProjectAndBranchNamesParser = do + (project, hadSlash) <- projectNameParser + if hadSlash + then pure () + else void $ Megaparsec.char '/' + branch <- projectBranchNameParser False + pure (ProjectAndBranch project branch) + -- | @project/branch@ syntax, where the branch is optional. instance From (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) Text where from = \case diff --git a/unison-core/src/Unison/Referent'.hs b/unison-core/src/Unison/Referent'.hs deleted file mode 100644 index b65b75e09d..0000000000 --- a/unison-core/src/Unison/Referent'.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} - -module Unison.Referent' - ( Referent' (..), - - -- * Basic queries - isConstructor, - Unison.Referent'.fold, - - -- * Lenses - reference_, - - -- * Conversions - toReference', - toTermReference, - toTypeReference, - ) -where - -import Control.Lens (Lens, lens) -import Unison.ConstructorReference (GConstructorReference (..)) -import Unison.ConstructorType (ConstructorType) -import Unison.DataDeclaration.ConstructorId (ConstructorId) -import Unison.Prelude - --- | Specifies a term. --- --- Either a term 'Reference', a data constructor, or an effect constructor. --- --- Slightly odd naming. This is the "referent of term name in the codebase", --- rather than the target of a Reference. - --- | When @Ref'@ then @r@ represents a term. --- --- When @Con'@ then @r@ is a type declaration. -data Referent' r = Ref' r | Con' (GConstructorReference r) ConstructorType - deriving (Show, Eq, Ord, Functor, Generic) - --- | A lens onto the reference in a referent. -reference_ :: Lens (Referent' r) (Referent' r') r r' -reference_ = - lens toReference' \rt rc -> - case rt of - Ref' _ -> Ref' rc - Con' (ConstructorReference _ cid) ct -> Con' (ConstructorReference rc cid) ct - -isConstructor :: Referent' r -> Bool -isConstructor Con' {} = True -isConstructor _ = False - -toTermReference :: Referent' r -> Maybe r -toTermReference = \case - Ref' r -> Just r - _ -> Nothing - -toReference' :: Referent' r -> r -toReference' = \case - Ref' r -> r - Con' (ConstructorReference r _i) _t -> r - -toTypeReference :: Referent' r -> Maybe r -toTypeReference = \case - Con' (ConstructorReference r _i) _t -> Just r - _ -> Nothing - -fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a -fold fr fc = \case - Ref' r -> fr r - Con' (ConstructorReference r i) ct -> fc r i ct diff --git a/unison-core/src/Unison/Referent.hs b/unison-core/src/Unison/Referent.hs index d04454ea17..bf89ed878f 100644 --- a/unison-core/src/Unison/Referent.hs +++ b/unison-core/src/Unison/Referent.hs @@ -12,6 +12,8 @@ module Unison.Referent toId, toReference, toReferenceId, + toConstructorReference, + toConstructorReferenceId, toTermReference, toTermReferenceId, fromId, @@ -41,7 +43,7 @@ import Unison.Prelude hiding (fold) import Unison.Reference (Reference, TermReference, TermReferenceId) import Unison.Reference qualified as R import Unison.Reference qualified as Reference -import Unison.Referent' (Referent' (..), reference_, toReference') +import Unison.ReferentPrime (Referent' (..), reference_, toReference') import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as SH @@ -119,7 +121,16 @@ toReference = toReference' toReferenceId :: Referent -> Maybe Reference.Id toReferenceId = Reference.toId . toReference -toTermReference :: Referent -> Maybe TermReference +toConstructorReference :: Referent' r -> Maybe (GConstructorReference r) +toConstructorReference = \case + Con' r _ -> Just r + Ref' _ -> Nothing + +toConstructorReferenceId :: Referent -> Maybe ConstructorReferenceId +toConstructorReferenceId = + toConstructorReference >=> ConstructorReference.toId + +toTermReference :: Referent' r -> Maybe r toTermReference = \case Con' _ _ -> Nothing Ref' reference -> Just reference @@ -129,7 +140,7 @@ toTermReferenceId r = toTermReference r >>= Reference.toId -- | Inject a Term Reference into a Referent fromTermReference :: TermReference -> Referent -fromTermReference r = Ref r +fromTermReference = Ref fromTermReferenceId :: TermReferenceId -> Referent fromTermReferenceId = fromTermReference . Reference.fromId diff --git a/unison-core/src/Unison/ReferentPrime.hs b/unison-core/src/Unison/ReferentPrime.hs new file mode 100644 index 0000000000..a51aff374f --- /dev/null +++ b/unison-core/src/Unison/ReferentPrime.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.ReferentPrime + ( Referent' (..), + + -- * Basic queries + isConstructor, + Unison.ReferentPrime.fold, + + -- * Lenses + reference_, + + -- * Conversions + toReference', + toTermReference, + toTypeReference, + ) +where + +import Control.Lens (Lens, lens) +import Unison.ConstructorReference (GConstructorReference (..)) +import Unison.ConstructorType (ConstructorType) +import Unison.DataDeclaration.ConstructorId (ConstructorId) +import Unison.Prelude + +-- | Specifies a term. +-- +-- Either a term 'Reference', a data constructor, or an effect constructor. +-- +-- Slightly odd naming. This is the "referent of term name in the codebase", +-- rather than the target of a Reference. + +-- | When @Ref'@ then @r@ represents a term. +-- +-- When @Con'@ then @r@ is a type declaration. +data Referent' r = Ref' r | Con' (GConstructorReference r) ConstructorType + deriving (Show, Eq, Ord, Functor, Generic) + +-- | A lens onto the reference in a referent. +reference_ :: Lens (Referent' r) (Referent' r') r r' +reference_ = + lens toReference' \rt rc -> + case rt of + Ref' _ -> Ref' rc + Con' (ConstructorReference _ cid) ct -> Con' (ConstructorReference rc cid) ct + +isConstructor :: Referent' r -> Bool +isConstructor Con' {} = True +isConstructor _ = False + +toTermReference :: Referent' r -> Maybe r +toTermReference = \case + Ref' r -> Just r + _ -> Nothing + +toReference' :: Referent' r -> r +toReference' = \case + Ref' r -> r + Con' (ConstructorReference r _i) _t -> r + +toTypeReference :: Referent' r -> Maybe r +toTypeReference = \case + Con' (ConstructorReference r _i) _t -> Just r + _ -> Nothing + +fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a +fold fr fc = \case + Ref' r -> fr r + Con' (ConstructorReference r i) ct -> fc r i ct diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index acde4533fb..a6ce6bb7fc 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -8,33 +8,38 @@ import Control.Monad.State (evalState) import Control.Monad.State qualified as State import Control.Monad.Writer.Strict qualified as Writer import Data.Generics.Sum (_Ctor) +import Data.List qualified as List import Data.Map qualified as Map +import Data.Sequence qualified as Seq import Data.Sequence qualified as Sequence import Data.Set qualified as Set -import Data.Set.NonEmpty qualified as NES import Data.Text qualified as Text import Text.Show import Unison.ABT qualified as ABT import Unison.Blank qualified as B import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) +import Unison.ConstructorReference qualified as ConstructorReference import Unison.ConstructorType qualified as CT import Unison.DataDeclaration.ConstructorId (ConstructorId) +import Unison.HashQualified qualified as HQ import Unison.LabeledDependency (LabeledDependency) import Unison.LabeledDependency qualified as LD import Unison.Name qualified as Name import Unison.Names (Names) import Unison.Names qualified as Names import Unison.Names.ResolutionResult qualified as Names +import Unison.Names.ResolvesTo (ResolvesTo (..), partitionResolutions) import Unison.NamesWithHistory qualified as Names import Unison.Pattern (Pattern) import Unison.Pattern qualified as Pattern import Unison.Prelude -import Unison.Reference (Reference, TermReference, pattern Builtin) +import Unison.Reference (Reference, TermReference, TypeReference, pattern Builtin) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Type (Type) import Unison.Type qualified as Type +import Unison.Util.Defns (Defns (..), DefnsF) import Unison.Util.List (multimap, validate) import Unison.Var (Var) import Unison.Var qualified as Var @@ -146,69 +151,56 @@ bindNames :: forall v a. (Var v) => (v -> Name.Name) -> + (Name.Name -> v) -> Set v -> Names -> Term v a -> - Names.ResolutionResult v a (Term v a) -bindNames unsafeVarToName keepFreeTerms ns e = do - let freeTmVars = [(v, a) | (v, a) <- ABT.freeVarOccurrences keepFreeTerms e] - -- !_ = trace "bindNames.free term vars: " () - -- !_ = traceShow $ fst <$> freeTmVars - freeTyVars = - [ (v, a) | (v, as) <- Map.toList (freeTypeVarAnnotations e), a <- as - ] - -- !_ = trace "bindNames.free type vars: " () - -- !_ = traceShow $ fst <$> freeTyVars - okTm :: (v, a) -> Names.ResolutionResult v a (v, Term v a) - okTm (v, a) = case Names.lookupHQTerm Names.IncludeSuffixes (Name.convert $ unsafeVarToName v) ns of - rs - | Set.size rs == 1 -> - pure (v, fromReferent a $ Set.findMin rs) - | otherwise -> case NES.nonEmptySet rs of - Nothing -> Left (pure (Names.TermResolutionFailure v a Names.NotFound)) - Just refs -> Left (pure (Names.TermResolutionFailure v a (Names.Ambiguous ns refs))) - okTy (v, a) = case Names.lookupHQType Names.IncludeSuffixes (Name.convert $ unsafeVarToName v) ns of - rs - | Set.size rs == 1 -> pure (v, Type.ref a $ Set.findMin rs) - | otherwise -> case NES.nonEmptySet rs of - Nothing -> Left (pure (Names.TypeResolutionFailure v a Names.NotFound)) - Just refs -> Left (pure (Names.TypeResolutionFailure v a (Names.Ambiguous ns refs))) - termSubsts <- validate okTm freeTmVars - typeSubsts <- validate okTy freeTyVars - pure . substTypeVars typeSubsts . ABT.substsInheritAnnotation termSubsts $ e - --- This function replaces free term and type variables with --- hashes found in the provided `Names`, using suffix-based --- lookup. Any terms not found in the `Names` are kept free. -bindSomeNames :: - forall v a. - (Var v) => - (v -> Name.Name) -> - Set v -> - Names -> - Term v a -> - Names.ResolutionResult v a (Term v a) --- bindSomeNames ns e | trace "Term.bindSome" False --- || trace "Names =" False --- || traceShow ns False --- || trace "Free type vars:" False --- || traceShow (freeTypeVars e) False --- || trace "Free term vars:" False --- || traceShow (freeVars e) False --- || traceShow e False --- = undefined -bindSomeNames unsafeVarToName avoid ns e = bindNames unsafeVarToName (avoid <> varsToTDNR) ns e + Names.ResolutionResult a (Term v a) +bindNames unsafeVarToName nameToVar localVars namespace = + -- term is bound here because the where-clause binds a data structure that we only want to compute once, then share + -- across all calls to `bindNames` with different terms + \term -> do + let freeTmVars = ABT.freeVarOccurrences localVars term + freeTyVars = + [ (v, a) | (v, as) <- Map.toList (freeTypeVarAnnotations term), a <- as + ] + + okTm :: (v, a) -> Maybe (v, ResolvesTo Referent) + okTm (v, _) = + case Set.size matches of + 1 -> Just (v, Set.findMin matches) + 0 -> Nothing -- not found: leave free for telling user about expected type + _ -> Nothing -- ambiguous: leave free for TDNR + where + matches :: Set (ResolvesTo Referent) + matches = + resolveTermName (unsafeVarToName v) + + okTy :: (v, a) -> Names.ResolutionResult a (v, Type v a) + okTy (v, a) = + case Names.lookupHQType Names.IncludeSuffixes hqName namespace of + rs + | Set.size rs == 1 -> pure (v, Type.ref a $ Set.findMin rs) + | Set.size rs == 0 -> Left (Seq.singleton (Names.TypeResolutionFailure hqName a Names.NotFound)) + | otherwise -> Left (Seq.singleton (Names.TypeResolutionFailure hqName a (Names.Ambiguous namespace rs Set.empty))) + where + hqName = HQ.NameOnly (unsafeVarToName v) + + let (namespaceTermResolutions, localTermResolutions) = + partitionResolutions (mapMaybe okTm freeTmVars) + + termSubsts = + [(v, fromReferent () ref) | (v, ref) <- namespaceTermResolutions] + ++ [(v, var () (nameToVar name)) | (v, name) <- localTermResolutions] + typeSubsts <- validate okTy freeTyVars + pure $ + term + & ABT.substsInheritAnnotation termSubsts + & substTypeVars typeSubsts where - -- `Term.bindNames` takes a set of variables that are not substituted. - -- These should be the variables that will be subject to TDNR, which - -- we compute as the set of variables whose names cannot be found in `ns`. - -- - -- This allows TDNR to disambiguate those names (if multiple definitions - -- share the same suffix) or to report the type expected for that name - -- (if a free variable is being used as a typed hole). - varsToTDNR = Set.filter notFound (freeVars e) - notFound var = - Set.size (Name.searchByRankedSuffix (unsafeVarToName var) (Names.terms ns)) /= 1 + resolveTermName :: Name.Name -> Set (ResolvesTo Referent) + resolveTermName = + Names.resolveName (Names.terms namespace) (Set.map unsafeVarToName localVars) -- Prepare a term for type-directed name resolution by replacing -- any remaining free variables with blanks to be resolved by TDNR @@ -396,7 +388,7 @@ substTypeVar vt ty = go Set.empty t2 = ABT.bindInheritAnnotation body (Type.var () v2) in uncapture ((ABT.annotation t, v2) : vs) (renameTypeVar v v2 e) t2 uncapture vs e t0 = - let t = foldl (\body (loc, v) -> Type.forall loc v body) t0 vs + let t = foldl (\body (loc, v) -> Type.forAll loc v body) t0 vs bound' = case Type.unForalls (Type.stripIntroOuters t) of Nothing -> bound Just (vs, _) -> bound <> Set.fromList vs @@ -598,6 +590,13 @@ pattern BinaryAppsPred' :: (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) pattern BinaryAppsPred' apps lastArg <- (unBinaryAppsPred -> Just (apps, lastArg)) +pattern BinaryAppPred' :: + Term2 vt at ap v a -> + Term2 vt at ap v a -> + Term2 vt at ap v a -> + (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) +pattern BinaryAppPred' f arg1 arg2 <- (unBinaryAppPred -> Just (f, arg1, arg2)) + pattern OverappliedBinaryAppPred' :: Term2 vt at ap v a -> Term2 vt at ap v a -> @@ -721,6 +720,15 @@ pattern LetRecTop' :: Term2 vt at ap v a pattern LetRecTop' top subst <- (unLetRec -> Just (top, subst)) +pattern LetRecAnnotatedTop' :: + (Monad m, Var v) => + IsTop -> + ( (v -> m v) -> + m ([((a, v), Term2 vt at ap v a)], Term2 vt at ap v a) + ) -> + Term2 vt at ap v a +pattern LetRecAnnotatedTop' top subst <- (unLetRecAnnotated -> Just (top, subst)) + pattern LetRecNamedAnnotated' :: a -> [((a, v), Term' vt v a)] -> Term' vt v a -> Term' vt v a pattern LetRecNamedAnnotated' ann bs e <- (unLetRecNamedAnnotated -> Just (_, ann, bs, e)) @@ -865,20 +873,40 @@ ann :: Term2 vt at ap v a ann a e t = ABT.tm' a (Ann e t) --- arya: are we sure we want the two annotations to be the same? -lam :: (Ord v) => a -> v -> Term2 vt at ap v a -> Term2 vt at ap v a -lam a v body = ABT.tm' a (Lam (ABT.abs' a v body)) +-- | Add a lambda with a single argument. +lam :: + (Ord v) => + -- | Annotation of the whole lambda + a -> + -- Annotation of just the arg binding + (a, v) -> + Term2 vt at ap v a -> + Term2 vt at ap v a +lam spanAnn (bindingAnn, v) body = ABT.tm' spanAnn (Lam (ABT.abs' bindingAnn v body)) + +-- | Add a lambda with a list of arguments. +lam' :: + (Ord v) => + -- | Annotation of the whole lambda + a -> + [(a {- Annotation of the arg binding -}, v)] -> + Term2 vt at ap v a -> + Term2 vt at ap v a +lam' a vs body = foldr (lam a) body vs + +-- | Only use this variant if you don't have source annotations for the binding arguments available. +lamWithoutBindingAnns :: + (Ord v) => + a -> + [v] -> + Term2 vt at ap v a -> + Term2 vt at ap v a +lamWithoutBindingAnns a vs body = lam' a ((a,) <$> vs) body delay :: (Var v) => a -> Term2 vt at ap v a -> Term2 vt at ap v a delay a body = ABT.tm' a (Lam (ABT.abs' a (ABT.freshIn (ABT.freeVars body) (Var.typed Var.Delay)) body)) -lam' :: (Ord v) => a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a -lam' a vs body = foldr (lam a) body vs - -lam'' :: (Ord v) => [(a, v)] -> Term2 vt at ap v a -> Term2 vt at ap v a -lam'' vs body = foldr (uncurry lam) body vs - isLam :: Term2 vt at ap v a -> Bool isLam t = arity t > 0 @@ -888,13 +916,34 @@ arity (Ann' e _) = arity e arity _ = 0 unLetRecNamedAnnotated :: - Term' vt v a -> + Term2 vt at ap v a -> Maybe - (IsTop, a, [((a, v), Term' vt v a)], Term' vt v a) + (IsTop, a, [((a, v), Term2 vt at ap v a)], Term2 vt at ap v a) unLetRecNamedAnnotated (ABT.CycleA' ann avs (ABT.Tm' (LetRec isTop bs e))) = Just (isTop, ann, avs `zip` bs, e) unLetRecNamedAnnotated _ = Nothing +unLetRecAnnotated :: + (Monad m, Var v) => + Term2 vt at ap v a -> + Maybe + ( IsTop, + (v -> m v) -> + m + ( [((a, v), Term2 vt at ap v a)], + Term2 vt at ap v a + ) + ) +unLetRecAnnotated (unLetRecNamedAnnotated -> Just (isTop, _a, bs, e)) = + Just + ( isTop, + \freshen -> do + vs <- sequence [(a,) <$> freshen v | ((a, v), _) <- bs] + let sub = ABT.substsInheritAnnotation (map (snd . fst) bs `zip` map (ABT.var . snd) vs) + pure (vs `zip` [sub b | (_, b) <- bs], sub e) + ) +unLetRecAnnotated _ = Nothing + letRec' :: (Ord v, Monoid a) => Bool -> @@ -946,7 +995,7 @@ letRec isTop blockAnn bindings e = (foldr addAbs body bindings) where addAbs :: ((a, v), b) -> ABT.Term f v a -> ABT.Term f v a - addAbs ((_a, v), _b) t = ABT.abs' blockAnn v t + addAbs ((a, v), _b) t = ABT.abs' a v t body :: Term' vt v a body = ABT.tm' blockAnn (LetRec isTop (map snd bindings) e) @@ -977,7 +1026,7 @@ let1 :: Term2 vt at ap v a let1 isTop bindings e = foldr f e bindings where - f ((ann, v), b) body = ABT.tm' (ann <> ABT.annotation body) (Let isTop b (ABT.abs' (ABT.annotation body) v body)) + f ((ann, v), b) body = ABT.tm' (ann <> ABT.annotation body) (Let isTop b (ABT.abs' ann v body)) let1' :: (Semigroup a, Ord v) => @@ -996,12 +1045,14 @@ let1' isTop bindings e = foldr f e bindings singleLet :: (Ord v) => IsTop -> - -- Annotation spanning the whole let-binding + -- Annotation spanning the let-binding and its body + a -> + -- Annotation for just the binding, not the body it's used in. a -> (v, Term2 vt at ap v a) -> Term2 vt at ap v a -> Term2 vt at ap v a -singleLet isTop a (v, body) e = ABT.tm' a (Let isTop body (ABT.abs' a v e)) +singleLet isTop spanAnn absAnn (v, body) e = ABT.tm' spanAnn (Let isTop body (ABT.abs' absAnn v e)) -- let1' :: Var v => [(Text, Term0 vt v)] -> Term0 vt v -> Term0 vt v -- let1' bs e = let1 [(ABT.v' name, b) | (name,b) <- bs ] e @@ -1142,12 +1193,23 @@ unBinaryAppsPred :: ], Term2 vt at ap v a ) -unBinaryAppsPred (t, pred) = case unBinaryApp t of - Just (f, x, y) | pred f -> case unBinaryAppsPred (x, pred) of +unBinaryAppsPred (t, pred) = case unBinaryAppPred (t, pred) of + Just (f, x, y) -> case unBinaryAppsPred (x, pred) of Just (as, xLast) -> Just ((xLast, f) : as, y) Nothing -> Just ([(x, f)], y) _ -> Nothing +unBinaryAppPred :: + (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) -> + Maybe + ( Term2 vt at ap v a, + Term2 vt at ap v a, + Term2 vt at ap v a + ) +unBinaryAppPred (t, pred) = case unBinaryApp t of + Just (f, x, y) | pred f -> Just (f, x, y) + _ -> Nothing + unLams' :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) unLams' t = unLamsPred' (t, const True) @@ -1188,27 +1250,27 @@ unReqOrCtor (Request' r) = Just r unReqOrCtor _ = Nothing -- Dependencies including referenced data and effect decls -dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference -dependencies t = Set.map (LD.fold id Referent.toReference) (labeledDependencies t) +dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> DefnsF Set TermReference TypeReference +dependencies = + List.foldl' f (Defns Set.empty Set.empty) . Set.toList . labeledDependencies + where + f :: + DefnsF Set TermReference TypeReference -> + LabeledDependency -> + DefnsF Set TermReference TypeReference + f deps = \case + LD.TermReferent (Referent.Con ref _) -> deps & over #types (Set.insert (ref ^. ConstructorReference.reference_)) + LD.TermReferent (Referent.Ref ref) -> deps & over #terms (Set.insert ref) + LD.TypeReference ref -> deps & over #types (Set.insert ref) termDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set TermReference termDependencies = - Set.fromList - . mapMaybe - ( LD.fold - (\_typeRef -> Nothing) - ( Referent.fold - (\termRef -> Just termRef) - (\_typeConRef _i _ct -> Nothing) - ) - ) - . toList - . labeledDependencies + (.terms) . dependencies -- gets types from annotations and constructors typeDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference typeDependencies = - Set.fromList . mapMaybe (LD.fold Just (const Nothing)) . toList . labeledDependencies + (.types) . dependencies -- Gets the types to which this term contains references via patterns and -- data constructors. @@ -1322,7 +1384,7 @@ betaNormalForm e = e -- x -> f x => f etaNormalForm :: (Ord v) => Term0 v -> Term0 v etaNormalForm tm = case tm of - LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaNormalForm body + LamNamed' v body -> step . lam () ((), v) $ etaNormalForm body where step (LamNamed' v (App' f (Var' v'))) | v == v', v `Set.notMember` freeVars f = f @@ -1332,7 +1394,7 @@ etaNormalForm tm = case tm of -- x -> f x => f as long as `x` is a variable of type `Var.Eta` etaReduceEtaVars :: (Var v) => Term0 v -> Term0 v etaReduceEtaVars tm = case tm of - LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaReduceEtaVars body + LamNamed' v body -> step . lam (ABT.annotation tm) ((), v) $ etaReduceEtaVars body where ok v v' f = v == v' @@ -1382,7 +1444,7 @@ containsExpression = ABT.containsExpression -- Used to find matches of `@rewrite case` rules -- Returns `Nothing` if `pat` can't be interpreted as a `Pattern` -- (like `1 + 1` is not a valid pattern, but `Some x` can be) -containsCaseTerm :: Var v1 => Term2 tv ta tb v1 loc -> Term2 typeVar typeAnn loc v2 a -> Maybe Bool +containsCaseTerm :: (Var v1) => Term2 tv ta tb v1 loc -> Term2 typeVar typeAnn loc v2 a -> Maybe Bool containsCaseTerm pat = (\tm -> containsCase <$> pat' <*> pure tm) where @@ -1455,7 +1517,7 @@ rewriteCasesLHS pat0 pat0' = go t = t -- Implementation detail of `@rewrite case` rules (both find and replace) -toPattern :: Var v => Term2 tv ta tb v loc -> Maybe (Pattern loc) +toPattern :: (Var v) => Term2 tv ta tb v loc -> Maybe (Pattern loc) toPattern tm = case tm of Var' v | "_" `Text.isPrefixOf` Var.name v -> pure $ Pattern.Unbound loc Var' _ -> pure $ Pattern.Var loc @@ -1483,7 +1545,7 @@ toPattern tm = case tm of loc = ABT.annotation tm -- Implementation detail of `@rewrite case` rules (both find and replace) -matchCaseFromTerm :: Var v => Term2 typeVar typeAnn a v a -> Maybe (MatchCase a (Term2 typeVar typeAnn a v a)) +matchCaseFromTerm :: (Var v) => Term2 typeVar typeAnn a v a -> Maybe (MatchCase a (Term2 typeVar typeAnn a v a)) matchCaseFromTerm (App' (Builtin' "#case") (ABT.unabsA -> (_, Apps' _ci [pat, guard, body]))) = do p <- toPattern pat let g = unguard guard diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index 4e571ff761..7f26318001 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -8,8 +8,10 @@ import Data.Generics.Sum (_Ctor) import Data.List.Extra (nubOrd) import Data.Map qualified as Map import Data.Monoid (Any (..)) +import Data.Sequence qualified as Seq import Data.Set qualified as Set import Unison.ABT qualified as ABT +import Unison.HashQualified qualified as HQ import Unison.Kind qualified as K import Unison.LabeledDependency qualified as LD import Unison.Name qualified as Name @@ -55,6 +57,9 @@ _Ref = _Ctor @"Ref" -- | Types are represented as ABTs over the base functor F, with variables in `v` type Type v a = ABT.Term F v a +-- | For use with recursion schemes. +type TypeF v a r = ABT.Term' F v a r + wrapV :: (Ord v) => Type v a -> Type (ABT.V v) a wrapV = ABT.vmap ABT.Bound @@ -71,12 +76,14 @@ bindReferences :: Set v -> Map Name.Name TypeReference -> Type v a -> - Names.ResolutionResult v a (Type v a) + Names.ResolutionResult a (Type v a) bindReferences unsafeVarToName keepFree ns t = let fvs = ABT.freeVarOccurrences keepFree t rs = [(v, a, Map.lookup (unsafeVarToName v) ns) | (v, a) <- fvs] ok (v, _a, Just r) = pure (v, r) - ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a Names.NotFound)) + ok (v, a, Nothing) = + Left $ + Seq.singleton (Names.TypeResolutionFailure (HQ.NameOnly (unsafeVarToName v)) a Names.NotFound) in List.validate ok rs <&> \es -> bindExternal es t newtype Monotype v a = Monotype {getPolytype :: Type v a} deriving (Eq) @@ -451,28 +458,28 @@ arrow' i o = arrow (ABT.annotation i <> ABT.annotation o) i o ann :: (Ord v) => a -> Type v a -> K.Kind -> Type v a ann a e t = ABT.tm' a (Ann e t) -forall :: (Ord v) => a -> v -> Type v a -> Type v a -forall a v body = ABT.tm' a (Forall (ABT.abs' a v body)) +forAll :: (Ord v) => a -> v -> Type v a -> Type v a +forAll a v body = ABT.tm' a (Forall (ABT.abs' a v body)) introOuter :: (Ord v) => a -> v -> Type v a -> Type v a introOuter a v body = ABT.tm' a (IntroOuter (ABT.abs' a v body)) iff :: (Var v) => Type v () -iff = forall () aa $ arrows (f <$> [boolean (), a, a]) a +iff = forAll () aa $ arrows (f <$> [boolean (), a, a]) a where aa = Var.named "a" a = var () aa f x = ((), x) iff' :: (Var v) => a -> Type v a -iff' loc = forall loc aa $ arrows (f <$> [boolean loc, a, a]) a +iff' loc = forAll loc aa $ arrows (f <$> [boolean loc, a, a]) a where aa = Var.named "a" a = var loc aa f x = (loc, x) iff2 :: (Var v) => a -> Type v a -iff2 loc = forall loc aa $ arrows (f <$> [a, a]) a +iff2 loc = forAll loc aa $ arrows (f <$> [a, a]) a where aa = Var.named "a" a = var loc aa @@ -498,11 +505,11 @@ v' s = ABT.var (Var.named s) av' :: (Var v) => a -> Text -> Type v a av' a s = ABT.annotatedVar a (Var.named s) -forall' :: (Var v) => a -> [Text] -> Type v a -> Type v a -forall' a vs body = foldr (forall a) body (Var.named <$> vs) +forAll' :: (Var v) => a -> [Text] -> Type v a -> Type v a +forAll' a vs body = foldr (forAll a) body (Var.named <$> vs) foralls :: (Ord v) => a -> [v] -> Type v a -> Type v a -foralls a vs body = foldr (forall a) body vs +foralls a vs body = foldr (forAll a) body vs -- Note: `a -> b -> c` parses as `a -> (b -> c)` -- the annotation associated with `b` will be the annotation for the `b -> c` @@ -545,7 +552,7 @@ stripEffect t = ([], t) -- The type of the flipped function application operator: -- `(a -> (a -> b) -> b)` flipApply :: (Var v) => Type v () -> Type v () -flipApply t = forall () b $ arrow () (arrow () t (var () b)) (var () b) +flipApply t = forAll () b $ arrow () (arrow () t (var () b)) (var () b) where b = ABT.fresh t (Var.named "b") @@ -554,12 +561,12 @@ generalize' k t = generalize vsk t where vsk = [v | v <- Set.toList (freeVars t), Var.typeOf v == k] --- | Bind the given variables with an outer `forall`, if they are used in `t`. +-- | Bind the given variables with an outer `forAll`, if they are used in `t`. generalize :: (Ord v) => [v] -> Type v a -> Type v a generalize vs t = foldr f t vs where f v t = - if Set.member v (ABT.freeVars t) then forall (ABT.annotation t) v t else t + if Set.member v (ABT.freeVars t) then forAll (ABT.annotation t) v t else t unforall :: Type v a -> Type v a unforall (ForallsNamed' _ t) = t @@ -755,7 +762,7 @@ functionResult = go False -- `.foo -> .foo` becomes `.foo -> .foo` (not changed) -- `.foo.bar -> blarrg.woot` becomes `.foo.bar -> blarrg.woot` (unchanged) generalizeLowercase :: (Var v) => Set v -> Type v a -> Type v a -generalizeLowercase except t = foldr (forall (ABT.annotation t)) t vars +generalizeLowercase except t = foldr (forAll (ABT.annotation t)) t vars where vars = [v | v <- Set.toList (ABT.freeVars t `Set.difference` except), Var.universallyQuantifyIfFree v] @@ -774,7 +781,7 @@ normalizeForallOrder tm0 = where step :: (a, v) -> Type v a -> Type v a step (a, v) body - | Set.member v (ABT.freeVars body) = forall a v body + | Set.member v (ABT.freeVars body) = forAll a v body | otherwise = body (body, vs0) = extract tm0 vs = sortOn (\(_, v) -> Map.lookup v ind) vs0 diff --git a/unison-core/src/Unison/Type/Names.hs b/unison-core/src/Unison/Type/Names.hs index a88a913c66..030229fdde 100644 --- a/unison-core/src/Unison/Type/Names.hs +++ b/unison-core/src/Unison/Type/Names.hs @@ -3,32 +3,83 @@ module Unison.Type.Names ) where +import Data.Sequence qualified as Seq import Data.Set qualified as Set -import Data.Set.NonEmpty qualified as NES import Unison.ABT qualified as ABT -import Unison.Name qualified as Name +import Unison.HashQualified qualified as HQ +import Unison.Name (Name) +import Unison.Names (Names) import Unison.Names qualified as Names import Unison.Names.ResolutionResult qualified as Names -import Unison.NamesWithHistory qualified as Names +import Unison.Names.ResolvesTo (ResolvesTo (..), partitionResolutions) import Unison.Prelude +import Unison.Reference (TypeReference) import Unison.Type +import Unison.Type qualified as Type import Unison.Util.List qualified as List import Unison.Var (Var) bindNames :: + forall a v. (Var v) => - (v -> Name.Name) -> + (v -> Name) -> + (Name -> v) -> Set v -> - Names.Names -> + Names -> Type v a -> - Names.ResolutionResult v a (Type v a) -bindNames unsafeVarToName keepFree ns t = - let fvs = ABT.freeVarOccurrences keepFree t - rs = [(v, a, Names.lookupHQType Names.IncludeSuffixes (Name.convert $ unsafeVarToName v) ns) | (v, a) <- fvs] - ok (v, a, rs) = - if Set.size rs == 1 - then pure (v, Set.findMin rs) - else case NES.nonEmptySet rs of - Nothing -> Left (pure (Names.TypeResolutionFailure v a Names.NotFound)) - Just rs' -> Left (pure (Names.TypeResolutionFailure v a (Names.Ambiguous ns rs'))) - in List.validate ok rs <&> \es -> bindExternal es t + Names.ResolutionResult a (Type v a) +bindNames unsafeVarToName nameToVar localVars namespace = + -- type is bound here because the where-clause binds a data structure that we only want to compute once, then share + -- across all calls to `bindNames` with different types + \ty -> + let -- Identify the unresolved variables in the type: those whose names aren't an *exact* match for some locally-bound + -- type. + -- + -- For example: + -- + -- type Foo.Bar = ... + -- type Baz.Qux = ... + -- type Whatever = Whatever Foo.Bar Qux + -- ^^^^^^^ ^^^ + -- | this variable *is* unresolved: it doesn't match any locally-bound type exactly + -- | + -- this variable is *not* unresolved: it matches locally-bound `Foo.Bar` exactly + unresolvedVars :: [(v, a)] + unresolvedVars = + ABT.freeVarOccurrences localVars ty + + okTy :: (v, a) -> Names.ResolutionResult a (v, ResolvesTo TypeReference) + okTy (v, a) = + case Set.size matches of + 1 -> good (Set.findMin matches) + 0 -> bad Names.NotFound + _ -> + let (namespaceMatches, localMatches) = + matches + & Set.toList + & map \case + ResolvesToNamespace ref -> Left ref + ResolvesToLocal name -> Right name + & partitionEithers + & bimap Set.fromList Set.fromList + in bad (Names.Ambiguous namespace namespaceMatches localMatches) + where + matches :: Set (ResolvesTo TypeReference) + matches = + resolveTypeName (unsafeVarToName v) + + bad = Left . Seq.singleton . Names.TypeResolutionFailure (HQ.NameOnly (unsafeVarToName v)) a + good = Right . (v,) + in List.validate okTy unresolvedVars <&> \resolutions -> + let (namespaceResolutions, localResolutions) = partitionResolutions resolutions + in ty + -- Apply namespace resolutions (replacing "Foo" with #Foo where "Foo" refers to namespace) + & bindExternal namespaceResolutions + -- Apply local resolutions (replacing "Foo" with "Full.Name.Foo" where "Full.Name.Foo" is in local vars) + & ABT.substsInheritAnnotation [(v, Type.var () (nameToVar name)) | (v, name) <- localResolutions] + -- Clean up ability lists again – we might have something to de-dupe after resolution + & Type.cleanupAbilityLists + where + resolveTypeName :: Name -> Set (ResolvesTo TypeReference) + resolveTypeName = + Names.resolveName (Names.types namespace) (Set.map unsafeVarToName localVars) diff --git a/unison-core/src/Unison/Util/Conflicted.hs b/unison-core/src/Unison/Util/Conflicted.hs new file mode 100644 index 0000000000..2d90f4318c --- /dev/null +++ b/unison-core/src/Unison/Util/Conflicted.hs @@ -0,0 +1,10 @@ +module Unison.Util.Conflicted + ( Conflicted (..), + ) +where + +import Data.Set.NonEmpty (NESet) + +-- | A conflicted thing. +data Conflicted n a + = Conflicted !n !(NESet a) diff --git a/unison-core/src/Unison/Util/Defn.hs b/unison-core/src/Unison/Util/Defn.hs new file mode 100644 index 0000000000..d897491de4 --- /dev/null +++ b/unison-core/src/Unison/Util/Defn.hs @@ -0,0 +1,9 @@ +module Unison.Util.Defn + ( Defn (..), + ) +where + +-- | A "definition" is either a term or a type. +data Defn term typ + = TermDefn term + | TypeDefn typ diff --git a/lib/unison-util-nametree/src/Unison/Util/Defns.hs b/unison-core/src/Unison/Util/Defns.hs similarity index 78% rename from lib/unison-util-nametree/src/Unison/Util/Defns.hs rename to unison-core/src/Unison/Util/Defns.hs index 9dde575531..fed00742b4 100644 --- a/lib/unison-util-nametree/src/Unison/Util/Defns.hs +++ b/unison-core/src/Unison/Util/Defns.hs @@ -6,6 +6,8 @@ module Unison.Util.Defns DefnsF4, alignDefnsWith, defnsAreEmpty, + fromTerms, + fromTypes, hoistDefnsF, mapDefns, unzipDefns, @@ -13,6 +15,7 @@ module Unison.Util.Defns zipDefns, zipDefnsWith, zipDefnsWith3, + zipDefnsWith4, ) where @@ -28,7 +31,7 @@ data Defns terms types = Defns { terms :: terms, types :: types } - deriving stock (Generic, Show) + deriving stock (Generic, Functor, Show) deriving (Monoid, Semigroup) via GenericSemigroupMonoid (Defns terms types) instance Bifoldable Defns where @@ -56,7 +59,7 @@ type DefnsF3 f g h terms types = type DefnsF4 f g h i terms types = Defns (f (g (h (i terms)))) (f (g (h (i types)))) -alignDefnsWith :: Semialign f => (These a b -> c) -> Defns (f a) (f b) -> f c +alignDefnsWith :: (Semialign f) => (These a b -> c) -> Defns (f a) (f b) -> f c alignDefnsWith f defns = alignWith f defns.terms defns.types @@ -64,6 +67,14 @@ defnsAreEmpty :: (Foldable f, Foldable g) => Defns (f a) (g b) -> Bool defnsAreEmpty defns = null defns.terms && null defns.types +fromTerms :: (Monoid types) => terms -> Defns terms types +fromTerms terms = + Defns {terms, types = mempty} + +fromTypes :: (Monoid terms) => types -> Defns terms types +fromTypes types = + Defns {terms = mempty, types} + hoistDefnsF :: (forall x. f x -> g x) -> DefnsF f a b -> DefnsF g a b hoistDefnsF f (Defns x y) = Defns (f x) (f y) @@ -99,3 +110,14 @@ zipDefnsWith3 :: Defns tm4 ty4 zipDefnsWith3 f g (Defns terms1 types1) (Defns terms2 types2) (Defns terms3 types3) = Defns (f terms1 terms2 terms3) (g types1 types2 types3) + +zipDefnsWith4 :: + (tm1 -> tm2 -> tm3 -> tm4 -> tm5) -> + (ty1 -> ty2 -> ty3 -> ty4 -> ty5) -> + Defns tm1 ty1 -> + Defns tm2 ty2 -> + Defns tm3 ty3 -> + Defns tm4 ty4 -> + Defns tm5 ty5 +zipDefnsWith4 f g (Defns terms1 types1) (Defns terms2 types2) (Defns terms3 types3) (Defns terms4 types4) = + Defns (f terms1 terms2 terms3 terms4) (g types1 types2 types3 types4) diff --git a/lib/unison-util-nametree/src/Unison/Util/Nametree.hs b/unison-core/src/Unison/Util/Nametree.hs similarity index 78% rename from lib/unison-util-nametree/src/Unison/Util/Nametree.hs rename to unison-core/src/Unison/Util/Nametree.hs index 18a6ba3769..e87bdde344 100644 --- a/lib/unison-util-nametree/src/Unison/Util/Nametree.hs +++ b/unison-core/src/Unison/Util/Nametree.hs @@ -6,7 +6,9 @@ module Unison.Util.Nametree -- ** Flattening and unflattening flattenNametree, + flattenNametrees, unflattenNametree, + unflattenNametrees, ) where @@ -21,6 +23,7 @@ import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Util.BiMultimap (BiMultimap) import Unison.Util.BiMultimap qualified as BiMultimap +import Unison.Util.Defns (Defns (..), DefnsF) import Prelude hiding (zipWith) -- | A nametree has a value, and a collection of children nametrees keyed by name segment. @@ -49,7 +52,7 @@ instance Unzip Nametree where (ys, zs) = unzipWith (unzipWith f) xs -- | Traverse over a nametree, with access to the list of name segments (in reverse order) leading to each value. -traverseNametreeWithName :: Applicative f => ([NameSegment] -> a -> f b) -> Nametree a -> f (Nametree b) +traverseNametreeWithName :: (Applicative f) => ([NameSegment] -> a -> f b) -> Nametree a -> f (Nametree b) traverseNametreeWithName f = go [] where @@ -81,7 +84,7 @@ unfoldNametree f x = -- > } flattenNametree :: forall a b. - Ord b => + (Ord b) => (a -> Map NameSegment b) -> Nametree a -> BiMultimap b Name @@ -103,6 +106,17 @@ flattenNametree f = ) (Map.toList children) +-- | Like 'flattenNametree', but works on both the types and terms namespace at once. +flattenNametrees :: + (Ord term, Ord typ) => + Nametree (DefnsF (Map NameSegment) term typ) -> + Defns (BiMultimap term Name) (BiMultimap typ Name) +flattenNametrees defns = + Defns + { terms = flattenNametree (view #terms) defns, + types = flattenNametree (view #types) defns + } + -- | 'unflattenNametree' organizes an association between names and definitions like -- -- > { @@ -120,9 +134,9 @@ flattenNametree f = -- > "baz" = #baz -- > } -- > } -unflattenNametree :: Ord a => BiMultimap a Name -> Nametree (Map NameSegment a) +unflattenNametree :: (Ord a) => Map Name a -> Nametree (Map NameSegment a) unflattenNametree = - unfoldNametree unflattenLevel . map (first Name.segments) . Map.toList . BiMultimap.range + unfoldNametree unflattenLevel . map (first Name.segments) . Map.toList where unflattenLevel :: [(NonEmpty NameSegment, a)] -> (Map NameSegment a, Map NameSegment [(NonEmpty NameSegment, a)]) unflattenLevel = @@ -132,6 +146,18 @@ unflattenNametree = (NameHere n, v) -> (Map.insert n v accValue, accChildren) (NameThere n ns, v) -> (accValue, Map.insertWith (++) n [(ns, v)] accChildren) +-- | Like 'unflattenNametree', but works on both the types and terms namespace at once. +unflattenNametrees :: (Ord term, Ord typ) => DefnsF (Map Name) term typ -> Nametree (DefnsF (Map NameSegment) term typ) +unflattenNametrees defns = + alignWith + ( \case + This terms -> Defns {terms, types = Map.empty} + That types -> Defns {terms = Map.empty, types} + These terms types -> Defns {terms, types} + ) + (unflattenNametree defns.terms) + (unflattenNametree defns.types) + -- Helper patterns for switching on "name here" (1 name segment) or "name there" (2+ name segments) pattern NameHere :: a -> NonEmpty a diff --git a/unison-core/src/Unison/Var.hs b/unison-core/src/Unison/Var.hs index a78b6638e2..981378624a 100644 --- a/unison-core/src/Unison/Var.hs +++ b/unison-core/src/Unison/Var.hs @@ -58,7 +58,7 @@ named n = typed (User n) -- This bakes the fresh id into the name portion of the variable -- and resets the id to 0. -bakeId :: Var v => v -> v +bakeId :: (Var v) => v -> v bakeId v = named (name v) rawName :: Type -> Text diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index f5ea030c43..91d1b40b27 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -17,10 +17,6 @@ source-repository head type: git location: https://github.com/unisonweb/unison -flag optimized - manual: True - default: False - library exposed-modules: Unison.ABT @@ -32,9 +28,10 @@ library Unison.DataDeclaration.ConstructorId Unison.DataDeclaration.Names Unison.DataDeclaration.Records + Unison.DeclNameLookup Unison.Hashable Unison.HashQualified - Unison.HashQualified' + Unison.HashQualifiedPrime Unison.Kind Unison.LabeledDependency Unison.Name @@ -42,25 +39,30 @@ library Unison.Name.Internal Unison.Names Unison.Names.ResolutionResult + Unison.Names.ResolvesTo Unison.NamesWithHistory Unison.Pattern Unison.Position Unison.Project Unison.Reference Unison.Referent - Unison.Referent' + Unison.ReferentPrime Unison.Settings Unison.Symbol Unison.Term Unison.Type Unison.Type.Names Unison.Util.Components + Unison.Util.Conflicted + Unison.Util.Defn + Unison.Util.Defns + Unison.Util.Nametree Unison.Var Unison.WatchKind hs-source-dirs: src default-extensions: - ApplicativeDo + BangPatterns BlockArguments DeriveAnyClass DeriveFoldable @@ -68,17 +70,22 @@ library DeriveGeneric DeriveTraversable DerivingStrategies + DerivingVia DoAndIfThenElse + DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving ImportQualifiedPost + InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns + OverloadedLabels OverloadedStrings + OverloadedRecordDot PatternSynonyms RankNTypes ScopedTypeVariables @@ -91,7 +98,6 @@ library , bytestring , containers >=0.6.3 , cryptonite - , either , extra , fuzzyfind , generic-lens @@ -101,21 +107,17 @@ library , mtl , nonempty-containers , rfc5051 - , safe + , semialign + , semigroups , text , text-builder , these - , transformers , unison-core , unison-hash , unison-prelude - , unison-util-base32hex , unison-util-relation - , vector , witch default-language: Haskell2010 - if flag(optimized) - ghc-options: -O2 -funbox-strict-fields test-suite tests type: exitcode-stdio-1.0 @@ -123,7 +125,7 @@ test-suite tests hs-source-dirs: test default-extensions: - ApplicativeDo + BangPatterns BlockArguments DeriveAnyClass DeriveFoldable @@ -131,17 +133,22 @@ test-suite tests DeriveGeneric DeriveTraversable DerivingStrategies + DerivingVia DoAndIfThenElse + DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving ImportQualifiedPost + InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns + OverloadedLabels OverloadedStrings + OverloadedRecordDot PatternSynonyms RankNTypes ScopedTypeVariables @@ -158,5 +165,3 @@ test-suite tests , unison-core1 , unison-prelude default-language: Haskell2010 - if flag(optimized) - ghc-options: -O2 -funbox-strict-fields diff --git a/unison-hashing-v2/package.yaml b/unison-hashing-v2/package.yaml index 8d334428ba..a0d531c550 100644 --- a/unison-hashing-v2/package.yaml +++ b/unison-hashing-v2/package.yaml @@ -17,7 +17,6 @@ dependencies: - unison-hash - unison-hashing - unison-prelude - - unison-util-base32hex - unison-util-relation library: diff --git a/unison-hashing-v2/src/Unison/Hashing/V2/DataDeclaration.hs b/unison-hashing-v2/src/Unison/Hashing/V2/DataDeclaration.hs index 7d1d67ce41..3dc7b4eba0 100644 --- a/unison-hashing-v2/src/Unison/Hashing/V2/DataDeclaration.hs +++ b/unison-hashing-v2/src/Unison/Hashing/V2/DataDeclaration.hs @@ -76,7 +76,7 @@ hashDecls :: (Eq v, Var v, Show v) => (v -> Name.Name) -> Map v (DataDeclaration v a) -> - Names.ResolutionResult v a [(v, ReferenceId, DataDeclaration v a)] + Names.ResolutionResult a [(v, ReferenceId, DataDeclaration v a)] hashDecls unsafeVarToName decls = do -- todo: make sure all other external references are resolved before calling this let varToRef = hashDecls0 (void <$> decls) @@ -96,7 +96,7 @@ bindReferences :: Set v -> Map Name.Name Reference -> DataDeclaration v a -> - Names.ResolutionResult v a (DataDeclaration v a) + Names.ResolutionResult a (DataDeclaration v a) bindReferences unsafeVarToName keepFree names (DataDeclaration m a bound constructors) = do constructors <- for constructors $ \(a, v, ty) -> (a,v,) <$> Type.bindReferences unsafeVarToName keepFree names ty diff --git a/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs index 25a042e50c..b1397d0e81 100644 --- a/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs +++ b/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs @@ -23,6 +23,7 @@ where import Data.Map qualified as Map import Data.Set qualified as Set import Unison.ABT qualified as ABT +import Unison.HashQualified qualified as HQ import Unison.Hashing.V2.ABT qualified as ABT import Unison.Hashing.V2.Kind qualified as K import Unison.Hashing.V2.Reference (Reference (..), pattern ReferenceDerived) @@ -64,12 +65,12 @@ bindReferences :: Set v -> Map Name.Name Reference -> Type v a -> - Names.ResolutionResult v a (Type v a) + Names.ResolutionResult a (Type v a) bindReferences unsafeVarToName keepFree ns t = let fvs = ABT.freeVarOccurrences keepFree t rs = [(v, a, Map.lookup (unsafeVarToName v) ns) | (v, a) <- fvs] ok (v, _a, Just r) = pure (v, r) - ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a Names.NotFound)) + ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure (HQ.NameOnly (unsafeVarToName v)) a Names.NotFound)) in List.validate ok rs <&> \es -> bindExternal es t -- some smart patterns @@ -103,15 +104,15 @@ charRef = ReferenceBuiltin "Char" listRef = ReferenceBuiltin "Sequence" effectRef = ReferenceBuiltin "Effect" -forall :: (Ord v) => a -> v -> Type v a -> Type v a -forall a v body = ABT.tm' a (TypeForall (ABT.abs' a v body)) +forAll :: (Ord v) => a -> v -> Type v a -> Type v a +forAll a v body = ABT.tm' a (TypeForall (ABT.abs' a v body)) -- | Bind the given variables with an outer `forall`, if they are used in `t`. generalize :: (Ord v) => [v] -> Type v a -> Type v a generalize vs t = foldr f t vs where f v t = - if Set.member v (ABT.freeVars t) then forall (ABT.annotation t) v t else t + if Set.member v (ABT.freeVars t) then forAll (ABT.annotation t) v t else t unforall' :: Type v a -> ([v], Type v a) unforall' (ForallsNamed' vs t) = (vs, t) diff --git a/unison-hashing-v2/unison-hashing-v2.cabal b/unison-hashing-v2/unison-hashing-v2.cabal index f9c9daabd2..feae301be6 100644 --- a/unison-hashing-v2/unison-hashing-v2.cabal +++ b/unison-hashing-v2/unison-hashing-v2.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -78,6 +78,5 @@ library , unison-hash , unison-hashing , unison-prelude - , unison-util-base32hex , unison-util-relation default-language: Haskell2010 diff --git a/unison-merge/package.yaml b/unison-merge/package.yaml index 73f33af4a5..53b339cf9f 100644 --- a/unison-merge/package.yaml +++ b/unison-merge/package.yaml @@ -6,37 +6,24 @@ ghc-options: -Wall dependencies: - base - - bimap - - bitvec - - bytestring - containers - - either - - free - - generic-lens - lens - - monad-validate - mtl - nonempty-containers - - safe - semialign - semigroups - text - these - transformers - - unison-codebase - - unison-codebase-sqlite - - unison-codebase-sqlite-hashing-v2 - unison-core - unison-core1 - unison-hash - unison-parser-typechecker - unison-prelude - - unison-sqlite + - unison-pretty-printer - unison-syntax - - unison-util-cache - - unison-util-nametree - unison-util-relation - - vector + - witch - witherable library: @@ -46,8 +33,6 @@ library: # - Unison.Merge2 source-dirs: src when: - - condition: '!os(windows)' - dependencies: unix - condition: false other-modules: Paths_unison_merge @@ -79,6 +64,7 @@ default-extensions: - OverloadedRecordDot - OverloadedStrings - PatternSynonyms + - QuantifiedConstraints - RankNTypes - ScopedTypeVariables - TupleSections diff --git a/unison-merge/src/Unison/Merge.hs b/unison-merge/src/Unison/Merge.hs new file mode 100644 index 0000000000..908e776cd0 --- /dev/null +++ b/unison-merge/src/Unison/Merge.hs @@ -0,0 +1,65 @@ +module Unison.Merge + ( Mergeblob0 (..), + makeMergeblob0, + Mergeblob1 (..), + makeMergeblob1, + Mergeblob2 (..), + Mergeblob2Error (..), + makeMergeblob2, + Mergeblob3 (..), + makeMergeblob3, + Mergeblob4 (..), + makeMergeblob4, + Mergeblob5 (..), + makeMergeblob5, + + -- * Decl coherency checks + PartialDeclNameLookup (..), + IncoherentDeclReason (..), + checkDeclCoherency, + lenientCheckDeclCoherency, + IncoherentDeclReasons (..), + checkAllDeclCoherency, + + -- * Types + CombinedDiffOp (..), + DiffOp (..), + EitherWay (..), + EitherWayI (..), + LibdepDiffOp (..), + Synhashed (..), + ThreeWay (..), + TwoOrThreeWay (..), + TwoWay (..), + TwoWayI (..), + Unconflicts (..), + Updated (..), + ) +where + +import Unison.Merge.CombineDiffs (CombinedDiffOp (..)) +import Unison.Merge.DeclCoherencyCheck + ( IncoherentDeclReason (..), + IncoherentDeclReasons (..), + checkAllDeclCoherency, + checkDeclCoherency, + lenientCheckDeclCoherency, + ) +import Unison.Merge.DiffOp (DiffOp (..)) +import Unison.Merge.EitherWay (EitherWay (..)) +import Unison.Merge.EitherWayI (EitherWayI (..)) +import Unison.Merge.Libdeps (LibdepDiffOp (..)) +import Unison.Merge.Mergeblob0 (Mergeblob0 (..), makeMergeblob0) +import Unison.Merge.Mergeblob1 (Mergeblob1 (..), makeMergeblob1) +import Unison.Merge.Mergeblob2 (Mergeblob2 (..), Mergeblob2Error (..), makeMergeblob2) +import Unison.Merge.Mergeblob3 (Mergeblob3 (..), makeMergeblob3) +import Unison.Merge.Mergeblob4 (Mergeblob4 (..), makeMergeblob4) +import Unison.Merge.Mergeblob5 (Mergeblob5 (..), makeMergeblob5) +import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup (..)) +import Unison.Merge.Synhashed (Synhashed (..)) +import Unison.Merge.ThreeWay (ThreeWay (..)) +import Unison.Merge.TwoOrThreeWay (TwoOrThreeWay (..)) +import Unison.Merge.TwoWay (TwoWay (..)) +import Unison.Merge.TwoWayI (TwoWayI (..)) +import Unison.Merge.Unconflicts (Unconflicts (..)) +import Unison.Merge.Updated (Updated (..)) diff --git a/unison-merge/src/Unison/Merge/CombineDiffs.hs b/unison-merge/src/Unison/Merge/CombineDiffs.hs index c983eba79f..973a6911a8 100644 --- a/unison-merge/src/Unison/Merge/CombineDiffs.hs +++ b/unison-merge/src/Unison/Merge/CombineDiffs.hs @@ -44,7 +44,7 @@ combine :: These (DiffOp (Synhashed a)) (DiffOp (Synhashed a)) -> CombinedDiffOp combine = TwoDiffOps.make >>> combine1 >>> fmap (view #value) -combine1 :: Eq a => TwoDiffOps a -> CombinedDiffOp a +combine1 :: (Eq a) => TwoDiffOps a -> CombinedDiffOp a combine1 = \case TwoDiffOps'Add x -> CombinedDiffOp'Add (xor2ior x) TwoDiffOps'Delete x -> CombinedDiffOp'Delete (xor2ior x) diff --git a/unison-merge/src/Unison/Merge/Database.hs b/unison-merge/src/Unison/Merge/Database.hs deleted file mode 100644 index 28cc05c937..0000000000 --- a/unison-merge/src/Unison/Merge/Database.hs +++ /dev/null @@ -1,91 +0,0 @@ -module Unison.Merge.Database - ( MergeDatabase (..), - referent2to1, - makeMergeDatabase, - ) -where - -import Data.Map.Strict qualified as Map -import Data.Text qualified as Text -import U.Codebase.Branch (CausalBranch) -import U.Codebase.HashTags (CausalHash) -import U.Codebase.Reference (Reference' (..), TermReferenceId, TypeReference, TypeReferenceId) -import U.Codebase.Referent (Referent) -import U.Codebase.Referent qualified as Referent -import U.Codebase.Sqlite.Operations qualified as Operations -import Unison.Builtin qualified as Builtins -import Unison.Codebase (Codebase) -import Unison.Codebase qualified as Codebase -import Unison.Codebase.SqliteCodebase.Operations qualified as Operations (expectDeclComponent) -import Unison.ConstructorReference (GConstructorReference (..)) -import Unison.ConstructorType (ConstructorType) -import Unison.DataDeclaration qualified as V1 (Decl) -import Unison.DataDeclaration qualified as V1.Decl -import Unison.Hash (Hash) -import Unison.Parser.Ann qualified as V1 (Ann) -import Unison.Prelude -import Unison.Referent qualified as V1 (Referent) -import Unison.Referent qualified as V1.Referent -import Unison.Sqlite (Transaction) -import Unison.Sqlite qualified as Sqlite -import Unison.Symbol qualified as V1 (Symbol) -import Unison.Term qualified as V1 (Term) -import Unison.Type qualified as V1 (Type) -import Unison.Util.Cache qualified as Cache - ------------------------------------------------------------------------------------------------------------------------- --- Merge database - --- A mini record-of-functions that contains just the (possibly backed by a cache) database queries used in merge. -data MergeDatabase = MergeDatabase - { loadCausal :: CausalHash -> Transaction (CausalBranch Transaction), - loadDeclNumConstructors :: TypeReferenceId -> Transaction Int, - loadDeclType :: TypeReference -> Transaction ConstructorType, - loadV1Decl :: TypeReferenceId -> Transaction (V1.Decl V1.Symbol V1.Ann), - loadV1DeclComponent :: Hash -> Transaction [V1.Decl V1.Symbol V1.Ann], - loadV1Term :: TermReferenceId -> Transaction (V1.Term V1.Symbol V1.Ann), - loadV1TermComponent :: Hash -> Transaction [(V1.Term V1.Symbol V1.Ann, V1.Type V1.Symbol V1.Ann)] - } - -makeMergeDatabase :: MonadIO m => Codebase IO V1.Symbol V1.Ann -> m MergeDatabase -makeMergeDatabase codebase = liftIO do - -- Create a bunch of cached database lookup functions - loadCausal <- do - cache <- Cache.semispaceCache 1024 - pure (Sqlite.cacheTransaction cache Operations.expectCausalBranchByCausalHash) - loadDeclNumConstructors <- do - cache <- Cache.semispaceCache 1024 - pure (Sqlite.cacheTransaction cache Operations.expectDeclNumConstructors) - loadV1Decl <- do - cache <- Cache.semispaceCache 1024 - pure (Sqlite.cacheTransaction cache (Codebase.unsafeGetTypeDeclaration codebase)) - -- Since loading a decl type loads the decl and projects out the decl type, just reuse the loadDecl cache - let loadDeclType ref = - case ref of - ReferenceBuiltin name -> - Map.lookup ref Builtins.builtinConstructorType - & maybe (error ("Unknown builtin: " ++ Text.unpack name)) pure - ReferenceDerived refId -> V1.Decl.constructorType <$> loadV1Decl refId - loadV1Term <- do - cache <- Cache.semispaceCache 1024 - pure (Sqlite.cacheTransaction cache (Codebase.unsafeGetTerm codebase)) - let loadV1TermComponent = Codebase.unsafeGetTermComponent codebase - let loadV1DeclComponent = Operations.expectDeclComponent - pure - MergeDatabase - { loadCausal, - loadDeclNumConstructors, - loadDeclType, - loadV1Decl, - loadV1DeclComponent, - loadV1Term, - loadV1TermComponent - } - --- Convert a v2 referent (missing decl type) to a v1 referent. -referent2to1 :: MergeDatabase -> Referent -> Transaction V1.Referent -referent2to1 MergeDatabase {loadDeclType} = \case - Referent.Con typeRef conId -> do - declTy <- loadDeclType typeRef - pure (V1.Referent.Con (ConstructorReference typeRef conId) declTy) - Referent.Ref termRef -> pure (V1.Referent.Ref termRef) diff --git a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs index a215354b3b..697e693d6b 100644 --- a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs +++ b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs @@ -83,15 +83,17 @@ module Unison.Merge.DeclCoherencyCheck ( IncoherentDeclReason (..), checkDeclCoherency, lenientCheckDeclCoherency, + + -- * Getting all failures rather than just the first + IncoherentDeclReasons (..), + checkAllDeclCoherency, ) where import Control.Lens ((%=), (.=), _2) -import Control.Monad.Except (ExceptT) -import Control.Monad.Except qualified as Except import Control.Monad.State.Strict (StateT) import Control.Monad.State.Strict qualified as State -import Control.Monad.Trans.Except qualified as Except (except) +import Control.Monad.Trans.State.Strict (State) import Data.Functor.Compose (Compose (..)) import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict qualified as IntMap @@ -103,11 +105,13 @@ import Data.Set qualified as Set import U.Codebase.Reference (Reference' (..), TypeReference, TypeReferenceId) import Unison.ConstructorReference (GConstructorReference (..)) import Unison.DataDeclaration.ConstructorId (ConstructorId) -import Unison.Merge.DeclNameLookup (DeclNameLookup (..)) +import Unison.DeclNameLookup (DeclNameLookup (..)) +import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup (..)) import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.Prelude +import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Util.Defns (Defns (..), DefnsF) @@ -127,117 +131,235 @@ data IncoherentDeclReason -- Foo#Foo -- Foo.Bar#Foo IncoherentDeclReason'NestedDeclAlias !Name !Name -- shorter name, longer name - | IncoherentDeclReason'StrayConstructor !Name + | IncoherentDeclReason'StrayConstructor !TypeReferenceId !Name + deriving stock (Show) checkDeclCoherency :: + (HasCallStack) => + Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> + Map TypeReferenceId Int -> + Either IncoherentDeclReason DeclNameLookup +checkDeclCoherency nametree numConstructorsById = + checkDeclCoherencyWith + (\refId -> Right (expectNumConstructors refId numConstructorsById)) + OnIncoherentDeclReasons + { onConstructorAlias = \x y z -> Left (IncoherentDeclReason'ConstructorAlias x y z), + onMissingConstructorName = \x -> Left (IncoherentDeclReason'MissingConstructorName x), + onNestedDeclAlias = \x y -> Left (IncoherentDeclReason'NestedDeclAlias x y), + onStrayConstructor = \x y -> Left (IncoherentDeclReason'StrayConstructor x y) + } + nametree + +data IncoherentDeclReasons = IncoherentDeclReasons + { constructorAliases :: ![(Name, Name, Name)], + missingConstructorNames :: ![Name], + nestedDeclAliases :: ![(Name, Name)], + strayConstructors :: ![(TypeReferenceId, Name)] + } + deriving stock (Eq, Generic) + +-- | Like 'checkDeclCoherency', but returns info about all of the incoherent decls found, not just the first. +checkAllDeclCoherency :: + forall m. + (Monad m) => + (TypeReferenceId -> m Int) -> + Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> + m (Either IncoherentDeclReasons DeclNameLookup) +checkAllDeclCoherency loadDeclNumConstructors nametree = do + State.runStateT doCheck emptyReasons <&> \(declNameLookup, reasons) -> + if reasons == emptyReasons + then Right declNameLookup + else Left (reverseReasons reasons) + where + doCheck :: StateT IncoherentDeclReasons m DeclNameLookup + doCheck = + checkDeclCoherencyWith + (lift . loadDeclNumConstructors) + ( OnIncoherentDeclReasons + { onConstructorAlias = \x y z -> #constructorAliases %= ((x, y, z) :), + onMissingConstructorName = \x -> #missingConstructorNames %= (x :), + onNestedDeclAlias = \x y -> #nestedDeclAliases %= ((x, y) :), + onStrayConstructor = \x y -> #strayConstructors %= ((x, y) :) + } + ) + nametree + + emptyReasons :: IncoherentDeclReasons + emptyReasons = + IncoherentDeclReasons [] [] [] [] + + reverseReasons :: IncoherentDeclReasons -> IncoherentDeclReasons + reverseReasons reasons = + IncoherentDeclReasons + { constructorAliases = reverse reasons.constructorAliases, + missingConstructorNames = reverse reasons.missingConstructorNames, + nestedDeclAliases = reverse reasons.nestedDeclAliases, + strayConstructors = reverse reasons.strayConstructors + } + +data OnIncoherentDeclReasons m = OnIncoherentDeclReasons + { onConstructorAlias :: Name -> Name -> Name -> m (), + onMissingConstructorName :: Name -> m (), + onNestedDeclAlias :: Name -> Name -> m (), + onStrayConstructor :: TypeReferenceId -> Name -> m () + } + +checkDeclCoherencyWith :: forall m. - Monad m => + (Monad m) => (TypeReferenceId -> m Int) -> + OnIncoherentDeclReasons m -> Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> - m (Either IncoherentDeclReason DeclNameLookup) -checkDeclCoherency loadDeclNumConstructors = - Except.runExceptT - . fmap (view #declNameLookup) + m DeclNameLookup +checkDeclCoherencyWith loadDeclNumConstructors callbacks = + fmap (view #declNameLookup) . (`State.execStateT` DeclCoherencyCheckState Map.empty (DeclNameLookup Map.empty Map.empty)) . go [] where go :: [NameSegment] -> (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> - StateT DeclCoherencyCheckState (ExceptT IncoherentDeclReason m) () + StateT DeclCoherencyCheckState m () go prefix (Nametree defns children) = do - for_ (Map.toList defns.terms) \case - (_, Referent.Ref _) -> pure () - (_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure () - (name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do - DeclCoherencyCheckState {expectedConstructors} <- State.get - expectedConstructors1 <- lift (Except.except (Map.upsertF f typeRef expectedConstructors)) - #expectedConstructors .= expectedConstructors1 - where - f :: - Maybe (Name, ConstructorNames) -> - Either IncoherentDeclReason (Name, ConstructorNames) - f = \case - Nothing -> Left (IncoherentDeclReason'StrayConstructor name1) - Just (typeName, expected) -> - case recordConstructorName conId name1 expected of - Left existingName -> Left (IncoherentDeclReason'ConstructorAlias typeName existingName name1) - Right expected1 -> Right (typeName, expected1) - where - name1 = fullName name - + for_ + (Map.toList defns.terms) + ( checkDeclCoherencyWith_DoTerms + callbacks + prefix + ) childrenWeWentInto <- - forMaybe (Map.toList defns.types) \case - (_, ReferenceBuiltin _) -> pure Nothing - (name, ReferenceDerived typeRef) -> do - DeclCoherencyCheckState {expectedConstructors} <- State.get - whatHappened <- do - let recordNewDecl :: - Maybe (Name, ConstructorNames) -> - Compose (ExceptT IncoherentDeclReason m) WhatHappened (Name, ConstructorNames) - recordNewDecl = - Compose . \case - Just (shorterTypeName, _) -> Except.throwError (IncoherentDeclReason'NestedDeclAlias shorterTypeName typeName) - Nothing -> - lift (loadDeclNumConstructors typeRef) <&> \case - 0 -> UninhabitedDecl - n -> InhabitedDecl (typeName, emptyConstructorNames n) - lift (getCompose (Map.upsertF recordNewDecl typeRef expectedConstructors)) - case whatHappened of - UninhabitedDecl -> do - #declNameLookup . #declToConstructors %= Map.insert typeName [] - pure Nothing - InhabitedDecl expectedConstructors1 -> do - child <- - Map.lookup name children & onNothing do - Except.throwError (IncoherentDeclReason'MissingConstructorName typeName) - #expectedConstructors .= expectedConstructors1 - go (name : prefix) child - DeclCoherencyCheckState {expectedConstructors} <- State.get - -- fromJust is safe here because we upserted `typeRef` key above - let (fromJust -> (_typeName, maybeConstructorNames), expectedConstructors1) = - Map.deleteLookup typeRef expectedConstructors - constructorNames <- - sequence (IntMap.elems maybeConstructorNames) & onNothing do - Except.throwError (IncoherentDeclReason'MissingConstructorName typeName) - #expectedConstructors .= expectedConstructors1 - #declNameLookup . #constructorToDecl %= \constructorToDecl -> - List.foldl' - (\acc constructorName -> Map.insert constructorName typeName acc) - constructorToDecl - constructorNames - #declNameLookup . #declToConstructors %= Map.insert typeName constructorNames - pure (Just name) - where - typeName = fullName name - + forMaybe + (Map.toList defns.types) + (checkDeclCoherencyWith_DoTypes loadDeclNumConstructors callbacks go prefix children) let childrenWeHaventGoneInto = children `Map.withoutKeys` Set.fromList childrenWeWentInto for_ (Map.toList childrenWeHaventGoneInto) \(name, child) -> go (name : prefix) child - where - fullName name = - Name.fromReverseSegments (name :| prefix) --- | A lenient variant of 'checkDeclCoherency' - so lenient it can't even fail! It returns a mapping from decl name to --- constructor names, where constructor names can be missing. --- --- This function exists merely to extract a best-effort decl-name-to-constructor-name mapping for the LCA of a merge. --- We require Alice and Bob to have coherent decls, but their LCA is out of the user's control and may have incoherent --- decls, and whether or not it does, we still need to compute *some* syntactic hash for its decls. -lenientCheckDeclCoherency :: +checkDeclCoherencyWith_DoTerms :: + forall m. + (Monad m) => + OnIncoherentDeclReasons m -> + [NameSegment] -> + (NameSegment, Referent) -> + StateT DeclCoherencyCheckState m () +checkDeclCoherencyWith_DoTerms callbacks prefix (segment, ref) = + whenJust (Referent.toConstructorReferenceId ref) \(ConstructorReference typeRef conId) -> do + let f :: Maybe (Name, ConstructorNames) -> MaybeT m (Name, ConstructorNames) + f = \case + Nothing -> do + lift (callbacks.onStrayConstructor typeRef conName) + MaybeT (pure Nothing) + Just (typeName, expected) -> + case recordConstructorName conId conName expected of + Left existingName -> do + lift (callbacks.onConstructorAlias typeName existingName conName) + MaybeT (pure Nothing) + Right expected1 -> pure (typeName, expected1) + where + conName = + Name.fromReverseSegments (segment :| prefix) + state <- State.get + whenJustM (lift (runMaybeT (Map.upsertF f typeRef state.expectedConstructors))) \expectedConstructors1 -> + #expectedConstructors .= expectedConstructors1 + +checkDeclCoherencyWith_DoTypes :: forall m. - Monad m => + (Monad m) => (TypeReferenceId -> m Int) -> + OnIncoherentDeclReasons m -> + ( [NameSegment] -> + (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> + StateT DeclCoherencyCheckState m () + ) -> + [NameSegment] -> + Map NameSegment (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> + (NameSegment, TypeReference) -> + StateT DeclCoherencyCheckState m (Maybe NameSegment) +checkDeclCoherencyWith_DoTypes loadDeclNumConstructors callbacks go prefix children (name, ref) = + case Reference.toId ref of + Nothing -> pure Nothing + Just refId -> + checkDeclCoherencyWith_DoTypes2 loadDeclNumConstructors callbacks go prefix children name refId + +checkDeclCoherencyWith_DoTypes2 :: + forall m. + (Monad m) => + (TypeReferenceId -> m Int) -> + OnIncoherentDeclReasons m -> + ( [NameSegment] -> + (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> + StateT DeclCoherencyCheckState m () + ) -> + [NameSegment] -> + Map NameSegment (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> + NameSegment -> + TypeReferenceId -> + StateT DeclCoherencyCheckState m (Maybe NameSegment) +checkDeclCoherencyWith_DoTypes2 loadDeclNumConstructors callbacks go prefix children name typeRef = do + state <- State.get + lift (runMaybeT (getCompose (Map.upsertF recordNewDecl typeRef state.expectedConstructors))) >>= \case + Nothing -> pure Nothing + Just UninhabitedDecl -> do + #declNameLookup . #declToConstructors %= Map.insert typeName [] + pure Nothing + Just (InhabitedDecl expectedConstructors1) -> do + case Map.lookup name children of + Nothing -> do + lift (callbacks.onMissingConstructorName typeName) + pure Nothing + Just child -> do + #expectedConstructors .= expectedConstructors1 + go (name : prefix) child + state <- State.get + -- fromJust is safe here because we upserted `typeRef` key above + let (fromJust -> (_typeName, maybeConstructorNames), expectedConstructors1) = + Map.deleteLookup typeRef state.expectedConstructors + #expectedConstructors .= expectedConstructors1 + case sequence (IntMap.elems maybeConstructorNames) of + Nothing -> lift (callbacks.onMissingConstructorName typeName) + Just constructorNames -> do + #declNameLookup . #constructorToDecl %= \constructorToDecl -> + List.foldl' + (\acc constructorName -> Map.insert constructorName typeName acc) + constructorToDecl + constructorNames + #declNameLookup . #declToConstructors %= Map.insert typeName constructorNames + pure (Just name) + where + typeName :: Name + typeName = + Name.fromReverseSegments (name :| prefix) + + recordNewDecl :: Maybe (Name, ConstructorNames) -> Compose (MaybeT m) WhatHappened (Name, ConstructorNames) + recordNewDecl = + Compose . \case + Just (shorterTypeName, _) -> do + lift (callbacks.onNestedDeclAlias shorterTypeName typeName) + MaybeT (pure Nothing) + Nothing -> + lift (loadDeclNumConstructors typeRef) <&> \case + 0 -> UninhabitedDecl + n -> InhabitedDecl (typeName, emptyConstructorNames n) + +-- | A lenient variant of 'checkDeclCoherency' - so lenient it can't even fail! It returns partial decl name lookup, +-- which doesn't require a name for every constructor, and allows a constructor with a nameless decl. +-- +-- This function exists merely to extract a best-effort name mapping for the LCA of a merge. We require Alice and Bob to +-- have coherent decls, but their LCA is out of the user's control and may have incoherent decls, and whether or not it +-- does, we still need to compute *some* syntactic hash for its decls. +lenientCheckDeclCoherency :: Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> - m (Map Name [Maybe Name]) -lenientCheckDeclCoherency loadDeclNumConstructors = - fmap (view #declToConstructors) - . (`State.execStateT` LenientDeclCoherencyCheckState Map.empty Map.empty) - . go [] + Map TypeReferenceId Int -> + PartialDeclNameLookup +lenientCheckDeclCoherency nametree numConstructorsById = + nametree + & go [] + & (`State.execState` LenientDeclCoherencyCheckState Map.empty (PartialDeclNameLookup Map.empty Map.empty)) + & view #declNameLookup where go :: [NameSegment] -> (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> - StateT LenientDeclCoherencyCheckState m () + State LenientDeclCoherencyCheckState () go prefix (Nametree defns children) = do for_ (Map.toList defns.terms) \case (_, Referent.Ref _) -> pure () @@ -249,24 +371,24 @@ lenientCheckDeclCoherency loadDeclNumConstructors = forMaybe (Map.toList defns.types) \case (_, ReferenceBuiltin _) -> pure Nothing (name, ReferenceDerived typeRef) -> do - whatHappened <- do - let recordNewDecl :: m (WhatHappened (Map Name ConstructorNames)) - recordNewDecl = - loadDeclNumConstructors typeRef <&> \case - 0 -> UninhabitedDecl - n -> InhabitedDecl (Map.singleton typeName (emptyConstructorNames n)) - state <- State.get - lift (getCompose (Map.upsertF (\_ -> Compose recordNewDecl) typeRef state.expectedConstructors)) + state <- State.get + let whatHappened = + let recordNewDecl :: WhatHappened (Map Name ConstructorNames) + recordNewDecl = + case expectNumConstructors typeRef numConstructorsById of + 0 -> UninhabitedDecl + n -> InhabitedDecl (Map.singleton typeName (emptyConstructorNames n)) + in Map.upsertF (\_ -> recordNewDecl) typeRef state.expectedConstructors case whatHappened of UninhabitedDecl -> do - #declToConstructors %= Map.insert typeName [] + #declNameLookup . #declToConstructors %= Map.insert typeName [] pure Nothing InhabitedDecl expectedConstructors1 -> do let child = Map.findWithDefault (Nametree (Defns Map.empty Map.empty) Map.empty) name children #expectedConstructors .= expectedConstructors1 go (name : prefix) child state <- State.get - let (maybeConstructorNames, expectedConstructors) = + let (constructorNames0, expectedConstructors) = Map.alterF f typeRef state.expectedConstructors where f :: @@ -278,8 +400,21 @@ lenientCheckDeclCoherency loadDeclNumConstructors = fromJust >>> Map.deleteLookupJust typeName >>> over _2 \m -> if Map.null m then Nothing else Just m + + constructorNames :: [Maybe Name] + constructorNames = + IntMap.elems constructorNames0 + #expectedConstructors .= expectedConstructors - #declToConstructors %= Map.insert typeName (IntMap.elems maybeConstructorNames) + #declNameLookup . #constructorToDecl %= \constructorToDecl -> + List.foldl' + ( \acc -> \case + Nothing -> acc + Just constructorName -> Map.insert constructorName typeName acc + ) + constructorToDecl + constructorNames + #declNameLookup . #declToConstructors %= Map.insert typeName constructorNames pure (Just name) where typeName = fullName name @@ -298,7 +433,7 @@ data DeclCoherencyCheckState = DeclCoherencyCheckState data LenientDeclCoherencyCheckState = LenientDeclCoherencyCheckState { expectedConstructors :: !(Map TypeReferenceId (Map Name ConstructorNames)), - declToConstructors :: !(Map Name [Maybe Name]) + declNameLookup :: !PartialDeclNameLookup } deriving stock (Generic) @@ -313,7 +448,7 @@ emptyConstructorNames :: Int -> ConstructorNames emptyConstructorNames numConstructors = IntMap.fromAscList [(i, Nothing) | i <- [0 .. numConstructors - 1]] -recordConstructorName :: HasCallStack => ConstructorId -> Name -> ConstructorNames -> Either Name ConstructorNames +recordConstructorName :: (HasCallStack) => ConstructorId -> Name -> ConstructorNames -> Either Name ConstructorNames recordConstructorName conId conName = IntMap.alterF f (fromIntegral @Word64 @Int conId) where @@ -337,3 +472,11 @@ data WhatHappened a = UninhabitedDecl | InhabitedDecl !a deriving stock (Functor, Show) + +expectNumConstructors :: (HasCallStack) => TypeReferenceId -> Map TypeReferenceId Int -> Int +expectNumConstructors refId numConstructorsById = + case Map.lookup refId numConstructorsById of + Just numConstructors -> numConstructors + Nothing -> + error $ + reportBug "E061715" ("type ref " ++ show refId ++ " not found in map " ++ show numConstructorsById) diff --git a/unison-merge/src/Unison/Merge/Diff.hs b/unison-merge/src/Unison/Merge/Diff.hs index 754b36be78..39be392c28 100644 --- a/unison-merge/src/Unison/Merge/Diff.hs +++ b/unison-merge/src/Unison/Merge/Diff.hs @@ -3,21 +3,21 @@ module Unison.Merge.Diff ) where -import Data.Bitraversable (bitraverse) import Data.Map.Strict qualified as Map import Data.Semialign (alignWith) import Data.Set qualified as Set import Data.These (These (..)) import U.Codebase.Reference (TypeReference) +import Unison.ConstructorReference (GConstructorReference (..)) import Unison.DataDeclaration (Decl) import Unison.DataDeclaration qualified as DataDeclaration +import Unison.DeclNameLookup (DeclNameLookup) +import Unison.DeclNameLookup qualified as DeclNameLookup import Unison.Hash (Hash (Hash)) -import Unison.HashQualified' qualified as HQ' -import Unison.Merge.Database (MergeDatabase (..)) -import Unison.Merge.DeclNameLookup (DeclNameLookup) -import Unison.Merge.DeclNameLookup qualified as DeclNameLookup +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Merge.DiffOp (DiffOp (..)) -import Unison.Merge.Synhash +import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup (..)) +import Unison.Merge.Synhash qualified as Synhash import Unison.Merge.Synhashed (Synhashed (..)) import Unison.Merge.ThreeWay (ThreeWay (..)) import Unison.Merge.ThreeWay qualified as ThreeWay @@ -28,11 +28,12 @@ import Unison.Parser.Ann (Ann) import Unison.Prelude hiding (catMaybes) import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) import Unison.PrettyPrintEnv qualified as Ppe -import Unison.Reference (Reference' (..), TypeReferenceId) +import Unison.Reference (Reference' (..), TermReference, TermReferenceId, TypeReferenceId) import Unison.Referent (Referent) -import Unison.Sqlite (Transaction) +import Unison.Referent qualified as Referent import Unison.Symbol (Symbol) import Unison.Syntax.Name qualified as Name +import Unison.Term (Term) import Unison.Util.BiMultimap (BiMultimap) import Unison.Util.BiMultimap qualified as BiMultimap import Unison.Util.Defns (Defns (..), DefnsF2, DefnsF3, zipDefnsWith) @@ -46,54 +47,17 @@ import Unison.Util.Defns (Defns (..), DefnsF2, DefnsF3, zipDefnsWith) -- where each name is paired with its diff-op (added, deleted, or updated), relative to the LCA between Alice and Bob's -- branches. If the hash of a name did not change, it will not appear in the map. nameBasedNamespaceDiff :: - MergeDatabase -> + (HasCallStack) => TwoWay DeclNameLookup -> - Map Name [Maybe Name] -> + PartialDeclNameLookup -> ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> - Transaction (TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)) -nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns = do - lcaHashes <- - synhashDefnsWith - hashTerm - ( \name -> \case - ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin) - ReferenceDerived ref -> - case sequence (lcaDeclToConstructors Map.! name) of - -- If we don't have a name for every constructor, that's okay, just use a dummy syntactic hash here. - -- This is safe; Alice/Bob can't have such a decl (it violates a merge precondition), so there's no risk - -- that we accidentally get an equal hash and classify a real update as unchanged. - Nothing -> pure (Hash mempty) - Just names -> do - decl <- loadDeclWithGoodConstructorNames names ref - pure (synhashDerivedDecl ppe name decl) - ) - defns.lca - hashes <- sequence (synhashDefns <$> declNameLookups <*> ThreeWay.forgetLca defns) - pure (diffNamespaceDefns lcaHashes <$> hashes) + Defns (Map TermReferenceId (Term Symbol Ann)) (Map TypeReferenceId (Decl Symbol Ann)) -> + TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) +nameBasedNamespaceDiff declNameLookups lcaDeclNameLookup defns hydratedDefns = + let lcaHashes = synhashLcaDefns ppe lcaDeclNameLookup defns.lca hydratedDefns + hashes = synhashDefns ppe hydratedDefns <$> declNameLookups <*> ThreeWay.forgetLca defns + in diffHashedNamespaceDefns lcaHashes <$> hashes where - synhashDefns :: - DeclNameLookup -> - Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> - Transaction (DefnsF2 (Map Name) Synhashed Referent TypeReference) - synhashDefns declNameLookup = - -- FIXME: use cache so we only synhash each thing once - synhashDefnsWith hashTerm hashType - where - hashType :: Name -> TypeReference -> Transaction Hash - hashType name = \case - ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin) - ReferenceDerived ref -> do - decl <- loadDeclWithGoodConstructorNames (DeclNameLookup.expectConstructorNames declNameLookup name) ref - pure (synhashDerivedDecl ppe name decl) - - loadDeclWithGoodConstructorNames :: [Name] -> TypeReferenceId -> Transaction (Decl Symbol Ann) - loadDeclWithGoodConstructorNames names = - fmap (DataDeclaration.setConstructorNames (map Name.toVar names)) . db.loadV1Decl - - hashTerm :: Referent -> Transaction Hash - hashTerm = - synhashTerm db.loadV1Term ppe - ppe :: PrettyPrintEnv ppe = -- The order between Alice and Bob isn't important here for syntactic hashing; not sure right now if it matters @@ -102,18 +66,18 @@ nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns = do `Ppe.addFallback` deepNamespaceDefinitionsToPpe defns.bob `Ppe.addFallback` deepNamespaceDefinitionsToPpe defns.lca -diffNamespaceDefns :: +diffHashedNamespaceDefns :: DefnsF2 (Map Name) Synhashed term typ -> DefnsF2 (Map Name) Synhashed term typ -> DefnsF3 (Map Name) DiffOp Synhashed term typ -diffNamespaceDefns = +diffHashedNamespaceDefns = zipDefnsWith f f where f :: Map Name (Synhashed ref) -> Map Name (Synhashed ref) -> Map Name (DiffOp (Synhashed ref)) f old new = Map.mapMaybe id (alignWith g old new) - g :: Eq x => These x x -> Maybe (DiffOp x) + g :: (Eq x) => These x x -> Maybe (DiffOp x) g = \case This old -> Just (DiffOp'Delete old) That new -> Just (DiffOp'Add new) @@ -121,6 +85,104 @@ diffNamespaceDefns = | old == new -> Nothing | otherwise -> Just (DiffOp'Update Updated {old, new}) +------------------------------------------------------------------------------------------------------------------------ +-- Syntactic hashing + +synhashLcaDefns :: + (HasCallStack) => + PrettyPrintEnv -> + PartialDeclNameLookup -> + Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> + Defns (Map TermReferenceId (Term Symbol Ann)) (Map TypeReferenceId (Decl Symbol Ann)) -> + DefnsF2 (Map Name) Synhashed Referent TypeReference +synhashLcaDefns ppe declNameLookup defns hydratedDefns = + synhashDefnsWith hashReferent hashType defns + where + -- For the LCA only, if we don't have a name for every constructor, or we don't have a name for a decl, that's okay, + -- just use a dummy syntactic hash (e.g. where we return `Hash mempty` below in two places). + -- + -- This is safe and correct; Alice/Bob can't have such a decl (it violates a merge precondition), so there's no risk + -- that we accidentally get an equal hash and classify a real update as unchanged. + + hashReferent :: Name -> Referent -> Hash + hashReferent name = \case + Referent.Con (ConstructorReference ref _) _ -> + case Map.lookup name declNameLookup.constructorToDecl of + Nothing -> Hash mempty -- see note above + Just declName -> hashType declName ref + Referent.Ref ref -> synhashTermReference ppe hydratedDefns.terms ref + + hashType :: Name -> TypeReference -> Hash + hashType name = \case + ReferenceBuiltin builtin -> Synhash.synhashBuiltinDecl builtin + ReferenceDerived ref -> + case sequence (declNameLookup.declToConstructors Map.! name) of + Nothing -> Hash mempty -- see note above + Just names -> synhashDerivedDecl ppe hydratedDefns.types names name ref + +synhashDefns :: + (HasCallStack) => + PrettyPrintEnv -> + Defns (Map TermReferenceId (Term Symbol Ann)) (Map TypeReferenceId (Decl Symbol Ann)) -> + DeclNameLookup -> + Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> + DefnsF2 (Map Name) Synhashed Referent TypeReference +synhashDefns ppe hydratedDefns declNameLookup = + synhashDefnsWith hashReferent hashType + where + hashReferent :: Name -> Referent -> Hash + hashReferent name = \case + -- We say that a referent constructor *in the namespace* (distinct from a referent that is in a term body) has a + -- synhash that is simply equal to the synhash of its type declaration. This is because the type declaration and + -- constructors are changed in lock-step: it is not possible to change one, but not the other. + -- + -- For example, if Alice updates `type Foo = Bar Nat` to `type Foo = Bar Nat Nat`, we want different synhashes on + -- both the type (Foo) and the constructor (Foo.Bar). + Referent.Con (ConstructorReference ref _) _ -> hashType (DeclNameLookup.expectDeclName declNameLookup name) ref + Referent.Ref ref -> synhashTermReference ppe hydratedDefns.terms ref + + hashType :: Name -> TypeReference -> Hash + hashType name = \case + ReferenceBuiltin builtin -> Synhash.synhashBuiltinDecl builtin + ReferenceDerived ref -> + synhashDerivedDecl ppe hydratedDefns.types (DeclNameLookup.expectConstructorNames declNameLookup name) name ref + +synhashDerivedDecl :: + (HasCallStack) => + PrettyPrintEnv -> + Map TypeReferenceId (Decl Symbol Ann) -> + [Name] -> + Name -> + TypeReferenceId -> + Hash +synhashDerivedDecl ppe declsById names name ref = + declsById + & expectDecl ref + & DataDeclaration.setConstructorNames (map Name.toVar names) + & Synhash.synhashDerivedDecl ppe name + +synhashTermReference :: (HasCallStack) => PrettyPrintEnv -> Map TermReferenceId (Term Symbol Ann) -> TermReference -> Hash +synhashTermReference ppe termsById = \case + ReferenceBuiltin builtin -> Synhash.synhashBuiltinTerm builtin + ReferenceDerived ref -> Synhash.synhashDerivedTerm ppe (expectTerm ref termsById) + +synhashDefnsWith :: + (HasCallStack) => + (Name -> term -> Hash) -> + (Name -> typ -> Hash) -> + Defns (BiMultimap term Name) (BiMultimap typ Name) -> + DefnsF2 (Map Name) Synhashed term typ +synhashDefnsWith hashTerm hashType = do + bimap + (Map.mapWithKey hashTerm1 . BiMultimap.range) + (Map.mapWithKey hashType1 . BiMultimap.range) + where + hashTerm1 name term = + Synhashed (hashTerm name term) term + + hashType1 name typ = + Synhashed (hashType name typ) typ + ------------------------------------------------------------------------------------------------------------------------ -- Pretty-print env helpers @@ -128,30 +190,23 @@ deepNamespaceDefinitionsToPpe :: Defns (BiMultimap Referent Name) (BiMultimap Ty deepNamespaceDefinitionsToPpe Defns {terms, types} = PrettyPrintEnv (arbitraryName terms) (arbitraryName types) where - arbitraryName :: Ord ref => BiMultimap ref Name -> ref -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)] + arbitraryName :: (Ord ref) => BiMultimap ref Name -> ref -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)] arbitraryName names ref = BiMultimap.lookupDom ref names & Set.lookupMin & maybe [] \name -> [(HQ'.NameOnly name, HQ'.NameOnly name)] ------------------------------------------------------------------------------------------------------------------------ --- Syntactic hashing helpers +-- Looking up terms and decls that we expect to be there -synhashDefnsWith :: - Monad m => - (term -> m Hash) -> - (Name -> typ -> m Hash) -> - Defns (BiMultimap term Name) (BiMultimap typ Name) -> - m (DefnsF2 (Map Name) Synhashed term typ) -synhashDefnsWith hashTerm hashType = do - bitraverse - (traverse hashTerm1 . BiMultimap.range) - (Map.traverseWithKey hashType1 . BiMultimap.range) - where - hashTerm1 term = do - hash <- hashTerm term - pure (Synhashed hash term) +expectTerm :: (HasCallStack) => TermReferenceId -> Map TermReferenceId (Term Symbol Ann) -> Term Symbol Ann +expectTerm ref termsById = + case Map.lookup ref termsById of + Nothing -> error (reportBug "E488229" ("term ref " ++ show ref ++ " not found in map " ++ show termsById)) + Just term -> term - hashType1 name typ = do - hash <- hashType name typ - pure (Synhashed hash typ) +expectDecl :: (HasCallStack) => TypeReferenceId -> Map TypeReferenceId (Decl Symbol Ann) -> Decl Symbol Ann +expectDecl ref declsById = + case Map.lookup ref declsById of + Nothing -> error (reportBug "E663160" ("type ref " ++ show ref ++ " not found in map " ++ show declsById)) + Just decl -> decl diff --git a/unison-merge/src/Unison/Merge/FindConflictedAlias.hs b/unison-merge/src/Unison/Merge/FindConflictedAlias.hs new file mode 100644 index 0000000000..bf7222d4dd --- /dev/null +++ b/unison-merge/src/Unison/Merge/FindConflictedAlias.hs @@ -0,0 +1,67 @@ +module Unison.Merge.FindConflictedAlias + ( findConflictedAlias, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Unison.Merge.DiffOp (DiffOp (..)) +import Unison.Merge.Updated qualified +import Unison.Prelude +import Unison.Util.BiMultimap (BiMultimap) +import Unison.Util.BiMultimap qualified as BiMultimap +import Unison.Util.Defn (Defn (..)) +import Unison.Util.Defns (Defns (..), DefnsF3) + +-- @findConflictedAlias namespace diff@, given an old namespace and a diff to a new namespace, will return the first +-- "conflicted alias" encountered (if any), where a "conflicted alias" is a pair of names that referred to the same +-- thing in the old namespace, but different things in the new one. +-- +-- For example, if the old namespace was +-- +-- foo = #foo +-- bar = #foo +-- +-- and the new namespace is +-- +-- foo = #baz +-- bar = #qux +-- +-- then (foo, bar) is a conflicted alias. +findConflictedAlias :: + forall name synhashed term typ. + (Ord name, forall ref. Eq (synhashed ref), Ord term, Ord typ) => + Defns (BiMultimap term name) (BiMultimap typ name) -> + DefnsF3 (Map name) DiffOp synhashed term typ -> + Maybe (Defn (name, name) (name, name)) +findConflictedAlias defns diff = + asum [TermDefn <$> go defns.terms diff.terms, TypeDefn <$> go defns.types diff.types] + where + go :: + forall ref. + (Eq (synhashed ref), Ord ref) => + BiMultimap ref name -> + Map name (DiffOp (synhashed ref)) -> + Maybe (name, name) + go namespace diff = + asum (map f (Map.toList diff)) + where + f :: (name, DiffOp (synhashed ref)) -> Maybe (name, name) + f (name, op) = + case op of + DiffOp'Add _ -> Nothing + DiffOp'Delete _ -> Nothing + DiffOp'Update hashed1 -> + BiMultimap.lookupPreimage name namespace + & Set.delete name + & Set.toList + & map (g hashed1.new) + & asum + where + g :: synhashed ref -> name -> Maybe (name, name) + g hashed1 alias = + case Map.lookup alias diff of + Just (DiffOp'Update hashed2) | hashed1 == hashed2.new -> Nothing + -- If "foo" was updated but its alias "bar" was deleted, that's ok + Just (DiffOp'Delete _) -> Nothing + _ -> Just (name, alias) diff --git a/unison-merge/src/Unison/Merge/Libdeps.hs b/unison-merge/src/Unison/Merge/Libdeps.hs index 61b5754417..ec0b9899d4 100644 --- a/unison-merge/src/Unison/Merge/Libdeps.hs +++ b/unison-merge/src/Unison/Merge/Libdeps.hs @@ -1,6 +1,9 @@ -- | An API for merging together two collections of library dependencies. module Unison.Merge.Libdeps - ( mergeLibdeps, + ( LibdepDiffOp (..), + diffLibdeps, + applyLibdepsDiff, + getTwoFreshLibdepNames, ) where @@ -16,37 +19,35 @@ import Unison.Merge.TwoDiffOps (TwoDiffOps (..)) import Unison.Merge.TwoDiffOps qualified as TwoDiffOps import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Merge.Updated (Updated (..)) +import Unison.NameSegment.Internal (NameSegment (NameSegment)) +import Unison.NameSegment.Internal qualified as NameSegment import Unison.Prelude hiding (catMaybes) import Unison.Util.Map qualified as Map import Witherable (catMaybes) --- | Perform a three-way merge on two collections of library dependencies. -mergeLibdeps :: - forall k v. +------------------------------------------------------------------------------------------------------------------------ +-- Diffing libdeps + +data LibdepDiffOp a + = AddLibdep !a + | AddBothLibdeps !a !a + | DeleteLibdep + +-- | Perform a three-way diff on two collections of library dependencies. +diffLibdeps :: (Ord k, Eq v) => - -- | Freshen a name, e.g. "base" -> ("base__4", "base__5"). - (Set k -> k -> (k, k)) -> -- | Library dependencies. ThreeWay (Map k v) -> - -- | Merged library dependencies. - Map k v -mergeLibdeps freshen libdeps = - mergeDiffs (diff libdeps.lca libdeps.alice) (diff libdeps.lca libdeps.bob) - & applyDiff (freshen usedNames) libdeps.lca - where - usedNames :: Set k - usedNames = - Set.unions - [ Map.keysSet libdeps.lca, - Map.keysSet libdeps.alice, - Map.keysSet libdeps.bob - ] + -- | Library dependencies diff. + Map k (LibdepDiffOp v) +diffLibdeps libdeps = + mergeDiffs (twoWayDiff libdeps.lca libdeps.alice) (twoWayDiff libdeps.lca libdeps.bob) --- `diff old new` computes a diff between old thing `old` and new thing `new`. +-- `twoWayDiff old new` computes a diff between old thing `old` and new thing `new`. -- -- Values present in `old` but not `new` are tagged as "deleted"; similar for "added" and "updated". -diff :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (DiffOp v) -diff = +twoWayDiff :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (DiffOp v) +twoWayDiff = Map.merge (Map.mapMissing \_ -> DiffOp'Delete) (Map.mapMissing \_ -> DiffOp'Add) @@ -72,11 +73,11 @@ mergeDiffs :: mergeDiffs alice bob = catMaybes (alignWith combineDiffOps alice bob) -combineDiffOps :: Eq a => These (DiffOp a) (DiffOp a) -> Maybe (LibdepDiffOp a) +combineDiffOps :: (Eq a) => These (DiffOp a) (DiffOp a) -> Maybe (LibdepDiffOp a) combineDiffOps = TwoDiffOps.make >>> combineDiffOps1 -combineDiffOps1 :: Eq a => TwoDiffOps a -> Maybe (LibdepDiffOp a) +combineDiffOps1 :: (Eq a) => TwoDiffOps a -> Maybe (LibdepDiffOp a) combineDiffOps1 = \case TwoDiffOps'Add new -> Just (AddLibdep (EitherWay.value new)) -- If Alice deletes a dep and Bob doesn't touch it, ignore the delete, since Bob may still be using it. @@ -97,20 +98,23 @@ combineDiffOps1 = \case | alice == bob -> Just (AddLibdep alice) | otherwise -> Just (AddBothLibdeps alice bob) +------------------------------------------------------------------------------------------------------------------------ +-- Applying libdeps diff + -- Apply a library dependencies diff to the LCA. -applyDiff :: +applyLibdepsDiff :: forall k v. (Ord k) => - -- Freshen a name, e.g. "base" -> ("base__4", "base__5") - (k -> (k, k)) -> - -- The LCA library dependencies. - Map k v -> - -- LCA->Alice+Bob library dependencies diff. + -- | Freshen a name, e.g. "base" -> ("base__4", "base__5"). + (Set k -> k -> (k, k)) -> + -- | Library dependencies. + ThreeWay (Map k v) -> + -- | Library dependencies diff. Map k (LibdepDiffOp v) -> - -- The merged library dependencies. + -- | Merged library dependencies. Map k v -applyDiff freshen = - Map.mergeMap Map.singleton f (\name _ -> f name) +applyLibdepsDiff freshen0 libdeps = + Map.mergeMap Map.singleton f (\name _ -> f name) libdeps.lca where f :: k -> LibdepDiffOp v -> Map k v f k = \case @@ -120,7 +124,48 @@ applyDiff freshen = in Map.fromList [(k1, v1), (k2, v2)] DeleteLibdep -> Map.empty -data LibdepDiffOp a - = AddLibdep !a - | AddBothLibdeps !a !a - | DeleteLibdep + freshen :: k -> (k, k) + freshen = + freshen0 $ + Set.unions + [ Map.keysSet libdeps.lca, + Map.keysSet libdeps.alice, + Map.keysSet libdeps.bob + ] + +------------------------------------------------------------------------------------------------------------------------ +-- Getting fresh libdeps names + +-- Given a name like "base", try "base__1", then "base__2", etc, until we find a name that doesn't +-- clash with any existing dependencies. +getTwoFreshLibdepNames :: Set NameSegment -> NameSegment -> (NameSegment, NameSegment) +getTwoFreshLibdepNames names name0 = + go2 0 + where + -- if + -- name0 = "base" + -- names = {"base__5", "base__6"} + -- then + -- go2 4 = ("base__4", "base__7") + go2 :: Integer -> (NameSegment, NameSegment) + go2 !i + | Set.member name names = go2 (i + 1) + | otherwise = (name, go1 (i + 1)) + where + name = mangled i + + -- if + -- name0 = "base" + -- names = {"base__5", "base__6"} + -- then + -- go1 5 = "base__7" + go1 :: Integer -> NameSegment + go1 !i + | Set.member name names = go1 (i + 1) + | otherwise = name + where + name = mangled i + + mangled :: Integer -> NameSegment + mangled i = + NameSegment (NameSegment.toUnescapedText name0 <> "__" <> tShow i) diff --git a/unison-merge/src/Unison/Merge/Mergeblob0.hs b/unison-merge/src/Unison/Merge/Mergeblob0.hs new file mode 100644 index 0000000000..97fea83cac --- /dev/null +++ b/unison-merge/src/Unison/Merge/Mergeblob0.hs @@ -0,0 +1,32 @@ +module Unison.Merge.Mergeblob0 + ( Mergeblob0 (..), + makeMergeblob0, + ) +where + +import Unison.Merge.ThreeWay (ThreeWay) +import Unison.Name (Name) +import Unison.NameSegment (NameSegment) +import Unison.Prelude +import Unison.Reference (TypeReference) +import Unison.Referent (Referent) +import Unison.Util.BiMultimap (BiMultimap) +import Unison.Util.Defns (Defns, DefnsF) +import Unison.Util.Nametree (Nametree, flattenNametrees) + +data Mergeblob0 libdep = Mergeblob0 + { defns :: ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)), + libdeps :: ThreeWay (Map NameSegment libdep), + nametrees :: ThreeWay (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) + } + +makeMergeblob0 :: + ThreeWay (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> + ThreeWay (Map NameSegment libdep) -> + Mergeblob0 libdep +makeMergeblob0 nametrees libdeps = + Mergeblob0 + { defns = flattenNametrees <$> nametrees, + libdeps, + nametrees + } diff --git a/unison-merge/src/Unison/Merge/Mergeblob1.hs b/unison-merge/src/Unison/Merge/Mergeblob1.hs new file mode 100644 index 0000000000..aef0ec7973 --- /dev/null +++ b/unison-merge/src/Unison/Merge/Mergeblob1.hs @@ -0,0 +1,143 @@ +module Unison.Merge.Mergeblob1 + ( Mergeblob1 (..), + makeMergeblob1, + ) +where + +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Unison.DataDeclaration (Decl) +import Unison.DataDeclaration qualified as DataDeclaration +import Unison.DeclNameLookup (DeclNameLookup) +import Unison.Merge.CombineDiffs (CombinedDiffOp, combineDiffs) +import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason, checkDeclCoherency, lenientCheckDeclCoherency) +import Unison.Merge.Diff (nameBasedNamespaceDiff) +import Unison.Merge.DiffOp (DiffOp) +import Unison.Merge.EitherWay (EitherWay (..)) +import Unison.Merge.Libdeps (LibdepDiffOp, applyLibdepsDiff, diffLibdeps, getTwoFreshLibdepNames) +import Unison.Merge.Mergeblob0 (Mergeblob0 (..)) +import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup) +import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs) +import Unison.Merge.Synhashed (Synhashed) +import Unison.Merge.ThreeWay (ThreeWay) +import Unison.Merge.ThreeWay qualified as ThreeWay +import Unison.Merge.TwoWay (TwoWay (..)) +import Unison.Merge.Unconflicts (Unconflicts) +import Unison.Name (Name) +import Unison.NameSegment (NameSegment) +import Unison.Parser.Ann (Ann) +import Unison.Prelude +import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId) +import Unison.Referent (Referent) +import Unison.Symbol (Symbol) +import Unison.Term (Term) +import Unison.Type (Type) +import Unison.Util.BiMultimap (BiMultimap) +import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3) + +data Mergeblob1 libdep = Mergeblob1 + { conflicts :: TwoWay (DefnsF (Map Name) TermReference TypeReference), + declNameLookups :: TwoWay DeclNameLookup, + defns :: ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)), + diff :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference, + diffs :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference), + hydratedDefns :: + ThreeWay + ( DefnsF + (Map Name) + (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) + (TypeReferenceId, Decl Symbol Ann) + ), + lcaDeclNameLookup :: PartialDeclNameLookup, + libdeps :: Map NameSegment libdep, + libdepsDiff :: Map NameSegment (LibdepDiffOp libdep), + lcaLibdeps :: Map NameSegment libdep, + unconflicts :: DefnsF Unconflicts Referent TypeReference + } + +makeMergeblob1 :: + forall libdep. + (Eq libdep) => + Mergeblob0 libdep -> + ThreeWay + ( DefnsF + (Map Name) + (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) + (TypeReferenceId, Decl Symbol Ann) + ) -> + Either (EitherWay IncoherentDeclReason) (Mergeblob1 libdep) +makeMergeblob1 blob hydratedDefns = do + -- Make one big constructor count lookup for all type decls + let numConstructors = + Map.empty + & f (Map.elems hydratedDefns.alice.types) + & f (Map.elems hydratedDefns.bob.types) + & f (Map.elems hydratedDefns.lca.types) + where + f :: [(TypeReferenceId, Decl Symbol Ann)] -> Map TypeReferenceId Int -> Map TypeReferenceId Int + f types acc = + List.foldl' + ( \acc (ref, decl) -> + Map.insert ref (DataDeclaration.constructorCount (DataDeclaration.asDataDecl decl)) acc + ) + acc + types + + -- Make Alice/Bob decl name lookups, which can fail if either have an incoherent decl + declNameLookups <- do + alice <- checkDeclCoherency blob.nametrees.alice numConstructors & mapLeft Alice + bob <- checkDeclCoherency blob.nametrees.bob numConstructors & mapLeft Bob + pure TwoWay {alice, bob} + + -- Make LCA decl name lookup + let lcaDeclNameLookup = + lenientCheckDeclCoherency blob.nametrees.lca numConstructors + + -- Diff LCA->Alice and LCA->Bob + let diffs = + nameBasedNamespaceDiff + declNameLookups + lcaDeclNameLookup + blob.defns + Defns + { terms = + foldMap + (List.foldl' (\acc (ref, (term, _)) -> Map.insert ref term acc) Map.empty . Map.elems . (.terms)) + hydratedDefns, + types = + foldMap + (List.foldl' (\acc (ref, typ) -> Map.insert ref typ acc) Map.empty . Map.elems . (.types)) + hydratedDefns + } + + -- Combine the LCA->Alice and LCA->Bob diffs together + let diff = + combineDiffs diffs + + -- Partition the combined diff into the conflicted things and the unconflicted things + let (conflicts, unconflicts) = + partitionCombinedDiffs (ThreeWay.forgetLca blob.defns) declNameLookups diff + + -- Diff and merge libdeps + let libdepsDiff :: Map NameSegment (LibdepDiffOp libdep) + libdepsDiff = + diffLibdeps blob.libdeps + + let libdeps :: Map NameSegment libdep + libdeps = + applyLibdepsDiff getTwoFreshLibdepNames blob.libdeps libdepsDiff + + pure + Mergeblob1 + { conflicts, + declNameLookups, + defns = blob.defns, + diff, + diffs, + hydratedDefns, + lcaDeclNameLookup, + libdeps, + libdepsDiff, + lcaLibdeps = blob.libdeps.lca, + unconflicts + } diff --git a/unison-merge/src/Unison/Merge/Mergeblob2.hs b/unison-merge/src/Unison/Merge/Mergeblob2.hs new file mode 100644 index 0000000000..629d8d2146 --- /dev/null +++ b/unison-merge/src/Unison/Merge/Mergeblob2.hs @@ -0,0 +1,145 @@ +module Unison.Merge.Mergeblob2 + ( Mergeblob2 (..), + Mergeblob2Error (..), + makeMergeblob2, + ) +where + +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Unison.ConstructorReference (GConstructorReference (..)) +import Unison.DataDeclaration (Decl) +import Unison.DeclNameLookup (DeclNameLookup) +import Unison.Merge.EitherWay (EitherWay (..)) +import Unison.Merge.FindConflictedAlias (findConflictedAlias) +import Unison.Merge.Mergeblob1 (Mergeblob1 (..)) +import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup) +import Unison.Merge.PartitionCombinedDiffs (narrowConflictsToNonBuiltins) +import Unison.Merge.ThreeWay (ThreeWay) +import Unison.Merge.ThreeWay qualified as ThreeWay +import Unison.Merge.TwoWay (TwoWay (..)) +import Unison.Merge.TwoWay qualified as TwoWay +import Unison.Merge.Unconflicts (Unconflicts) +import Unison.Merge.Unconflicts qualified as Unconflicts +import Unison.Name (Name) +import Unison.NameSegment (NameSegment) +import Unison.Parser.Ann (Ann) +import Unison.Prelude +import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId) +import Unison.Reference qualified as Reference +import Unison.Referent (Referent) +import Unison.Referent qualified as Referent +import Unison.Symbol (Symbol) +import Unison.Term (Term) +import Unison.Type (Type) +import Unison.Util.BiMultimap (BiMultimap) +import Unison.Util.BiMultimap qualified as BiMultimap +import Unison.Util.Defn (Defn) +import Unison.Util.Defns (Defns (..), DefnsF, defnsAreEmpty, zipDefnsWith) + +data Mergeblob2 libdep = Mergeblob2 + { conflicts :: TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId), + coreDependencies :: TwoWay (DefnsF Set TermReference TypeReference), + declNameLookups :: TwoWay DeclNameLookup, + defns :: ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)), + hasConflicts :: Bool, + hydratedDefns :: + ThreeWay + ( DefnsF + (Map Name) + (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) + (TypeReferenceId, Decl Symbol Ann) + ), + lcaDeclNameLookup :: PartialDeclNameLookup, + lcaLibdeps :: Map NameSegment libdep, + libdeps :: Map NameSegment libdep, + soloUpdatesAndDeletes :: TwoWay (DefnsF Set Name Name), + unconflicts :: DefnsF Unconflicts Referent TypeReference + } + +data Mergeblob2Error + = Mergeblob2Error'ConflictedAlias (EitherWay (Defn (Name, Name) (Name, Name))) + | Mergeblob2Error'ConflictedBuiltin (Defn Name Name) + +makeMergeblob2 :: Mergeblob1 libdep -> Either Mergeblob2Error (Mergeblob2 libdep) +makeMergeblob2 blob = do + -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias + for_ ((,) <$> TwoWay Alice Bob <*> blob.diffs) \(who, diff) -> + whenJust (findConflictedAlias blob.defns.lca diff) $ + Left . Mergeblob2Error'ConflictedAlias . who + + conflicts <- narrowConflictsToNonBuiltins blob.conflicts & mapLeft Mergeblob2Error'ConflictedBuiltin + + let soloUpdatesAndDeletes :: TwoWay (DefnsF Set Name Name) + soloUpdatesAndDeletes = + Unconflicts.soloUpdatesAndDeletes blob.unconflicts + + let coreDependencies :: TwoWay (DefnsF Set TermReference TypeReference) + coreDependencies = + identifyCoreDependencies + (ThreeWay.forgetLca blob.defns) + (bimap (Set.fromList . Map.elems) (Set.fromList . Map.elems) <$> conflicts) + soloUpdatesAndDeletes + + pure + Mergeblob2 + { conflicts, + coreDependencies, + declNameLookups = blob.declNameLookups, + defns = blob.defns, + -- Eh, they'd either both be null, or neither, but just check both maps anyway + hasConflicts = not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob), + hydratedDefns = blob.hydratedDefns, + lcaDeclNameLookup = blob.lcaDeclNameLookup, + lcaLibdeps = blob.lcaLibdeps, + libdeps = blob.libdeps, + soloUpdatesAndDeletes, + unconflicts = blob.unconflicts + } + +identifyCoreDependencies :: + TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> + TwoWay (DefnsF Set TermReferenceId TypeReferenceId) -> + TwoWay (DefnsF Set Name Name) -> + TwoWay (DefnsF Set TermReference TypeReference) +identifyCoreDependencies defns conflicts soloUpdatesAndDeletes = do + fold + [ -- One source of dependencies: Alice's versions of Bob's unconflicted deletes and updates, and vice-versa. + -- + -- This is name-based: if Bob updates the *name* "foo", then we go find the thing that Alice calls "foo" (if + -- anything), no matter what its hash is. + defnsReferences + <$> ( zipDefnsWith BiMultimap.restrictRan BiMultimap.restrictRan + <$> TwoWay.swap soloUpdatesAndDeletes + <*> defns + ), + -- The other source of dependencies: Alice's own conflicted things, and ditto for Bob. + -- + -- An example: suppose Alice has foo#alice and Bob has foo#bob, so foo is conflicted. Furthermore, suppose + -- Alice has bar#bar that depends on foo#alice. + -- + -- We want Alice's #alice to be considered a dependency, so that when we go off and find dependents of these + -- dependencies to put in the scratch file for type checking and propagation, we find bar#bar. + -- + -- Note that this is necessary even if bar#bar is unconflicted! We don't want bar#bar to be put directly + -- into the namespace / parsing context for the conflicted merge, because it has an unnamed reference on + -- foo#alice. It rather ought to be in the scratchfile alongside the conflicted foo#alice and foo#bob, so + -- that when that conflict is resolved, it will propagate to bar. + bimap (Set.map Reference.DerivedId) (Set.map Reference.DerivedId) <$> conflicts + ] + +defnsReferences :: + Defns (BiMultimap Referent name) (BiMultimap TypeReference name) -> + DefnsF Set TermReference TypeReference +defnsReferences defns = + List.foldl' f Defns {terms = Set.empty, types = BiMultimap.dom defns.types} (Set.toList (BiMultimap.dom defns.terms)) + where + f :: DefnsF Set TermReference TypeReference -> Referent -> DefnsF Set TermReference TypeReference + f acc = \case + Referent.Con (ConstructorReference ref _) _ -> + let !types = Set.insert ref acc.types + in Defns {terms = acc.terms, types} + Referent.Ref ref -> + let !terms = Set.insert ref acc.terms + in Defns {terms, types = acc.types} diff --git a/unison-merge/src/Unison/Merge/Mergeblob3.hs b/unison-merge/src/Unison/Merge/Mergeblob3.hs new file mode 100644 index 0000000000..dfb6a795f6 --- /dev/null +++ b/unison-merge/src/Unison/Merge/Mergeblob3.hs @@ -0,0 +1,516 @@ +module Unison.Merge.Mergeblob3 + ( Mergeblob3 (..), + makeMergeblob3, + ) +where + +import Control.Lens (mapped) +import Data.Align (align) +import Data.Bifoldable (bifoldMap) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Set.NonEmpty (NESet) +import Data.Set.NonEmpty qualified as Set.NonEmpty +import Data.Text qualified as Text +import Data.These (These (..)) +import Data.Zip (unzip) +import Unison.DataDeclaration (Decl) +import Unison.DataDeclaration qualified as DataDeclaration +import Unison.DeclNameLookup (DeclNameLookup (..), expectConstructorNames) +import Unison.DeclNameLookup qualified as DeclNameLookup +import Unison.Merge.Mergeblob2 (Mergeblob2 (..)) +import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup (..)) +import Unison.Merge.ThreeWay (ThreeWay (..)) +import Unison.Merge.ThreeWay qualified as ThreeWay +import Unison.Merge.TwoWay (TwoWay) +import Unison.Merge.TwoWay qualified as TwoWay +import Unison.Merge.Unconflicts (Unconflicts) +import Unison.Merge.Unconflicts qualified as Unconflicts +import Unison.Name (Name) +import Unison.Names (Names (..)) +import Unison.Names qualified as Names +import Unison.Parser.Ann (Ann) +import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl) +import Unison.PrettyPrintEnvDecl.Names qualified as PPED +import Unison.Reference (Reference' (..), TermReferenceId, TypeReference, TypeReferenceId) +import Unison.Referent (Referent) +import Unison.Referent qualified as Referent +import Unison.Symbol (Symbol) +import Unison.Syntax.FilePrinter (renderDefnsForUnisonFile) +import Unison.Syntax.Name qualified as Name +import Unison.Term (Term) +import Unison.Type (Type) +import Unison.Util.BiMultimap (BiMultimap) +import Unison.Util.BiMultimap qualified as BiMultimap +import Unison.Util.Defns (Defns (..), DefnsF, defnsAreEmpty, zipDefnsWith, zipDefnsWith3, zipDefnsWith4) +import Unison.Util.Pretty (ColorText, Pretty) +import Unison.Util.Pretty qualified as Pretty +import Unison.Util.Relation qualified as Relation +import Prelude hiding (unzip) + +data Mergeblob3 = Mergeblob3 + { libdeps :: Names, + stageOne :: DefnsF (Map Name) Referent TypeReference, + stageTwo :: DefnsF (Map Name) Referent TypeReference, + uniqueTypeGuids :: Map Name Text, + -- `unparsedFile` (no mergetool) xor `unparsedSoloFiles` (yes mergetool) are ultimately given to the user + unparsedFile :: Pretty ColorText, + unparsedSoloFiles :: ThreeWay (Pretty ColorText) + } + +makeMergeblob3 :: + Mergeblob2 libdep -> + TwoWay (DefnsF Set TermReferenceId TypeReferenceId) -> + Names -> + Names -> + TwoWay Text -> + Mergeblob3 +makeMergeblob3 blob dependents0 libdeps lcaLibdeps authors = + let conflictsNames :: TwoWay (DefnsF Set Name Name) + conflictsNames = + bimap Map.keysSet Map.keysSet <$> blob.conflicts + + -- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if + -- there aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are) + dependents :: TwoWay (DefnsF Set Name Name) + dependents = + filterDependents + conflictsNames + blob.soloUpdatesAndDeletes + ( let f :: Set TermReferenceId -> Referent -> NESet Name -> Set Name + f deps defn0 names + | Just defn <- Referent.toTermReferenceId defn0, + Set.member defn deps = + Set.NonEmpty.toSet names + | otherwise = Set.empty + g :: Set TypeReferenceId -> TypeReference -> NESet Name -> Set Name + g deps defn0 names + | ReferenceDerived defn <- defn0, + Set.member defn deps = + Set.NonEmpty.toSet names + | otherwise = Set.empty + in zipDefnsWith + (\defns deps -> Map.foldMapWithKey (f deps) (BiMultimap.domain defns)) + (\defns deps -> Map.foldMapWithKey (g deps) (BiMultimap.domain defns)) + <$> ThreeWay.forgetLca blob.defns + <*> dependents0 + ) + + ppe :: PrettyPrintEnvDecl + ppe = + makePrettyPrintEnv + (defnsToNames <$> blob.defns) + libdeps + lcaLibdeps + + renderedConflicts :: TwoWay (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)) + renderedDependents :: TwoWay (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)) + (renderedConflicts, renderedDependents) = + renderConflictsAndDependents + blob.declNameLookups + (ThreeWay.forgetLca blob.hydratedDefns) + conflictsNames + dependents + ppe + + renderedLcaConflicts :: DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText) + renderedLcaConflicts = + renderLcaConflicts + blob.lcaDeclNameLookup + blob.hydratedDefns.lca + conflictsNames + ppe + in Mergeblob3 + { libdeps, + stageOne = + makeStageOne + blob.declNameLookups + conflictsNames + blob.unconflicts + dependents + (bimap BiMultimap.range BiMultimap.range blob.defns.lca), + uniqueTypeGuids = makeUniqueTypeGuids (ThreeWay.forgetLca blob.hydratedDefns), + stageTwo = + makeStageTwo + blob.declNameLookups + conflictsNames + blob.unconflicts + dependents + (bimap BiMultimap.range BiMultimap.range <$> blob.defns), + unparsedFile = makePrettyUnisonFile authors renderedConflicts renderedDependents, + unparsedSoloFiles = + ThreeWay + { alice = renderedConflicts.alice, + bob = renderedConflicts.bob, + lca = renderedLcaConflicts + } + <&> \conflicts -> makePrettySoloUnisonFile conflicts renderedDependents + } + +filterDependents :: + (Ord name) => + TwoWay (DefnsF Set name name) -> + TwoWay (DefnsF Set name name) -> + TwoWay (DefnsF Set name name) -> + TwoWay (DefnsF Set name name) +filterDependents conflicts soloUpdatesAndDeletes dependents0 = + -- There is some subset of Alice's dependents (and ditto for Bob of course) that we don't ultimately want/need to put + -- into the scratch file: those for which any of the following are true: + -- + -- 1. It is Alice-conflicted (since we only want to return *unconflicted* things). + -- 2. It was deleted by Bob. + -- 3. It was updated by Bob and not updated by Alice. + let dependents1 = + zipDefnsWith Set.difference Set.difference + <$> dependents0 + <*> (conflicts <> TwoWay.swap soloUpdatesAndDeletes) + + -- Of the remaining dependents, it's still possible that the maps are not disjoint. But whenever the same name key + -- exists in Alice's and Bob's dependents, the value will either be equal (by Unison hash)... + -- + -- { alice = { terms = {"foo" => #alice} } } + -- { bob = { terms = {"foo" => #alice} } } + -- + -- ...or synhash-equal (i.e. the term or type received different auto-propagated updates)... + -- + -- { alice = { terms = {"foo" => #alice} } } + -- { bob = { terms = {"foo" => #bob} } } + -- + -- So, we can arbitrarily keep Alice's, because they will render the same. + -- + -- { alice = { terms = {"foo" => #alice} } } + -- { bob = { terms = {} } } + dependents2 = + dependents1 & over #bob \bob -> + zipDefnsWith Set.difference Set.difference bob dependents1.alice + in dependents2 + +makeStageOne :: + TwoWay DeclNameLookup -> + TwoWay (DefnsF Set Name Name) -> + DefnsF Unconflicts term typ -> + TwoWay (DefnsF Set Name Name) -> + DefnsF (Map Name) term typ -> + DefnsF (Map Name) term typ +makeStageOne declNameLookups conflicts unconflicts dependents = + zipDefnsWith3 makeStageOneV makeStageOneV unconflicts (f conflicts <> f dependents) + where + f :: TwoWay (DefnsF Set Name Name) -> DefnsF Set Name Name + f defns = + fold (refIdsToNames <$> declNameLookups <*> defns) + +makeStageOneV :: Unconflicts v -> Set Name -> Map Name v -> Map Name v +makeStageOneV unconflicts namesToDelete = + (`Map.withoutKeys` namesToDelete) . Unconflicts.apply unconflicts + +makeStageTwo :: + forall term typ. + TwoWay DeclNameLookup -> + TwoWay (DefnsF Set Name Name) -> + DefnsF Unconflicts term typ -> + TwoWay (DefnsF Set Name Name) -> + ThreeWay (DefnsF (Map Name) term typ) -> + DefnsF (Map Name) term typ +makeStageTwo declNameLookups conflicts unconflicts dependents defns = + zipDefnsWith4 makeStageTwoV makeStageTwoV defns.lca aliceBiasedDependents unconflicts aliceConflicts + where + aliceConflicts :: DefnsF (Map Name) term typ + aliceConflicts = + zipDefnsWith + (\defns conflicts -> Map.restrictKeys defns (conflicts <> aliceConstructorsOfTypeConflicts)) + Map.restrictKeys + defns.alice + conflicts.alice + + aliceConstructorsOfTypeConflicts :: Set Name + aliceConstructorsOfTypeConflicts = + foldMap + (Set.fromList . DeclNameLookup.expectConstructorNames declNameLookups.alice) + conflicts.alice.types + + aliceBiasedDependents :: DefnsF (Map Name) term typ + aliceBiasedDependents = + TwoWay.twoWay + (zipDefnsWith (Map.unionWith const) (Map.unionWith const)) + (zipDefnsWith Map.restrictKeys Map.restrictKeys <$> ThreeWay.forgetLca defns <*> dependents) + +makeStageTwoV :: Map Name v -> Map Name v -> Unconflicts v -> Map Name v -> Map Name v +makeStageTwoV lca dependents unconflicts conflicts = + Map.unionWith const conflicts (Unconflicts.apply unconflicts (Map.unionWith const dependents lca)) + +-- Given just named term/type reference ids, fill out all names that occupy the term and type namespaces. This is simply +-- the given names plus all of the types' constructors. +-- +-- For example, if the input is +-- +-- declNameLookup = { +-- "Maybe" => ["Maybe.Nothing", "Maybe.Just"] +-- } +-- defns = { +-- terms = { "foo" => #foo } +-- types = { "Maybe" => #Maybe } +-- } +-- +-- then the output is +-- +-- defns = { +-- terms = { "foo", "Maybe.Nothing", "Maybe.Just" } +-- types = { "Maybe" } +-- } +refIdsToNames :: DeclNameLookup -> DefnsF Set Name Name -> DefnsF Set Name Name +refIdsToNames declNameLookup = + bifoldMap goTerms goTypes + where + goTerms :: Set Name -> DefnsF Set Name Name + goTerms terms = + Defns {terms, types = Set.empty} + + goTypes :: Set Name -> DefnsF Set Name Name + goTypes types = + Defns + { terms = foldMap (Set.fromList . expectConstructorNames declNameLookup) types, + types + } + +renderConflictsAndDependents :: + TwoWay DeclNameLookup -> + TwoWay (DefnsF (Map Name) (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) (TypeReferenceId, Decl Symbol Ann)) -> + TwoWay (DefnsF Set Name Name) -> + TwoWay (DefnsF Set Name Name) -> + PrettyPrintEnvDecl -> + ( TwoWay (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)), + TwoWay (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)) + ) +renderConflictsAndDependents declNameLookups hydratedDefns conflicts dependents ppe = + unzip $ + ( \declNameLookup (conflicts, dependents) -> + let render = renderDefnsForUnisonFile declNameLookup ppe . over (#terms . mapped) snd + in (render conflicts, render dependents) + ) + <$> declNameLookups + <*> hydratedConflictsAndDependents + where + hydratedConflictsAndDependents :: + TwoWay + ( DefnsF (Map Name) (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) (TypeReferenceId, Decl Symbol Ann), + DefnsF (Map Name) (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) (TypeReferenceId, Decl Symbol Ann) + ) + hydratedConflictsAndDependents = + ( \as bs cs -> + ( zipDefnsWith Map.restrictKeys Map.restrictKeys as bs, + zipDefnsWith Map.restrictKeys Map.restrictKeys as cs + ) + ) + <$> hydratedDefns + <*> conflicts + <*> dependents + +renderLcaConflicts :: + PartialDeclNameLookup -> + DefnsF (Map Name) (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) (TypeReferenceId, Decl Symbol Ann) -> + TwoWay (DefnsF Set Name Name) -> + PrettyPrintEnvDecl -> + DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText) +renderLcaConflicts partialDeclNameLookup hydratedDefns conflicts ppe = + let hydratedConflicts = zipDefnsWith Map.restrictKeys Map.restrictKeys hydratedDefns (fold conflicts) + in renderDefnsForUnisonFile declNameLookup ppe (over (#terms . mapped) snd hydratedConflicts) + where + -- We allow the LCA of a merge to have missing constructor names, yet we do need to render *something* in a file + -- for a mergetool (if one is configured). So, we make the partial decl name lookup total by making bogus + -- constructor names as necessary. + declNameLookup :: DeclNameLookup + declNameLookup = + DeclNameLookup + { constructorToDecl = partialDeclNameLookup.constructorToDecl, + declToConstructors = + makeTotal <$> partialDeclNameLookup.declToConstructors + } + where + makeTotal :: [Maybe Name] -> [Name] + makeTotal names0 = + case sequence names0 of + Just names -> names + Nothing -> + snd $ + List.mapAccumL + makeSomethingUp + (foldMap (maybe Set.empty Set.singleton) names0) + names0 + where + makeSomethingUp :: Set Name -> Maybe Name -> (Set Name, Name) + makeSomethingUp taken = \case + Just name -> (taken, name) + Nothing -> + let name = freshen 0 "Unnamed" + !taken1 = Set.insert name taken + in (taken1, name) + where + freshen :: Int -> Text -> Name + freshen i name0 + | Set.member name taken = freshen (i + 1) name0 + | otherwise = name + where + name :: Name + name = + Name.unsafeParseText (name0 <> if i == 0 then Text.empty else Text.pack (show i)) + +-- Create a PPE that uses Alice's names whenever possible, falling back to Bob's names only when Alice doesn't have any, +-- and falling back to the LCA after that. +-- +-- This results in a file that "looks familiar" to Alice (the one merging in Bob's changes), and avoids superfluous +-- textual conflicts that would arise from preferring Bob's names for Bob's code (where his names differ). +-- +-- The LCA names are not used unless we need to render LCA definitions for a mergetool, but we add them to the PPE in +-- all cases anyway. If this is very expensive, we could consider omitting them in the case that no mergetool is +-- configured. +-- +-- Note that LCA names can make name quality slightly worse. For example, "foo.bar" might exist in the LCA, but deleted +-- in Alice and Bob, and nonetheless prevent some "qux.bar" from rendering as "bar". That seems fine. +makePrettyPrintEnv :: ThreeWay Names -> Names -> Names -> PrettyPrintEnvDecl +makePrettyPrintEnv names libdepsNames lcaLibdeps = + PPED.makePPED + ( PPE.namer + ( Names.preferring + (Names.preferring names.alice names.bob <> libdepsNames) + (names.lca <> lcaLibdeps) + ) + ) + (PPE.suffixifyByName (fold names <> libdepsNames)) + +defnsToNames :: Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> Names +defnsToNames defns = + Names + { terms = Relation.fromMap (BiMultimap.range defns.terms), + types = Relation.fromMap (BiMultimap.range defns.types) + } + +makePrettyUnisonFile :: + TwoWay Text -> + TwoWay (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)) -> + TwoWay (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)) -> + Pretty ColorText +makePrettyUnisonFile authors conflicts dependents = + fold + [ conflicts + -- Merge the two maps together into one, remembering who authored what + & TwoWay.twoWay (zipDefnsWith align align) + -- Sort alphabetically + & inAlphabeticalOrder + -- Render each conflict, types then terms (even though a type can conflict with a term, in which case they + -- would not be adjacent in the file), with an author comment above each conflicted thing + & ( let f = + foldMap \case + This x -> alice x + That y -> bob y + These x y -> alice x <> bob y + where + alice = prettyBinding (Just (Pretty.text authors.alice)) + bob = prettyBinding (Just (Pretty.text authors.bob)) + in bifoldMap f f + ), + -- Show message that delineates where conflicts end and dependents begin only when there are both conflicts and + -- dependents + let thereAre defns = TwoWay.or (not . defnsAreEmpty <$> defns) + in if thereAre conflicts && thereAre dependents + then + fold + [ "-- The definitions below are not conflicted, but they each depend on one or more\n", + "-- conflicted definitions above.\n\n" + ] + else mempty, + makePrettyDependents dependents + ] + where + prettyBinding maybeComment binding = + fold + [ case maybeComment of + Nothing -> mempty + Just comment -> "-- " <> comment <> "\n", + binding, + "\n\n" + ] + +makePrettySoloUnisonFile :: + DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText) -> + TwoWay (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)) -> + Pretty ColorText +makePrettySoloUnisonFile conflicts dependents = + fold + [ conflicts + & inAlphabeticalOrder + & let f = foldMap (<> "\n\n") in bifoldMap f f, + -- Show message that delineates where conflicts end and dependents begin only when there are both conflicts and + -- dependents + if not (defnsAreEmpty conflicts) && TwoWay.or (not . defnsAreEmpty <$> dependents) + then + fold + [ "-- The definitions below are not conflicted, but they each depend on one or more\n", + "-- conflicted definitions.\n\n" + ] + else mempty, + -- Include all dependents when invoking this function with alice/bob/lca conflicts, because we don't want any diff + -- here – we want the mergetool to copy over all dependents after resolving the real conflicts above the fold. + makePrettyDependents dependents + ] + +makePrettyDependents :: TwoWay (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)) -> Pretty ColorText +makePrettyDependents = + -- Merge dependents together into one map (they are disjoint) + TwoWay.twoWay (zipDefnsWith Map.union Map.union) + >>> + -- Sort alphabetically + inAlphabeticalOrder + -- Render each dependent, types then terms, without bothering to comment attribution + >>> (let f = foldMap (<> "\n\n") in bifoldMap f f) + +inAlphabeticalOrder :: DefnsF (Map Name) a b -> DefnsF [] a b +inAlphabeticalOrder = + bimap f f + where + f = map snd . List.sortOn (Name.toText . fst) . Map.toList + +-- Given Alice's and Bob's hydrated defns, make a mapping from unique type name to unique type GUID, preferring Alice's +-- GUID if they both have one. +makeUniqueTypeGuids :: + TwoWay + ( DefnsF + (Map Name) + (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) + (TypeReferenceId, Decl Symbol Ann) + ) -> + Map Name Text +makeUniqueTypeGuids hydratedDefns = + let -- Start off with just Alice's GUIDs + aliceGuids :: Map Name Text + aliceGuids = + Map.mapMaybe (declGuid . snd) hydratedDefns.alice.types + + -- Define a helper that adds a Bob GUID only if it's not already in the map (so, preferring Alice) + addBobGuid :: Map Name Text -> (Name, (TypeReferenceId, Decl Symbol Ann)) -> Map Name Text + addBobGuid acc (name, (_, bobDecl)) = + Map.alter + ( \case + Nothing -> bobGuid + Just aliceGuid -> Just aliceGuid + ) + name + acc + where + bobGuid :: Maybe Text + bobGuid = + declGuid bobDecl + + -- Tumble in all of Bob's GUIDs with that helper + allTheGuids :: Map Name Text + allTheGuids = + List.foldl' addBobGuid aliceGuids (Map.toList hydratedDefns.bob.types) + in allTheGuids + where + declGuid :: Decl v a -> Maybe Text + declGuid decl = + case (DataDeclaration.asDataDecl decl).modifier of + DataDeclaration.Structural -> Nothing + DataDeclaration.Unique guid -> Just guid diff --git a/unison-merge/src/Unison/Merge/Mergeblob4.hs b/unison-merge/src/Unison/Merge/Mergeblob4.hs new file mode 100644 index 0000000000..fa8f8f0e61 --- /dev/null +++ b/unison-merge/src/Unison/Merge/Mergeblob4.hs @@ -0,0 +1,49 @@ +module Unison.Merge.Mergeblob4 + ( Mergeblob4 (..), + makeMergeblob4, + ) +where + +import Data.Map.Strict qualified as Map +import Unison.Merge.Mergeblob3 (Mergeblob3 (..)) +import Unison.Names (Names (..)) +import Unison.Parser.Ann (Ann) +import Unison.Parsers qualified as Parsers +import Unison.Prelude +import Unison.Reference (TermReference, TypeReference) +import Unison.Symbol (Symbol) +import Unison.Syntax.Parser (ParsingEnv (..)) +import Unison.Syntax.Parser qualified as Parser +import Unison.UnisonFile (UnisonFile) +import Unison.UnisonFile qualified as UnisonFile +import Unison.Util.Defns (Defns (..), DefnsF) +import Unison.Util.Pretty qualified as Pretty +import Unison.Util.Relation qualified as Relation + +data Mergeblob4 = Mergeblob4 + { dependencies :: DefnsF Set TermReference TypeReference, + file :: UnisonFile Symbol Ann + } + +makeMergeblob4 :: Mergeblob3 -> Either (Parser.Err Symbol) Mergeblob4 +makeMergeblob4 blob = do + let stageOneNames = + Names (Relation.fromMap blob.stageOne.terms) (Relation.fromMap blob.stageOne.types) <> blob.libdeps + + parsingEnv = + ParsingEnv + { -- We don't expect to have to generate any new GUIDs, since the uniqueTypeGuid lookup function below should + -- cover all name in the merged file we're about to parse and typecheck. So, this might be more correct as a + -- call to `error`. + uniqueNames = Parser.UniqueName \_ _ -> Nothing, + uniqueTypeGuid = \name -> Identity (Map.lookup name blob.uniqueTypeGuids), + names = stageOneNames, + maybeNamespace = Nothing, + localNamespacePrefixedTypesAndConstructors = mempty + } + file <- runIdentity (Parsers.parseFile "" (Pretty.toPlain 80 blob.unparsedFile) parsingEnv) + Right + Mergeblob4 + { dependencies = UnisonFile.dependencies file, + file + } diff --git a/unison-merge/src/Unison/Merge/Mergeblob5.hs b/unison-merge/src/Unison/Merge/Mergeblob5.hs new file mode 100644 index 0000000000..4390c74838 --- /dev/null +++ b/unison-merge/src/Unison/Merge/Mergeblob5.hs @@ -0,0 +1,33 @@ +module Unison.Merge.Mergeblob5 + ( Mergeblob5 (..), + makeMergeblob5, + ) +where + +import Data.Map.Strict qualified as Map +import Unison.FileParsers qualified as FileParsers +import Unison.Merge.Mergeblob4 (Mergeblob4 (..)) +import Unison.Parser.Ann (Ann) +import Unison.Prelude +import Unison.Result qualified as Result +import Unison.Symbol (Symbol) +import Unison.Typechecker qualified as Typechecker +import Unison.Typechecker.TypeLookup (TypeLookup) +import Unison.UnisonFile (TypecheckedUnisonFile) + +data Mergeblob5 = Mergeblob5 + { file :: TypecheckedUnisonFile Symbol Ann + } + +makeMergeblob5 :: Mergeblob4 -> TypeLookup Symbol Ann -> Either (Seq (Result.Note Symbol Ann)) Mergeblob5 +makeMergeblob5 blob typeLookup = + let typecheckingEnv = + Typechecker.Env + { ambientAbilities = [], + termsByShortname = Map.empty, + typeLookup, + topLevelComponents = Map.empty + } + in case runIdentity (Result.runResultT (FileParsers.synthesizeFile typecheckingEnv blob.file)) of + (Nothing, notes) -> Left notes + (Just file, _) -> Right Mergeblob5 {file} diff --git a/unison-merge/src/Unison/Merge/PartialDeclNameLookup.hs b/unison-merge/src/Unison/Merge/PartialDeclNameLookup.hs new file mode 100644 index 0000000000..556ea9f5dc --- /dev/null +++ b/unison-merge/src/Unison/Merge/PartialDeclNameLookup.hs @@ -0,0 +1,15 @@ +module Unison.Merge.PartialDeclNameLookup + ( PartialDeclNameLookup (..), + ) +where + +import Unison.Name (Name) +import Unison.Prelude + +-- | Like a @DeclNameLookup@, but "partial" / more lenient - because we don't require the LCA of a merge to have a full +-- @DeclNameLookup@. +data PartialDeclNameLookup = PartialDeclNameLookup + { constructorToDecl :: !(Map Name Name), + declToConstructors :: !(Map Name [Maybe Name]) + } + deriving stock (Generic) diff --git a/unison-merge/src/Unison/Merge/PartitionCombinedDiffs.hs b/unison-merge/src/Unison/Merge/PartitionCombinedDiffs.hs index 05787791f5..1f144638bb 100644 --- a/unison-merge/src/Unison/Merge/PartitionCombinedDiffs.hs +++ b/unison-merge/src/Unison/Merge/PartitionCombinedDiffs.hs @@ -1,13 +1,14 @@ module Unison.Merge.PartitionCombinedDiffs ( partitionCombinedDiffs, + narrowConflictsToNonBuiltins, ) where import Control.Lens (Lens') import Data.Bitraversable (bitraverse) import Data.Map.Strict qualified as Map +import Unison.DeclNameLookup (DeclNameLookup (..), expectConstructorNames, expectDeclName) import Unison.Merge.CombineDiffs (CombinedDiffOp (..)) -import Unison.Merge.DeclNameLookup (DeclNameLookup (..), expectConstructorNames, expectDeclName) import Unison.Merge.EitherWay (EitherWay (..)) import Unison.Merge.EitherWay qualified as EitherWay import Unison.Merge.EitherWayI (EitherWayI (..)) @@ -27,6 +28,7 @@ import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Util.BiMultimap (BiMultimap) import Unison.Util.BiMultimap qualified as BiMultimap +import Unison.Util.Defn (Defn (..)) import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, defnsAreEmpty) import Unison.Util.Map qualified as Map @@ -35,16 +37,12 @@ partitionCombinedDiffs :: TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> TwoWay DeclNameLookup -> DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> - Either - Name - ( TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId), - DefnsF Unconflicts Referent TypeReference - ) -partitionCombinedDiffs defns declNameLookups diffs = do - let conflicts0 = identifyConflicts declNameLookups defns diffs - let unconflicts = identifyUnconflicts declNameLookups conflicts0 diffs - conflicts <- assertThereAreNoBuiltins conflicts0 - Right (conflicts, unconflicts) + ( TwoWay (DefnsF (Map Name) TermReference TypeReference), + DefnsF Unconflicts Referent TypeReference + ) +partitionCombinedDiffs defns declNameLookups diffs = + let conflicts = identifyConflicts declNameLookups defns diffs + in (conflicts, identifyUnconflicts declNameLookups conflicts diffs) data S = S { me :: !(EitherWay ()), @@ -64,7 +62,7 @@ makeInitialIdentifyConflictsState diff = } identifyConflicts :: - HasCallStack => + (HasCallStack) => TwoWay DeclNameLookup -> TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> @@ -247,21 +245,20 @@ justTheConflictedNames = CombinedDiffOp'Delete _ -> names CombinedDiffOp'Update _ -> names -assertThereAreNoBuiltins :: +narrowConflictsToNonBuiltins :: TwoWay (DefnsF (Map Name) TermReference TypeReference) -> - Either Name (TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId)) -assertThereAreNoBuiltins = + Either (Defn Name Name) (TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId)) +narrowConflictsToNonBuiltins = traverse (bitraverse (Map.traverseWithKey assertTermIsntBuiltin) (Map.traverseWithKey assertTypeIsntBuiltin)) where - assertTermIsntBuiltin :: Name -> TermReference -> Either Name TermReferenceId + assertTermIsntBuiltin :: Name -> TermReference -> Either (Defn Name Name) TermReferenceId assertTermIsntBuiltin name ref = case Reference.toId ref of - Nothing -> Left name + Nothing -> Left (TermDefn name) Just refId -> Right refId - -- Same body as above, but could be different some day (e.g. return value tells you what namespace) - assertTypeIsntBuiltin :: Name -> TypeReference -> Either Name TypeReferenceId + assertTypeIsntBuiltin :: Name -> TypeReference -> Either (Defn Name Name) TypeReferenceId assertTypeIsntBuiltin name ref = case Reference.toId ref of - Nothing -> Left name + Nothing -> Left (TypeDefn name) Just refId -> Right refId diff --git a/unison-merge/src/Unison/Merge/Synhash.hs b/unison-merge/src/Unison/Merge/Synhash.hs index 29559690bf..c281f0b6a2 100644 --- a/unison-merge/src/Unison/Merge/Synhash.hs +++ b/unison-merge/src/Unison/Merge/Synhash.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} + -- | Utilities for computing the "syntactic hash" of a decl or term, which is a hash that is computed after substituting -- references to other terms and decls with names from a pretty-print environment. -- @@ -26,16 +28,22 @@ module Unison.Merge.Synhash ( synhashType, synhashTerm, + synhashBuiltinTerm, + synhashDerivedTerm, synhashBuiltinDecl, synhashDerivedDecl, + + -- * Exported for debugging + hashBuiltinTermTokens, + hashDerivedTermTokens, ) where import Data.Char (ord) +import Data.List qualified as List import Data.Text qualified as Text import U.Codebase.Reference (TypeReference) import Unison.ABT qualified as ABT -import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorType (ConstructorType) import Unison.ConstructorType qualified as CT import Unison.DataDeclaration (DataDeclaration, Decl) @@ -50,16 +58,17 @@ import Unison.Pattern qualified as Pattern import Unison.Prelude import Unison.PrettyPrintEnv (PrettyPrintEnv) import Unison.PrettyPrintEnv qualified as PPE -import Unison.Reference (Reference' (..), TypeReferenceId) -import Unison.Referent qualified as V1 (Referent) -import Unison.Referent qualified as V1.Referent +import Unison.Reference (Reference' (..), TermReferenceId) +import Unison.Reference qualified as V1 +import Unison.Referent (Referent) +import Unison.Referent qualified as Referent import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar) import Unison.Term (Term) import Unison.Term qualified as Term import Unison.Type (Type) import Unison.Type qualified as Type import Unison.Var (Var) -import Unison.Var qualified as Var +import Witch (unsafeFrom) type Token = H.Token Hash @@ -77,9 +86,13 @@ synhashBuiltinDecl :: Text -> Hash synhashBuiltinDecl name = H.accumulate [isBuiltinTag, isDeclTag, H.Text name] -hashBuiltinTerm :: Text -> Hash -hashBuiltinTerm name = - H.accumulate [isBuiltinTag, isTermTag, H.Text name] +synhashBuiltinTerm :: Text -> Hash +synhashBuiltinTerm = + H.accumulate . hashBuiltinTermTokens + +hashBuiltinTermTokens :: Text -> [Token] +hashBuiltinTermTokens name = + [isBuiltinTag, isTermTag, H.Text name] hashCaseTokens :: PrettyPrintEnv -> Term.MatchCase loc a -> [Token] hashCaseTokens ppe (Term.MatchCase pat Nothing _) = H.Tag 0 : hashPatternTokens ppe pat @@ -105,30 +118,40 @@ hashConstructorNameToken declName conName = ) in H.Text (Name.toText strippedConName) -hashDerivedTerm :: Var v => PrettyPrintEnv -> Term v a -> Hash -hashDerivedTerm ppe t = - H.accumulate $ isNotBuiltinTag : hashTermTokens ppe t +synhashDerivedTerm :: (Var v) => PrettyPrintEnv -> Term v a -> Hash +synhashDerivedTerm ppe term = + H.accumulate (hashDerivedTermTokens ppe term) + +hashDerivedTermTokens :: forall a v. (Var v) => PrettyPrintEnv -> Term v a -> [Token] +hashDerivedTermTokens ppe = + (isNotBuiltinTag :) . (isTermTag :) . go [] + where + go :: [v] -> Term v a -> [Token] + go bound t = + H.Tag 255 : case ABT.out t of + ABT.Var v -> [H.Tag 0, hashVarToken bound v] + -- trick: encode the structure, followed the children as a flat list + ABT.Tm f -> H.Tag 1 : hashTermFTokens ppe (void f) <> (toList f >>= go bound) + ABT.Cycle c -> H.Tag 2 : go bound c + ABT.Abs v body -> H.Tag 3 : go (v : bound) body hashConstructorType :: ConstructorType -> Token hashConstructorType = \case CT.Effect -> H.Tag 0 CT.Data -> H.Tag 1 -hashDataDeclTokens :: Var v => PrettyPrintEnv -> Name -> DataDeclaration v a -> [Token] -hashDataDeclTokens ppe declName (DD.DataDeclaration modifier _ vs ctors) = - hashModifierTokens modifier <> goVs <> (ctors >>= hashConstructorTokens ppe declName) - where - goVs = - hashLengthToken vs : map hashVarToken vs +hashDataDeclTokens :: (Var v) => PrettyPrintEnv -> Name -> DataDeclaration v a -> [Token] +hashDataDeclTokens ppe declName (DD.DataDeclaration modifier _ bound ctors) = + hashModifierTokens modifier <> (ctors >>= hashConstructorTokens ppe declName bound) -- separating constructor types with tag of 99, which isn't used elsewhere -hashConstructorTokens :: Var v => PrettyPrintEnv -> Name -> (a, v, Type v a) -> [Token] -hashConstructorTokens ppe declName (_, conName, ty) = +hashConstructorTokens :: (Var v) => PrettyPrintEnv -> Name -> [v] -> (a, v, Type v a) -> [Token] +hashConstructorTokens ppe declName bound (_, conName, ty) = H.Tag 99 : hashConstructorNameToken declName (Name.unsafeParseVar conName) - : hashTypeTokens ppe ty + : hashTypeTokens ppe bound ty -hashDeclTokens :: Var v => PrettyPrintEnv -> Name -> Decl v a -> [Token] +hashDeclTokens :: (Var v) => PrettyPrintEnv -> Name -> Decl v a -> [Token] hashDeclTokens ppe name decl = hashConstructorType (DD.constructorType decl) : hashDataDeclTokens ppe name (DD.asDataDecl decl) @@ -136,9 +159,9 @@ hashDeclTokens ppe name decl = -- they they are the same sort of decl (both are data decls or both are effect decls), the unique type guid is the same, -- the constructors appear in the same order and have the same names, and the constructors' types have the same -- syntactic hashes. -synhashDerivedDecl :: Var v => PrettyPrintEnv -> Name -> Decl v a -> Hash +synhashDerivedDecl :: (Var v) => PrettyPrintEnv -> Name -> Decl v a -> Hash synhashDerivedDecl ppe name decl = - H.accumulate $ isNotBuiltinTag : hashDeclTokens ppe name decl + H.accumulate $ isNotBuiltinTag : isDeclTag : hashDeclTokens ppe name decl hashHQNameToken :: HashQualified Name -> Token hashHQNameToken = @@ -149,7 +172,7 @@ hashKindTokens k = case k of K.Star -> [H.Tag 0] K.Arrow k1 k2 -> H.Tag 1 : (hashKindTokens k1 <> hashKindTokens k2) -hashLengthToken :: Foldable t => t a -> Token +hashLengthToken :: (Foldable t) => t a -> Token hashLengthToken = H.Nat . fromIntegral @Int @Word64 . length @@ -170,14 +193,14 @@ hashPatternTokens ppe = \case Pattern.Char _ c -> [H.Tag 7, H.Nat (fromIntegral (ord c))] Pattern.Constructor _ cr ps -> H.Tag 8 - : hashReferentToken ppe (V1.Referent.Con cr CT.Data) + : hashReferentToken ppe (Referent.Con cr CT.Data) : hashLengthToken ps : (ps >>= hashPatternTokens ppe) Pattern.As _ p -> H.Tag 9 : hashPatternTokens ppe p Pattern.EffectPure _ p -> H.Tag 10 : hashPatternTokens ppe p Pattern.EffectBind _ cr ps k -> H.Tag 11 - : hashReferentToken ppe (V1.Referent.Con cr CT.Effect) + : hashReferentToken ppe (Referent.Con cr CT.Effect) : hashLengthToken ps : hashPatternTokens ppe k <> (ps >>= hashPatternTokens ppe) Pattern.SequenceLiteral _ ps -> H.Tag 12 : hashLengthToken ps : (ps >>= hashPatternTokens ppe) @@ -188,51 +211,22 @@ hashPatternTokens ppe = \case Pattern.Snoc -> H.Tag 1 Pattern.Cons -> H.Tag 2 -hashReferentToken :: PrettyPrintEnv -> V1.Referent -> Token +hashReferentToken :: PrettyPrintEnv -> Referent -> Token hashReferentToken ppe = - H.Hashed . H.accumulate . hashReferentTokens ppe - -hashReferentTokens :: PrettyPrintEnv -> V1.Referent -> [Token] -hashReferentTokens ppe referent = - case referent of - -- distinguish constructor name from terms by tumbling in a name (of any alias of) its decl - V1.Referent.Con (ConstructorReference ref _i) _ct -> [hashTypeReferenceToken ppe ref, nameTok] - V1.Referent.Ref _ -> [nameTok] - where - nameTok :: Token - nameTok = - hashHQNameToken (PPE.termNameOrHashOnlyFq ppe referent) + hashHQNameToken . PPE.termNameOrHashOnlyFq ppe --- | Syntactically hash a term, using reference names rather than hashes. --- Two terms will have the same syntactic hash if they would --- print the the same way under the given pretty-print env. synhashTerm :: forall m v a. (Monad m, Var v) => - (TypeReferenceId -> m (Term v a)) -> + (TermReferenceId -> m (Term v a)) -> PrettyPrintEnv -> - V1.Referent -> + V1.TermReference -> m Hash synhashTerm loadTerm ppe = \case - V1.Referent.Con ref CT.Data -> pure (hashDerivedTerm ppe (Term.constructor @v () ref)) - V1.Referent.Con ref CT.Effect -> pure (hashDerivedTerm ppe (Term.request @v () ref)) - V1.Referent.Ref (ReferenceBuiltin builtin) -> pure (hashBuiltinTerm builtin) - V1.Referent.Ref (ReferenceDerived ref) -> hashDerivedTerm ppe <$> loadTerm ref - -hashTermTokens :: forall v a. Var v => PrettyPrintEnv -> Term v a -> [Token] -hashTermTokens ppe = - go - where - go :: Term v a -> [Token] - go t = - H.Tag 255 : case ABT.out t of - ABT.Var v -> [H.Tag 0, hashVarToken v] - -- trick: encode the structure, followed the children as a flat list - ABT.Tm f -> H.Tag 1 : hashTermFTokens ppe (void f) <> (toList f >>= go) - ABT.Cycle c -> H.Tag 2 : go c - ABT.Abs v body -> H.Tag 3 : hashVarToken v : go body + ReferenceBuiltin builtin -> pure (synhashBuiltinTerm builtin) + ReferenceDerived ref -> synhashDerivedTerm ppe <$> loadTerm ref -hashTermFTokens :: Var v => PrettyPrintEnv -> Term.F v a a () -> [Token] +hashTermFTokens :: (Var v) => PrettyPrintEnv -> Term.F v a a () -> [Token] hashTermFTokens ppe = \case Term.Int n -> [H.Tag 0, H.Int n] Term.Nat n -> [H.Tag 1, H.Nat n] @@ -242,12 +236,12 @@ hashTermFTokens ppe = \case Term.Char c -> [H.Tag 5, H.Nat (fromIntegral (ord c))] Term.Blank {} -> error "tried to hash a term with blanks, something's very wrong" -- note: these are all hashed the same, just based on the name - Term.Ref r -> [H.Tag 7, hashReferentToken ppe (V1.Referent.Ref r)] - Term.Constructor cr -> [H.Tag 7, hashReferentToken ppe (V1.Referent.Con cr CT.Data)] - Term.Request cr -> [H.Tag 7, hashReferentToken ppe (V1.Referent.Con cr CT.Effect)] + Term.Ref r -> [H.Tag 7, hashReferentToken ppe (Referent.Ref r)] + Term.Constructor cr -> [H.Tag 7, hashReferentToken ppe (Referent.Con cr CT.Data)] + Term.Request cr -> [H.Tag 7, hashReferentToken ppe (Referent.Con cr CT.Effect)] Term.Handle {} -> [H.Tag 8] Term.App {} -> [H.Tag 9] - Term.Ann _ ty -> H.Tag 10 : hashTypeTokens ppe ty + Term.Ann _ ty -> H.Tag 10 : hashTypeTokens ppe [] ty Term.List xs -> [H.Tag 11, hashLengthToken xs] Term.If {} -> [H.Tag 12] Term.And {} -> [H.Tag 13] @@ -263,21 +257,21 @@ hashTermFTokens ppe = \case -- | Syntactically hash a type, using reference names rather than hashes. -- Two types will have the same syntactic hash if they would -- print the the same way under the given pretty-print env. -synhashType :: Var v => PrettyPrintEnv -> Type v a -> Hash -synhashType ppe t = - H.accumulate $ hashTypeTokens ppe t +synhashType :: (Var v) => PrettyPrintEnv -> Type v a -> Hash +synhashType ppe ty = + H.accumulate $ hashTypeTokens ppe [] ty -hashTypeTokens :: forall v a. Var v => PrettyPrintEnv -> Type v a -> [Token] +hashTypeTokens :: forall v a. (Var v) => PrettyPrintEnv -> [v] -> Type v a -> [Token] hashTypeTokens ppe = go where - go :: Type v a -> [Token] - go t = + go :: [v] -> Type v a -> [Token] + go bound t = H.Tag 254 : case ABT.out t of - ABT.Var v -> [H.Tag 0, hashVarToken v] + ABT.Var v -> [H.Tag 0, hashVarToken bound v] -- trick: encode the structure, followed the children as a flat list - ABT.Tm f -> H.Tag 1 : (hashTypeFTokens ppe (void f) <> (toList f >>= go)) - ABT.Cycle c -> H.Tag 2 : go c - ABT.Abs v body -> H.Tag 3 : hashVarToken v : go body + ABT.Tm f -> H.Tag 1 : (hashTypeFTokens ppe (void f) <> (toList f >>= go bound)) + ABT.Cycle c -> H.Tag 2 : go bound c + ABT.Abs v body -> H.Tag 3 : go (v : bound) body hashTypeFTokens :: PrettyPrintEnv -> Type.F () -> [Token] hashTypeFTokens ppe = \case @@ -294,6 +288,8 @@ hashTypeReferenceToken :: PrettyPrintEnv -> TypeReference -> Token hashTypeReferenceToken ppe = hashHQNameToken . PPE.typeNameOrHashOnlyFq ppe -hashVarToken :: Var v => v -> Token -hashVarToken = - H.Text . Var.name +hashVarToken :: (Var v) => [v] -> v -> Token +hashVarToken bound v = + case List.elemIndex v bound of + Nothing -> error (reportBug "E633940" ("var " ++ show v ++ " not bound in " ++ show bound)) + Just index -> H.Nat (unsafeFrom @Int @Word64 index) diff --git a/unison-merge/src/Unison/Merge/TwoWay.hs b/unison-merge/src/Unison/Merge/TwoWay.hs index 05640a3786..bad9a928f9 100644 --- a/unison-merge/src/Unison/Merge/TwoWay.hs +++ b/unison-merge/src/Unison/Merge/TwoWay.hs @@ -80,7 +80,7 @@ twoWay f TwoWay {alice, bob} = f alice bob -- | Unzip a @Map k (TwoWay v)@ into a @TwoWay (Map k v)@. -unzipMap :: Ord k => Map k (TwoWay v) -> TwoWay (Map k v) +unzipMap :: (Ord k) => Map k (TwoWay v) -> TwoWay (Map k v) unzipMap = fromPair . unzipWith (\TwoWay {alice, bob} -> (alice, bob)) diff --git a/unison-merge/src/Unison/Merge/Unconflicts.hs b/unison-merge/src/Unison/Merge/Unconflicts.hs index e5411189a1..39d19e4a4b 100644 --- a/unison-merge/src/Unison/Merge/Unconflicts.hs +++ b/unison-merge/src/Unison/Merge/Unconflicts.hs @@ -2,17 +2,18 @@ module Unison.Merge.Unconflicts ( Unconflicts (..), empty, apply, - soloDeletedNames, - soloUpdatedNames, + soloUpdatesAndDeletes, ) where +import Data.Bitraversable (bitraverse) import Data.Map.Strict qualified as Map import Unison.Merge.TwoWay (TwoWay) import Unison.Merge.TwoWayI (TwoWayI (..)) import Unison.Merge.TwoWayI qualified as TwoWayI import Unison.Name (Name) import Unison.Prelude hiding (empty) +import Unison.Util.Defns (DefnsF) data Unconflicts v = Unconflicts { adds :: !(TwoWayI (Map Name v)), @@ -44,6 +45,18 @@ apply unconflicts = applyDeletes = (`Map.withoutKeys` foldMap Map.keysSet unconflicts.deletes) +soloUpdatesAndDeletes :: DefnsF Unconflicts term typ -> TwoWay (DefnsF Set Name Name) +soloUpdatesAndDeletes unconflicts = + unconflictedSoloDeletedNames <> unconflictedSoloUpdatedNames + where + unconflictedSoloDeletedNames :: TwoWay (DefnsF Set Name Name) + unconflictedSoloDeletedNames = + bitraverse soloDeletedNames soloDeletedNames unconflicts + + unconflictedSoloUpdatedNames :: TwoWay (DefnsF Set Name Name) + unconflictedSoloUpdatedNames = + bitraverse soloUpdatedNames soloUpdatedNames unconflicts + soloDeletedNames :: Unconflicts v -> TwoWay (Set Name) soloDeletedNames = fmap Map.keysSet . TwoWayI.forgetBoth . view #deletes diff --git a/unison-merge/unison-merge.cabal b/unison-merge/unison-merge.cabal index 84baab088f..e53e024a67 100644 --- a/unison-merge/unison-merge.cabal +++ b/unison-merge/unison-merge.cabal @@ -17,15 +17,22 @@ source-repository head library exposed-modules: + Unison.Merge Unison.Merge.CombineDiffs - Unison.Merge.Database Unison.Merge.DeclCoherencyCheck - Unison.Merge.DeclNameLookup Unison.Merge.Diff Unison.Merge.DiffOp Unison.Merge.EitherWay Unison.Merge.EitherWayI + Unison.Merge.FindConflictedAlias Unison.Merge.Libdeps + Unison.Merge.Mergeblob0 + Unison.Merge.Mergeblob1 + Unison.Merge.Mergeblob2 + Unison.Merge.Mergeblob3 + Unison.Merge.Mergeblob4 + Unison.Merge.Mergeblob5 + Unison.Merge.PartialDeclNameLookup Unison.Merge.PartitionCombinedDiffs Unison.Merge.Synhash Unison.Merge.Synhashed @@ -66,6 +73,7 @@ library OverloadedRecordDot OverloadedStrings PatternSynonyms + QuantifiedConstraints RankNTypes ScopedTypeVariables TupleSections @@ -74,39 +82,23 @@ library ghc-options: -Wall build-depends: base - , bimap - , bitvec - , bytestring , containers - , either - , free - , generic-lens , lens - , monad-validate , mtl , nonempty-containers - , safe , semialign , semigroups , text , these , transformers - , unison-codebase - , unison-codebase-sqlite - , unison-codebase-sqlite-hashing-v2 , unison-core , unison-core1 , unison-hash , unison-parser-typechecker , unison-prelude - , unison-sqlite + , unison-pretty-printer , unison-syntax - , unison-util-cache - , unison-util-nametree , unison-util-relation - , vector + , witch , witherable default-language: Haskell2010 - if !os(windows) - build-depends: - unix diff --git a/unison-runtime/LICENSE b/unison-runtime/LICENSE new file mode 100644 index 0000000000..c45ac9a548 --- /dev/null +++ b/unison-runtime/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2013-2021, Unison Computing, public benefit corp and contributors + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/unison-runtime/package.yaml b/unison-runtime/package.yaml new file mode 100644 index 0000000000..4cf83f10c9 --- /dev/null +++ b/unison-runtime/package.yaml @@ -0,0 +1,165 @@ +name: unison-runtime +github: unisonweb/unison +copyright: Copyright (C) 2013-2024 Unison Computing, PBC and contributors + +ghc-options: -fmax-worker-args=100 -Wall -funbox-strict-fields -O2 + +flags: + arraychecks: + manual: true + default: false + stackchecks: + manual: true + default: false + + # Run optimization assertion tests, make sure this runs with O2 + optchecks: + manual: true + default: false + + # Dumps core for debugging to unison-runtime/.stack-work/dist//ghc-x.y.z/build/ + dumpcore: + manual: true + default: false + +when: + - condition: flag(arraychecks) + cpp-options: -DARRAY_CHECK + - condition: flag(stackchecks) + cpp-options: -DSTACK_CHECK + - condition: flag(optchecks) + ghc-options: -O2 + cpp-options: -DOPT_CHECK + dependencies: + - inspection-testing + - condition: flag(dumpcore) + ghc-options: -ddump-simpl -ddump-stg-final -ddump-to-file -dsuppress-coercions -dsuppress-idinfo -dsuppress-module-prefixes -ddump-str-signatures -ddump-simpl-stats # -dsuppress-type-applications -dsuppress-type-signatures + +library: + source-dirs: src + when: + - condition: false + other-modules: Paths_unison_runtime + + dependencies: + - asn1-encoding + - asn1-types + - atomic-primops + - base + - binary + - bytes + - bytestring + - cereal + - clock + - containers >= 0.6.3 + - cryptonite + - data-default + - data-memocombinators + - deepseq + - directory + - exceptions + - filepath + - iproute + - lens + - memory + - mmorph + - mtl + - murmur-hash + - network + - network-simple + - network-udp + - pem + - primitive + - process + - raw-strings-qq + - safe-exceptions + - stm + - tagged + - temporary + - text + - template-haskell + - inspection-testing + - time + - tls + - unison-codebase-sqlite + - unison-core + - unison-core1 + - unison-hash + - unison-parser-typechecker + - unison-prelude + - unison-pretty-printer + - unison-syntax + - unison-util-bytes + - unison-util-recursion + - unliftio + - vector + - crypton-x509 + - crypton-x509-store + - crypton-x509-system + +tests: + runtime-tests: + source-dirs: tests + main: Suite.hs + ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 + when: + - condition: false + other-modules: Paths_unison_parser_typechecker + dependencies: + - base + - bytes + - cereal + - code-page + - containers + - cryptonite + - directory + - easytest + - hedgehog + - filemanip + - filepath + - hex-text + - lens + - megaparsec + - mtl + - primitive + - stm + - text + - unison-core1 + - unison-hash + - unison-util-bytes + - unison-parser-typechecker + - unison-prelude + - unison-pretty-printer + - unison-runtime + - unison-syntax + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveAnyClass + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - DuplicateRecordFields + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - ImportQualifiedPost + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedLabels + - OverloadedRecordDot + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeApplications + - TypeFamilies + - ViewPatterns diff --git a/unison-runtime/src/Unison/Codebase/Execute.hs b/unison-runtime/src/Unison/Codebase/Execute.hs new file mode 100644 index 0000000000..22b54c6f7d --- /dev/null +++ b/unison-runtime/src/Unison/Codebase/Execute.hs @@ -0,0 +1,77 @@ +-- | Execute a computation of type '{IO} () that has been previously added to +-- the codebase, without setting up an interactive environment. +-- +-- This allows one to run standalone applications implemented in the Unison +-- language. +module Unison.Codebase.Execute + ( execute, + codebaseToCodeLookup, + ) +where + +import Control.Exception (finally) +import Control.Monad.Except +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.Queries qualified as Q +import Unison.Builtin qualified as Builtin +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Branch.Names qualified as Branch +import Unison.Codebase.CodeLookup qualified as CL +import Unison.Codebase.MainTerm (getMainTerm) +import Unison.Codebase.MainTerm qualified as MainTerm +import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathG (..)) +import Unison.Codebase.ProjectPath qualified as PP +import Unison.Codebase.Runtime (Runtime) +import Unison.Codebase.Runtime qualified as Runtime +import Unison.Codebase.Type (Codebase (..)) +import Unison.HashQualified qualified as HQ +import Unison.Parser.Ann (Ann) +import Unison.Parser.Ann qualified as Parser +import Unison.Prelude +import Unison.PrettyPrintEnv qualified as PPE +import Unison.Runtime.IOSource qualified as IOSource +import Unison.Symbol (Symbol) +import Unison.Syntax.HashQualified qualified as HQ (toText) +import Unison.Util.Pretty qualified as P + +execute :: + Codebase.Codebase IO Symbol Ann -> + Runtime Symbol -> + PP.ProjectPathNames -> + IO (Either Runtime.Error ()) +execute codebase runtime mainPath = + (`finally` Runtime.terminate runtime) . runExceptT $ do + (project, branch) <- ExceptT $ (Codebase.runTransactionWithRollback codebase) \rollback -> do + project <- Q.loadProjectByName mainPath.project `whenNothingM` rollback (Left . P.text $ ("Project not found: " <> into @Text mainPath.project)) + branch <- Q.loadProjectBranchByName project.projectId mainPath.branch `whenNothingM` rollback (Left . P.text $ ("Branch not found: " <> into @Text mainPath.branch)) + pure . Right $ (project, branch) + projectRootNames <- fmap (Branch.toNames . Branch.head) . liftIO $ Codebase.expectProjectBranchRoot codebase project.projectId branch.branchId + let loadTypeOfTerm = Codebase.getTypeOfTerm codebase + let mainType = Runtime.mainType runtime + mainName <- case Path.toName (mainPath ^. PP.path_) of + Just n -> pure (HQ.NameOnly n) + Nothing -> throwError ("Path must lead to an executable term: " <> P.text (Path.toText (PP.path mainPath))) + + mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm projectRootNames mainName mainType + case mt of + MainTerm.NotFound s -> throwError ("Not found: " <> P.text (HQ.toText s)) + MainTerm.BadType s _ -> throwError (P.text (HQ.toText s) <> " is not of type '{IO} ()") + MainTerm.Success _ tm _ -> do + let codeLookup = codebaseToCodeLookup codebase + ppe = PPE.empty + (liftIO $ Runtime.evaluateTerm codeLookup ppe runtime tm) >>= \case + Left err -> throwError err + Right _ -> pure () + +codebaseToCodeLookup :: (MonadIO m) => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann +codebaseToCodeLookup c = + CL.CodeLookup goGetTerm goGetTypeOfTerm goGetTypeDecl + <> Builtin.codeLookup + <> IOSource.codeLookupM + where + goGetTerm = (Codebase.runTransaction c . getTerm c) + goGetTypeOfTerm = (Codebase.runTransaction c . getTypeOfTermImpl c) + goGetTypeDecl = (Codebase.runTransaction c . getTypeDeclaration c) diff --git a/unison-runtime/src/Unison/Runtime/ANF.hs b/unison-runtime/src/Unison/Runtime/ANF.hs new file mode 100644 index 0000000000..539b6bcd66 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/ANF.hs @@ -0,0 +1,2539 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Runtime.ANF + ( minimizeCyclesOrCrash, + pattern TVar, + pattern TLit, + pattern TBLit, + pattern TApp, + pattern TApv, + pattern TCom, + pattern TCon, + pattern UFalse, + pattern UTrue, + pattern TKon, + pattern TReq, + pattern TPrm, + pattern TFOp, + pattern THnd, + pattern TLet, + pattern TLetD, + pattern TFrc, + pattern TLets, + pattern TName, + pattern TBind, + pattern TBinds, + pattern TShift, + pattern TMatch, + CompileExn (..), + internalBug, + Mem (..), + Lit (..), + Cacheability (..), + Direction (..), + SuperNormal (..), + arity, + SuperGroup (..), + arities, + POp (..), + close, + saturate, + float, + floatGroup, + lamLift, + lamLiftGroup, + litRef, + inlineAlias, + addDefaultCases, + ANormalF (.., AApv, ACom, ACon, AKon, AReq, APrm, AFOp), + ANormal, + RTag, + CTag, + PackedTag (..), + Tag (..), + GroupRef (..), + Code (..), + ValList, + Value (..), + Cont (..), + BLit (..), + packTags, + unpackTags, + maskTags, + ANFM, + Branched (.., MatchDataCover), + Func (..), + SGEqv (..), + equivocate, + superNormalize, + anfTerm, + codeGroup, + valueTermLinks, + valueLinks, + groupTermLinks, + buildInlineMap, + inline, + foldGroup, + foldGroupLinks, + overGroup, + overGroupLinks, + traverseGroup, + traverseGroupLinks, + normalLinks, + prettyGroup, + prettySuperNormal, + prettyANF, + ) +where + +import Control.Exception (throw) +import Control.Lens (snoc, unsnoc) +import Control.Monad.Reader (ReaderT (..), ask, local) +import Control.Monad.State (MonadState (..), State, gets, modify, runState) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bitraversable (Bitraversable (..)) +import Data.Functor.Compose (Compose (..)) +import Data.List hiding (and, or) +import Data.Map qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Data.Text +import GHC.Stack (CallStack, callStack) +import Unison.ABT qualified as ABT +import Unison.ABT.Normalized qualified as ABTN +import Unison.Blank (nameb) +import Unison.Builtin.Decls qualified as Ty +import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) +import Unison.Hashing.V2.Convert (hashTermComponentsWithoutTypes) +import Unison.Pattern (SeqOp (..)) +import Unison.Pattern qualified as P +import Unison.Prelude +import Unison.Reference (Id, Reference, Reference' (Builtin, DerivedId)) +import Unison.Referent (Referent, pattern Con, pattern Ref) +import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..)) +import Unison.Runtime.TypeTags (CTag (..), PackedTag (..), RTag (..), Tag (..), maskTags, packTags, unpackTags) +import Unison.Symbol (Symbol) +import Unison.Term hiding (List, Ref, Text, arity, float, fresh, resolve) +import Unison.Type qualified as Ty +import Unison.Typechecker.Components (minimize') +import Unison.Util.Bytes (Bytes) +import Unison.Util.EnumContainers as EC +import Unison.Util.Pretty qualified as Pretty +import Unison.Util.Text qualified as Util.Text +import Unison.Var (Var, typed) +import Unison.Var qualified as Var +import Prelude hiding (abs, and, or, seq) + +-- For internal errors +data CompileExn = CE CallStack (Pretty.Pretty Pretty.ColorText) + deriving (Show) + +instance Exception CompileExn + +internalBug :: (HasCallStack) => String -> a +internalBug = throw . CE callStack . Pretty.lit . fromString + +closure :: (Var v) => Map v (Set v, Set v) -> Map v (Set v) +closure m0 = trace (snd <$> m0) + where + refs = fst <$> m0 + + expand acc fvs rvs = + fvs <> foldMap (\r -> Map.findWithDefault mempty r acc) rvs + + trace acc + | acc == acc' = acc + | otherwise = trace acc' + where + acc' = Map.intersectionWith (expand acc) acc refs + +expandRec :: + (Var v, Monoid a) => + Set v -> + [(v, Term v a)] -> + [(v, Term v a)] +expandRec keep vbs = mkSub <$> fvl + where + mkSub (v, fvs) = (v, apps' (var mempty v) (var mempty <$> fvs)) + + fvl = + Map.toList + . fmap (Set.toList) + . closure + $ Set.partition (`Set.member` keep) + . ABT.freeVars + <$> Map.fromList vbs + +expandSimple :: + (Var v, Monoid a) => + Set v -> + (v, Term v a) -> + (v, Term v a) +expandSimple keep (v, bnd) = (v, apps' (var a v) evs) + where + a = ABT.annotation bnd + fvs = ABT.freeVars bnd + evs = map (var a) . Set.toList $ Set.difference fvs keep + +abstract :: (Var v) => Set v -> Term v a -> Term v a +abstract keep bnd = lamWithoutBindingAnns a evs bnd + where + a = ABT.annotation bnd + fvs = ABT.freeVars bnd + evs = Set.toList $ Set.difference fvs keep + +enclose :: + (Var v, Monoid a) => + Set v -> + (Set v -> Term v a -> Term v a) -> + Term v a -> + Maybe (Term v a) +enclose keep rec (LetRecNamedTop' top vbs bd) = + Just $ letRec' top lvbs lbd + where + xpnd = expandRec keep' vbs + keep' = Set.union keep . Set.fromList . map fst $ vbs + lvbs = + vbs + <&> \(v, trm) -> + (v, ABT.annotation trm, (rec keep' . abstract keep' . ABT.substs xpnd) trm) + lbd = rec keep' . ABT.substs xpnd $ bd +-- will be lifted, so keep this variable +enclose keep rec (Let1NamedTop' top v b@(unAnn -> LamsNamed' vs bd) e) = + Just . let1' top [(v, lamb)] . rec (Set.insert v keep) $ + ABT.subst v av e + where + (_, av) = expandSimple keep (v, b) + keep' = Set.difference keep $ Set.fromList vs + fvs = ABT.freeVars b + evs = Set.toList $ Set.difference fvs keep + a = ABT.annotation b + lbody = rec keep' bd + annotate tm + | Ann' _ ty <- b = ann a tm ty + | otherwise = tm + lamb = lamWithoutBindingAnns a evs (annotate $ lamWithoutBindingAnns a vs lbody) +enclose keep rec t@(unLamsAnnot -> Just (vs0, mty, vs1, body)) = + Just $ if null evs then lamb else apps' lamb $ map (var a) evs + where + -- remove shadowed variables + keep' = Set.difference keep $ Set.fromList (vs0 ++ vs1) + fvs = ABT.freeVars t + evs = Set.toList $ Set.difference fvs keep + a = ABT.annotation t + lbody = rec keep' body + annotate tm + | Just ty <- mty = ann a tm ty + | otherwise = tm + lamb = lamWithoutBindingAnns a (evs ++ vs0) . annotate . lamWithoutBindingAnns a vs1 $ lbody +enclose keep rec t@(Handle' h body) + | isStructured body = + Just . handle (ABT.annotation t) (rec keep h) $ apps' lamb args + where + fvs = ABT.freeVars body + evs = Set.toList $ Set.difference fvs keep + a = ABT.annotation body + lbody = rec keep body + fv = Var.freshIn fvs $ typed Var.Eta + args + | null evs = [constructor a (ConstructorReference Ty.unitRef 0)] + | otherwise = var a <$> evs + lamb + | null evs = lamWithoutBindingAnns a [fv] lbody + | otherwise = lamWithoutBindingAnns a evs lbody +enclose keep rec t@(Match' s0 cs0) = Just $ match a s cs + where + a = ABT.annotation t + s = rec keep s0 + cs = encloseCase a keep rec <$> cs0 +enclose _ _ _ = Nothing + +encloseCase :: + (Var v, Monoid a) => + a -> + Set v -> + (Set v -> Term v a -> Term v a) -> + MatchCase a (Term v a) -> + MatchCase a (Term v a) +encloseCase a keep rec0 (MatchCase pats guard body) = + MatchCase pats (rec <$> guard) (rec body) + where + rec (ABT.AbsN' vs bd) = + ABT.absChain' ((,) a <$> vs) $ + rec0 (keep `Set.difference` Set.fromList vs) bd + +newtype Prefix v x = Pfx (Map v [v]) deriving (Show) + +instance Functor (Prefix v) where + fmap _ (Pfx m) = Pfx m + +instance (Ord v) => Applicative (Prefix v) where + pure _ = Pfx Map.empty + Pfx ml <*> Pfx mr = Pfx $ Map.unionWith common ml mr + +common :: (Eq v) => [v] -> [v] -> [v] +common (u : us) (v : vs) + | u == v = u : common us vs +common _ _ = [] + +splitPfx :: v -> [Term v a] -> (Prefix v x, [Term v a]) +splitPfx v = first (Pfx . Map.singleton v) . split + where + split (Var' u : as) = first (u :) $ split as + split rest = ([], rest) + +-- Finds the common variable prefixes that function variables are +-- applied to, so that they can be reduced. +prefix :: (Ord v) => Term v a -> Prefix v (Term v a) +prefix = ABT.visit \case + Apps' (Var' u) as -> case splitPfx u as of + (pf, rest) -> Just $ traverse prefix rest *> pf + Var' u -> Just . Pfx $ Map.singleton u [] + _ -> Nothing + +appPfx :: (Ord v) => Prefix v a -> v -> [v] -> [v] +appPfx (Pfx m) v = maybe (const []) common $ Map.lookup v m + +-- Rewrites a term by dropping the first n arguments to every +-- application of `v`. This just assumes such a thing makes sense, as +-- in `beta`, where we've calculated how many arguments to drop by +-- looking at every occurrence of `v`. +dropPrefix :: (Ord v) => (Semigroup a) => v -> Int -> Term v a -> Term v a +dropPrefix _ 0 = id +dropPrefix v n = ABT.visitPure rw + where + rw (Apps' f@(Var' u) as) + | v == u = Just (apps' (var (ABT.annotation f) u) (drop n as)) + rw _ = Nothing + +dropPrefixes :: + (Ord v) => (Semigroup a) => Map v Int -> Term v a -> Term v a +dropPrefixes m = ABT.visitPure rw + where + rw (Apps' f@(Var' u) as) + | Just n <- Map.lookup u m = + Just (apps' (var (ABT.annotation f) u) (drop n as)) + rw _ = Nothing + +-- Performs opposite transformations to those in enclose. Named after +-- the lambda case, which is beta reduction. +beta :: (Var v) => (Monoid a) => (Term v a -> Term v a) -> Term v a -> Maybe (Term v a) +beta rec (LetRecNamedTop' top (fmap (fmap rec) -> vbs) (rec -> bd)) = + Just $ letRec' top lvbs lbd + where + -- Avoid completely reducing a lambda expression, because recursive + -- lets must be guarded. + args (v, LamsNamed' vs Ann' {}) = (v, vs) + args (v, LamsNamed' vs _) = (v, init vs) + args (v, _) = (v, []) + + Pfx m0 = traverse_ (prefix . snd) vbs *> prefix bd + + f ls rs = case common ls rs of + [] -> Nothing + vs -> Just vs + + m = Map.map length $ Map.differenceWith f (Map.fromList $ map args vbs) m0 + lvbs = + vbs <&> \(v, b0) -> (v,ABT.annotation b0,) $ case b0 of + LamsNamed' vs b + | Just n <- Map.lookup v m -> + lamWithoutBindingAnns (ABT.annotation b0) (drop n vs) (dropPrefixes m b) + -- shouldn't happen + b -> dropPrefixes m b + + lbd = dropPrefixes m bd +beta rec (Let1NamedTop' top v l@(LamsNamed' vs bd) (rec -> e)) + | n > 0 = Just $ let1' top [(v, lamb)] (dropPrefix v n e) + | otherwise = Nothing + where + lamb = lamWithoutBindingAnns al (drop n vs) (bd) + al = ABT.annotation l + -- Calculate a maximum number of arguments to drop. + -- Enclosing doesn't create let-bound lambdas, so we + -- should never reduce a lambda to a non-lambda, as that + -- could affect evaluation order. + m + | Ann' _ _ <- bd = length vs + | otherwise = length vs - 1 + n = min m . length $ appPfx (prefix e) v vs +beta rec (Apps' l@(LamsNamed' vs body) as) + | n <- matchVars 0 vs as, + n > 0 = + Just $ apps' (lamWithoutBindingAnns al (drop n vs) (rec body)) (drop n as) + | otherwise = Nothing + where + al = ABT.annotation l + matchVars !n (u : us) (Var' v : as) | u == v = matchVars (1 + n) us as + matchVars n _ _ = n +beta _ _ = Nothing + +isStructured :: (Var v) => Term v a -> Bool +isStructured (Var' _) = False +isStructured (Lam' _) = False +isStructured (Nat' _) = False +isStructured (Int' _) = False +isStructured (Float' _) = False +isStructured (Text' _) = False +isStructured (Char' _) = False +isStructured (Constructor' _) = False +isStructured (Apps' Constructor' {} args) = any isStructured args +isStructured (If' b t f) = + isStructured b || isStructured t || isStructured f +isStructured (And' l r) = isStructured l || isStructured r +isStructured (Or' l r) = isStructured l || isStructured r +isStructured _ = True + +close :: (Var v, Monoid a) => Set v -> Term v a -> Term v a +close keep tm = ABT.visitPure (enclose keep close) tm + +-- Attempts to undo what was done in `close`. Useful for decompiling. +open :: (Var v, Monoid a) => Term v a -> Term v a +open x = ABT.visitPure (beta open) x + +type FloatM v a r = State (Set v, [(v, Term v a)], [(v, Term v a)]) r + +freshFloat :: (Var v) => Set v -> v -> v +freshFloat avoid (Var.freshIn avoid -> v0) = + case Var.typeOf v0 of + Var.User nm + | v <- typed (Var.User $ nm <> w), + v `Set.notMember` avoid -> + v + | otherwise -> + freshFloat (Set.insert v0 avoid) v0 + _ -> v0 + where + w = Data.Text.pack . show $ Var.freshId v0 + +groupFloater :: + (Var v, Monoid a) => + (Term v a -> FloatM v a (Term v a)) -> + [(v, Term v a)] -> + FloatM v a (Map v v) +groupFloater rec vbs = do + cvs <- gets (\(vs, _, _) -> vs) + let shadows = + [ (v, freshFloat cvs v) + | (v, _) <- vbs, + Set.member v cvs + ] + shadowMap = Map.fromList shadows + rn v = Map.findWithDefault v v shadowMap + shvs = Set.fromList $ map (rn . fst) vbs + modify $ \(cvs, ctx, dcmp) -> (cvs <> shvs, ctx, dcmp) + fvbs <- traverse (\(v, b) -> (,) (rn v) <$> rec' (ABT.renames shadowMap b)) vbs + let dvbs = fmap (\(v, b) -> (rn v, deannotate b)) vbs + modify $ \(vs, ctx, dcmp) -> (vs, ctx ++ fvbs, dcmp <> dvbs) + pure shadowMap + where + rec' b + | Just (vs0, mty, vs1, bd) <- unLamsAnnot b = + lamWithoutBindingAnns a vs0 . maybe id (flip $ ann a) mty . lamWithoutBindingAnns a vs1 <$> rec bd + where + a = ABT.annotation b + rec' b = rec b + +letFloater :: + (Var v, Monoid a) => + (Term v a -> FloatM v a (Term v a)) -> + [(v, Term v a)] -> + Term v a -> + FloatM v a (Term v a) +letFloater rec vbs e = do + shadowMap <- groupFloater rec vbs + pure $ ABT.renames shadowMap e + +lamFloater :: + (Var v, Monoid a) => + Bool -> + Term v a -> + Maybe v -> + a -> + [v] -> + Term v a -> + FloatM v a v +lamFloater closed tm mv a vs bd = + state $ \trip@(cvs, ctx, dcmp) -> case find p ctx of + Just (v, _) -> (v, trip) + Nothing -> + let v = ABT.freshIn cvs $ fromMaybe (typed Var.Float) mv + in ( v, + ( Set.insert v cvs, + ctx <> [(v, lamWithoutBindingAnns a vs bd)], + floatDecomp closed v tm dcmp + ) + ) + where + tgt = unannotate (lamWithoutBindingAnns a vs bd) + p (_, flam) = unannotate flam == tgt + +floatDecomp :: + Bool -> v -> Term v a -> [(v, Term v a)] -> [(v, Term v a)] +floatDecomp True v b dcmp = (v, b) : dcmp +floatDecomp False _ _ dcmp = dcmp + +floater :: + (Var v, Monoid a) => + Bool -> + (Term v a -> FloatM v a (Term v a)) -> + Term v a -> + Maybe (FloatM v a (Term v a)) +floater top rec tm0@(Ann' tm ty) = + (fmap . fmap) (\tm -> ann a tm ty) (floater top rec tm) + where + a = ABT.annotation tm0 +floater top rec (LetRecNamed' vbs e) = + Just $ + letFloater rec vbs e >>= \case + lm@(LamsNamed' vs bd) | top -> lamWithoutBindingAnns a vs <$> rec bd + where + a = ABT.annotation lm + tm -> rec tm +floater _ rec (Let1Named' v b e) + | Just (vs0, _, vs1, bd) <- unLamsAnnot b = + Just $ + rec bd + >>= lamFloater True b (Just v) a (vs0 ++ vs1) + >>= \lv -> rec $ ABT.renames (Map.singleton v lv) e + where + a = ABT.annotation b +floater top rec tm@(LamsNamed' vs bd) + | top = Just $ lamWithoutBindingAnns a vs <$> rec bd + | otherwise = Just $ do + bd <- rec bd + lv <- lamFloater True tm Nothing a vs bd + pure $ var a lv + where + a = ABT.annotation tm +floater _ _ _ = Nothing + +postFloat :: + (Var v) => + (Monoid a) => + Map v Reference -> + (Set v, [(v, Term v a)], [(v, Term v a)]) -> + ( [(v, Term v a)], + [(v, Id)], + [(Reference, Term v a)], + [(Reference, Term v a)] + ) +postFloat orig (_, bs, dcmp) = + ( subs, + subvs, + fmap (first DerivedId) tops, + dcmp >>= \(v, tm) -> + let stm = open $ ABT.substs dsubs tm + in (subm Map.! v, stm) : [(r, stm) | Just r <- [Map.lookup v orig]] + ) + where + m = + fmap (fmap deannotate) + . hashTermComponentsWithoutTypes + . Map.fromList + $ bs + trips = Map.toList m + f (v, (id, tm)) = ((v, id), (v, idtm), (id, tm)) + where + idtm = ref (ABT.annotation tm) (DerivedId id) + (subvs, subs, tops) = unzip3 $ map f trips + subm = fmap DerivedId (Map.fromList subvs) + dsubs = Map.toList $ Map.map (ref mempty) orig <> Map.fromList subs + +float :: + (Var v) => + (Monoid a) => + Map v Reference -> + Term v a -> + (Term v a, Map Reference Reference, [(Reference, Term v a)], [(Reference, Term v a)]) +float orig tm = case runState go0 (Set.empty, [], []) of + (bd, st) -> case postFloat orig st of + (subs, subvs, tops, dcmp) -> + ( letRec' True [] . ABT.substs subs . deannotate $ bd, + Map.fromList . mapMaybe f $ subvs, + tops, + dcmp + ) + where + f (v, i) = (,DerivedId i) <$> Map.lookup v orig + go0 = fromMaybe (go tm) (floater True go tm) + go = ABT.visit $ floater False go + +floatGroup :: + (Var v) => + (Monoid a) => + Map v Reference -> + [(v, Term v a)] -> + ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)]) +floatGroup orig grp = case runState go0 (Set.empty, [], []) of + (_, st) -> case postFloat orig st of + (_, subvs, tops, dcmp) -> (subvs, tops, dcmp) + where + go = ABT.visit $ floater False go + go0 = groupFloater go grp + +unAnn :: Term v a -> Term v a +unAnn (Ann' tm _) = tm +unAnn tm = tm + +unLamsAnnot :: Term v a -> Maybe ([v], Maybe (Ty.Type v a), [v], Term v a) +unLamsAnnot tm0 + | null vs0, null vs1 = Nothing + | otherwise = Just (vs0, mty, vs1, bd) + where + (vs0, bd0) + | LamsNamed' vs bd <- tm0 = (vs, bd) + | otherwise = ([], tm0) + (mty, bd1) + | Ann' bd ty <- bd0 = (Just ty, bd) + | otherwise = (Nothing, bd0) + (vs1, bd) + | LamsNamed' vs bd <- bd1 = (vs, bd) + | otherwise = ([], bd1) + +deannotate :: (Var v) => Term v a -> Term v a +deannotate = ABT.visitPure $ \case + Ann' c _ -> Just $ deannotate c + _ -> Nothing + +lamLift :: + (Var v) => + (Monoid a) => + Map v Reference -> + Term v a -> + (Term v a, Map Reference Reference, [(Reference, Term v a)], [(Reference, Term v a)]) +lamLift orig = float orig . close Set.empty + +lamLiftGroup :: + (Var v) => + (Monoid a) => + Map v Reference -> + [(v, Term v a)] -> + ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)]) +lamLiftGroup orig gr = floatGroup orig . (fmap . fmap) (close keep) $ gr + where + keep = Set.fromList $ map fst gr + +saturate :: + (Var v, Monoid a) => + Map ConstructorReference Int -> + Term v a -> + Term v a +saturate dat = ABT.visitPure $ \case + Apps' f@(Constructor' r) args -> sat r f args + Apps' f@(Request' r) args -> sat r f args + f@(Constructor' r) -> sat r f [] + f@(Request' r) -> sat r f [] + _ -> Nothing + where + frsh avoid _ = + let v = Var.freshIn avoid $ typed Var.Eta + in (Set.insert v avoid, v) + sat r f args = case Map.lookup r dat of + Just n + | m < n, + vs <- snd $ mapAccumL frsh fvs [1 .. n - m], + nargs <- var mempty <$> vs -> + Just . lamWithoutBindingAnns mempty vs . apps' f $ args' ++ nargs + | m > n, + (sargs, eargs) <- splitAt n args', + sv <- Var.freshIn fvs $ typed Var.Eta -> + Just + . let1' False [(sv, apps' f sargs)] + $ apps' (var mempty sv) eargs + _ -> Just (apps' f args') + where + m = length args + fvs = foldMap freeVars args + args' = saturate dat <$> args + +-- Performs inlining on a supergroup using the inlining information +-- in the map. The map can be created from typical SuperGroup data +-- using the `buildInlineMap` function. +inline :: + (Var v) => + Map Reference (Int, ANormal v) -> + SuperGroup v -> + SuperGroup v +inline inls (Rec bs entry) = Rec (fmap go0 <$> bs) (go0 entry) + where + go0 (Lambda ccs body) = Lambda ccs $ go (30 :: Int) body + -- Note: number argument bails out in recursive inlining cases + go n | n <= 0 = id + go n = ABTN.visitPure \case + TApp (FComb r) args + | Just (arity, expr) <- Map.lookup r inls -> + go (n - 1) <$> tweak expr args arity + _ -> Nothing + + tweak (ABTN.TAbss vs body) args arity + -- exactly saturated + | length args == arity, + rn <- Map.fromList (zip vs args) = + Just $ ABTN.renames rn body + -- oversaturated, only makes sense if body is a call + | length args > arity, + (pre, post) <- splitAt arity args, + rn <- Map.fromList (zip vs pre), + TApp f pre <- ABTN.renames rn body = + Just $ TApp f (pre ++ post) + | otherwise = Nothing + +addDefaultCases :: (Var v) => (Monoid a) => Text -> Term v a -> Term v a +addDefaultCases = ABT.visitPure . defaultCaseVisitor + +defaultCaseVisitor :: + (Var v) => (Monoid a) => Text -> Term v a -> Maybe (Term v a) +defaultCaseVisitor func m@(Match' scrut cases) + | scrut <- addDefaultCases func scrut, + cases <- fmap (addDefaultCases func) <$> cases = + Just $ match a scrut (cases ++ [dflt]) + where + a = ABT.annotation m + v = Var.freshIn mempty $ typed Var.Blank + txt = "pattern match failure in function `" <> func <> "`" + msg = text a txt + bu = ref a (Builtin "bug") + dflt = + MatchCase (P.Var a) Nothing + . ABT.abs' a v + $ apps bu [(a, Ty.tupleTerm [msg, var a v])] +defaultCaseVisitor _ _ = Nothing + +inlineAlias :: (Var v) => (Monoid a) => Term v a -> Term v a +inlineAlias = ABT.visitPure $ \case + Let1Named' v b@(Var' _) e -> Just . inlineAlias $ ABT.subst v b e + _ -> Nothing + +minimizeCyclesOrCrash :: (Var v) => Term v a -> Term v a +minimizeCyclesOrCrash t = case minimize' t of + Right t -> t + Left e -> + internalBug $ + "tried to minimize let rec with duplicate definitions: " + ++ show (fst <$> toList e) + +data Mem = UN | BX deriving (Eq, Ord, Show, Enum) + +-- Context entries with evaluation strategy +data CTE v s + = ST (Direction Word16) [v] [Mem] s + | LZ v (Either Reference v) [v] + deriving (Show) + +pattern ST1 :: Direction Word16 -> v -> Mem -> s -> CTE v s +pattern ST1 d v m s = ST d [v] [m] s + +-- All variables, both bound and free occurring in a CTE. This is +-- useful for avoiding both free and bound variables when +-- freshening. +cteVars :: (Ord v) => Cte v -> Set v +cteVars (ST _ vs _ e) = Set.fromList vs `Set.union` ABTN.freeVars e +cteVars (LZ v r as) = Set.fromList (either (const id) (:) r $ v : as) + +data ANormalF v e + = ALet (Direction Word16) [Mem] e e + | AName (Either Reference v) [v] e + | ALit Lit + | ABLit Lit -- direct boxed literal + | AMatch v (Branched e) + | AShift Reference e + | AHnd [Reference] v e + | AApp (Func v) [v] + | AFrc v + | AVar v + deriving (Show, Eq, Functor, Foldable, Traversable) + +instance Bifunctor ANormalF where + bimap f _ (AVar v) = AVar (f v) + bimap _ _ (ALit l) = ALit l + bimap _ _ (ABLit l) = ABLit l + bimap _ g (ALet d m bn bo) = ALet d m (g bn) (g bo) + bimap f g (AName n as bo) = AName (f <$> n) (f <$> as) $ g bo + bimap f g (AMatch v br) = AMatch (f v) $ fmap g br + bimap f g (AHnd rs v e) = AHnd rs (f v) $ g e + bimap _ g (AShift i e) = AShift i $ g e + bimap f _ (AFrc v) = AFrc (f v) + bimap f _ (AApp fu args) = AApp (fmap f fu) $ fmap f args + +instance Bifoldable ANormalF where + bifoldMap f _ (AVar v) = f v + bifoldMap _ _ (ALit _) = mempty + bifoldMap _ _ (ABLit _) = mempty + bifoldMap _ g (ALet _ _ b e) = g b <> g e + bifoldMap f g (AName n as e) = foldMap f n <> foldMap f as <> g e + bifoldMap f g (AMatch v br) = f v <> foldMap g br + bifoldMap f g (AHnd _ h e) = f h <> g e + bifoldMap _ g (AShift _ e) = g e + bifoldMap f _ (AFrc v) = f v + bifoldMap f _ (AApp func args) = foldMap f func <> foldMap f args + +instance ABTN.Align ANormalF where + align f _ (AVar u) (AVar v) = Just $ AVar <$> f u v + align _ _ (ALit l) (ALit r) + | l == r = Just $ pure (ALit l) + align _ _ (ABLit l) (ABLit r) + | l == r = Just $ pure (ABLit l) + align _ g (ALet dl ccl bl el) (ALet dr ccr br er) + | dl == dr, + ccl == ccr = + Just $ ALet dl ccl <$> g bl br <*> g el er + align f g (AName hl asl el) (AName hr asr er) + | length asl == length asr, + Just hs <- alignEither f hl hr = + Just $ + AName + <$> hs + <*> traverse (uncurry f) (zip asl asr) + <*> g el er + align f g (AMatch vl bsl) (AMatch vr bsr) + | Just bss <- alignBranch g bsl bsr = + Just $ AMatch <$> f vl vr <*> bss + align f g (AHnd rl hl bl) (AHnd rr hr br) + | rl == rr = Just $ AHnd rl <$> f hl hr <*> g bl br + align _ g (AShift rl bl) (AShift rr br) + | rl == rr = Just $ AShift rl <$> g bl br + align f _ (AFrc u) (AFrc v) = Just $ AFrc <$> f u v + align f _ (AApp hl asl) (AApp hr asr) + | Just hs <- alignFunc f hl hr, + length asl == length asr = + Just $ AApp <$> hs <*> traverse (uncurry f) (zip asl asr) + align _ _ _ _ = Nothing + +alignEither :: + (Applicative f) => + (l -> r -> f s) -> + Either Reference l -> + Either Reference r -> + Maybe (f (Either Reference s)) +alignEither _ (Left rl) (Left rr) | rl == rr = Just . pure $ Left rl +alignEither f (Right u) (Right v) = Just $ Right <$> f u v +alignEither _ _ _ = Nothing + +alignMaybe :: + (Applicative f) => + (l -> r -> f s) -> + Maybe l -> + Maybe r -> + Maybe (f (Maybe s)) +alignMaybe f (Just l) (Just r) = Just $ Just <$> f l r +alignMaybe _ Nothing Nothing = Just (pure Nothing) +alignMaybe _ _ _ = Nothing + +alignFunc :: + (Applicative f) => + (vl -> vr -> f vs) -> + Func vl -> + Func vr -> + Maybe (f (Func vs)) +alignFunc f (FVar u) (FVar v) = Just $ FVar <$> f u v +alignFunc _ (FComb rl) (FComb rr) | rl == rr = Just . pure $ FComb rl +alignFunc f (FCont u) (FCont v) = Just $ FCont <$> f u v +alignFunc _ (FCon rl tl) (FCon rr tr) + | rl == rr, tl == tr = Just . pure $ FCon rl tl +alignFunc _ (FReq rl tl) (FReq rr tr) + | rl == rr, tl == tr = Just . pure $ FReq rl tl +alignFunc _ (FPrim ol) (FPrim or) + | ol == or = Just . pure $ FPrim ol +alignFunc _ _ _ = Nothing + +alignBranch :: + (Applicative f) => + (el -> er -> f es) -> + Branched el -> + Branched er -> + Maybe (f (Branched es)) +alignBranch _ MatchEmpty MatchEmpty = Just $ pure MatchEmpty +alignBranch f (MatchIntegral bl dl) (MatchIntegral br dr) + | keysSet bl == keysSet br, + Just ds <- alignMaybe f dl dr = + Just $ + MatchIntegral + <$> interverse f bl br + <*> ds +alignBranch f (MatchText bl dl) (MatchText br dr) + | Map.keysSet bl == Map.keysSet br, + Just ds <- alignMaybe f dl dr = + Just $ + MatchText + <$> traverse id (Map.intersectionWith f bl br) + <*> ds +alignBranch f (MatchRequest bl pl) (MatchRequest br pr) + | Map.keysSet bl == Map.keysSet br, + all p (Map.keysSet bl) = + Just $ + MatchRequest + <$> traverse id (Map.intersectionWith (interverse (alignCCs f)) bl br) + <*> f pl pr + where + p r = keysSet hsl == keysSet hsr && all q (keys hsl) + where + hsl = bl Map.! r + hsr = br Map.! r + q t = fst (hsl ! t) == fst (hsr ! t) +alignBranch f (MatchData rfl bl dl) (MatchData rfr br dr) + | rfl == rfr, + keysSet bl == keysSet br, + all (\t -> fst (bl ! t) == fst (br ! t)) (keys bl), + Just ds <- alignMaybe f dl dr = + Just $ MatchData rfl <$> interverse (alignCCs f) bl br <*> ds +alignBranch f (MatchSum bl) (MatchSum br) + | keysSet bl == keysSet br, + all (\w -> fst (bl ! w) == fst (br ! w)) (keys bl) = + Just $ MatchSum <$> interverse (alignCCs f) bl br +alignBranch f (MatchNumeric rl bl dl) (MatchNumeric rr br dr) + | rl == rr, + keysSet bl == keysSet br, + Just ds <- alignMaybe f dl dr = + Just $ + MatchNumeric rl + <$> interverse f bl br + <*> ds +alignBranch _ _ _ = Nothing + +alignCCs :: (Functor f) => (l -> r -> f s) -> (a, l) -> (a, r) -> f (a, s) +alignCCs f (ccs, l) (_, r) = (,) ccs <$> f l r + +matchLit :: Term v a -> Maybe Lit +matchLit (Int' i) = Just $ I i +matchLit (Nat' n) = Just $ N n +matchLit (Float' f) = Just $ F f +matchLit (Text' t) = Just $ T (Util.Text.fromText t) +matchLit (Char' c) = Just $ C c +matchLit _ = Nothing + +pattern TLet :: + (ABT.Var v) => + Direction Word16 -> + v -> + Mem -> + ABTN.Term ANormalF v -> + ABTN.Term ANormalF v -> + ABTN.Term ANormalF v +pattern TLet d v m bn bo = ABTN.TTm (ALet d [m] bn (ABTN.TAbs v bo)) + +pattern TLetD :: + (ABT.Var v) => + v -> + Mem -> + ABTN.Term ANormalF v -> + ABTN.Term ANormalF v -> + ABTN.Term ANormalF v +pattern TLetD v m bn bo = ABTN.TTm (ALet Direct [m] bn (ABTN.TAbs v bo)) + +pattern TLets :: + (ABT.Var v) => + Direction Word16 -> + [v] -> + [Mem] -> + ABTN.Term ANormalF v -> + ABTN.Term ANormalF v -> + ABTN.Term ANormalF v +pattern TLets d vs ms bn bo = ABTN.TTm (ALet d ms bn (ABTN.TAbss vs bo)) + +pattern TName :: + (ABT.Var v) => + v -> + Either Reference v -> + [v] -> + ABTN.Term ANormalF v -> + ABTN.Term ANormalF v +pattern TName v f as bo = ABTN.TTm (AName f as (ABTN.TAbs v bo)) + +pattern Lit' :: Lit -> Term v a +pattern Lit' l <- (matchLit -> Just l) + +pattern TLit :: + (ABT.Var v) => + Lit -> + ABTN.Term ANormalF v +pattern TLit l = ABTN.TTm (ALit l) + +pattern TBLit :: + (ABT.Var v) => + Lit -> + ABTN.Term ANormalF v +pattern TBLit l = ABTN.TTm (ABLit l) + +pattern TApp :: + (ABT.Var v) => + Func v -> + [v] -> + ABTN.Term ANormalF v +pattern TApp f args = ABTN.TTm (AApp f args) + +pattern AApv :: v -> [v] -> ANormalF v e +pattern AApv v args = AApp (FVar v) args + +pattern TApv :: + (ABT.Var v) => + v -> + [v] -> + ABTN.Term ANormalF v +pattern TApv v args = TApp (FVar v) args + +pattern ACom :: Reference -> [v] -> ANormalF v e +pattern ACom r args = AApp (FComb r) args + +pattern TCom :: + (ABT.Var v) => + Reference -> + [v] -> + ABTN.Term ANormalF v +pattern TCom r args = TApp (FComb r) args + +pattern ACon :: Reference -> CTag -> [v] -> ANormalF v e +pattern ACon r t args = AApp (FCon r t) args + +pattern TCon :: + (ABT.Var v) => + Reference -> + CTag -> + [v] -> + ABTN.Term ANormalF v +pattern TCon r t args = TApp (FCon r t) args + +pattern AKon :: v -> [v] -> ANormalF v e +pattern AKon v args = AApp (FCont v) args + +pattern TKon :: + (ABT.Var v) => + v -> + [v] -> + ABTN.Term ANormalF v +pattern TKon v args = TApp (FCont v) args + +pattern AReq :: Reference -> CTag -> [v] -> ANormalF v e +pattern AReq r t args = AApp (FReq r t) args + +pattern TReq :: + (ABT.Var v) => + Reference -> + CTag -> + [v] -> + ABTN.Term ANormalF v +pattern TReq r t args = TApp (FReq r t) args + +pattern APrm :: POp -> [v] -> ANormalF v e +pattern APrm p args = AApp (FPrim (Left p)) args + +pattern TPrm :: + (ABT.Var v) => + POp -> + [v] -> + ABTN.Term ANormalF v +pattern TPrm p args = TApp (FPrim (Left p)) args + +pattern AFOp :: ForeignFunc -> [v] -> ANormalF v e +pattern AFOp p args = AApp (FPrim (Right p)) args + +pattern TFOp :: + (ABT.Var v) => + ForeignFunc -> + [v] -> + ABTN.Term ANormalF v +pattern TFOp p args = TApp (FPrim (Right p)) args + +pattern THnd :: + (ABT.Var v) => + [Reference] -> + v -> + ABTN.Term ANormalF v -> + ABTN.Term ANormalF v +pattern THnd rs h b = ABTN.TTm (AHnd rs h b) + +pattern TShift :: + (ABT.Var v) => + Reference -> + v -> + ABTN.Term ANormalF v -> + ABTN.Term ANormalF v +pattern TShift i v e = ABTN.TTm (AShift i (ABTN.TAbs v e)) + +pattern TMatch :: + (ABT.Var v) => + v -> + Branched (ABTN.Term ANormalF v) -> + ABTN.Term ANormalF v +pattern TMatch v cs = ABTN.TTm (AMatch v cs) + +pattern TFrc :: (ABT.Var v) => v -> ABTN.Term ANormalF v +pattern TFrc v = ABTN.TTm (AFrc v) + +pattern TVar :: (ABT.Var v) => v -> ABTN.Term ANormalF v +pattern TVar v = ABTN.TTm (AVar v) + +{-# COMPLETE TLet, TName, TVar, TApp, TFrc, TLit, THnd, TShift, TMatch #-} + +{-# COMPLETE + TLet, + TName, + TVar, + TFrc, + TApv, + TCom, + TCon, + TKon, + TReq, + TPrm, + TFOp, + TLit, + THnd, + TShift, + TMatch + #-} + +bind :: (Var v) => Cte v -> ANormal v -> ANormal v +bind (ST d us ms bu) = TLets d us ms bu +bind (LZ u f as) = TName u f as + +unbind :: (Var v) => ANormal v -> Maybe (Cte v, ANormal v) +unbind (TLets d us ms bu bd) = Just (ST d us ms bu, bd) +unbind (TName u f as bd) = Just (LZ u f as, bd) +unbind _ = Nothing + +unbinds :: (Var v) => ANormal v -> ([Cte v], ANormal v) +unbinds (TLets d us ms bu (unbinds -> (ctx, bd))) = + (ST d us ms bu : ctx, bd) +unbinds (TName u f as (unbinds -> (ctx, bd))) = (LZ u f as : ctx, bd) +unbinds tm = ([], tm) + +pattern TBind :: + (Var v) => + Cte v -> + ANormal v -> + ANormal v +pattern TBind bn bd <- + (unbind -> Just (bn, bd)) + where + TBind bn bd = bind bn bd + +pattern TBinds :: (Var v) => [Cte v] -> ANormal v -> ANormal v +pattern TBinds ctx bd <- + (unbinds -> (ctx, bd)) + where + TBinds ctx bd = foldr bind bd ctx + +{-# COMPLETE TBinds #-} + +data SeqEnd = SLeft | SRight + deriving (Eq, Ord, Enum, Show) + +-- Note: MatchNumeric is a new form for matching directly on boxed +-- numeric data. This leaves MatchIntegral around so that builtins can +-- continue to use it. But interchanged code can be free of unboxed +-- details. +data Branched e + = MatchIntegral (EnumMap Word64 e) (Maybe e) + | MatchText (Map.Map Util.Text.Text e) (Maybe e) + | MatchRequest (Map Reference (EnumMap CTag ([Mem], e))) e + | MatchEmpty + | MatchData Reference (EnumMap CTag ([Mem], e)) (Maybe e) + | MatchSum (EnumMap Word64 ([Mem], e)) + | MatchNumeric Reference (EnumMap Word64 e) (Maybe e) + deriving (Show, Eq, Functor, Foldable, Traversable) + +-- Data cases expected to cover all constructors +pattern MatchDataCover :: Reference -> EnumMap CTag ([Mem], e) -> Branched e +pattern MatchDataCover r m = MatchData r m Nothing + +data BranchAccum v + = AccumEmpty + | AccumIntegral + Reference + (Maybe (ANormal v)) + (EnumMap Word64 (ANormal v)) + | AccumText + (Maybe (ANormal v)) + (Map.Map Util.Text.Text (ANormal v)) + | AccumDefault (ANormal v) + | AccumPure (ANormal v) + | AccumRequest + (Map Reference (EnumMap CTag ([Mem], ANormal v))) + (Maybe (ANormal v)) + | AccumData + Reference + (Maybe (ANormal v)) + (EnumMap CTag ([Mem], ANormal v)) + | AccumSeqEmpty (ANormal v) + | AccumSeqView + SeqEnd + (Maybe (ANormal v)) -- empty + (ANormal v) -- cons/snoc + | AccumSeqSplit + SeqEnd + Int -- split at + (Maybe (ANormal v)) -- default + (ANormal v) -- split + +instance Semigroup (BranchAccum v) where + AccumEmpty <> r = r + l <> AccumEmpty = l + AccumIntegral rl dl cl <> AccumIntegral rr dr cr + | rl == rr = AccumIntegral rl (dl <|> dr) $ cl <> cr + AccumText dl cl <> AccumText dr cr = + AccumText (dl <|> dr) (cl <> cr) + AccumData rl dl cl <> AccumData rr dr cr + | rl == rr = AccumData rl (dl <|> dr) (cl <> cr) + AccumDefault dl <> AccumIntegral r _ cr = + AccumIntegral r (Just dl) cr + AccumDefault dl <> AccumText _ cr = + AccumText (Just dl) cr + AccumDefault dl <> AccumData rr _ cr = + AccumData rr (Just dl) cr + AccumIntegral r dl cl <> AccumDefault dr = + AccumIntegral r (dl <|> Just dr) cl + AccumText dl cl <> AccumDefault dr = + AccumText (dl <|> Just dr) cl + AccumData rl dl cl <> AccumDefault dr = + AccumData rl (dl <|> Just dr) cl + l@(AccumPure _) <> AccumPure _ = l + AccumPure dl <> AccumRequest hr _ = AccumRequest hr (Just dl) + AccumRequest hl dl <> AccumPure dr = + AccumRequest hl (dl <|> Just dr) + AccumRequest hl dl <> AccumRequest hr dr = + AccumRequest hm $ dl <|> dr + where + hm = Map.unionWith (<>) hl hr + l@(AccumSeqEmpty _) <> AccumSeqEmpty _ = l + AccumSeqEmpty eml <> AccumSeqView er _ cnr = + AccumSeqView er (Just eml) cnr + AccumSeqView el eml cnl <> AccumSeqEmpty emr = + AccumSeqView el (eml <|> Just emr) cnl + AccumSeqView el eml cnl <> AccumSeqView er emr _ + | el /= er = + internalBug "AccumSeqView: trying to merge views of opposite ends" + | otherwise = AccumSeqView el (eml <|> emr) cnl + AccumSeqView _ _ _ <> AccumDefault _ = + internalBug "seq views may not have defaults" + AccumDefault _ <> AccumSeqView _ _ _ = + internalBug "seq views may not have defaults" + AccumSeqSplit el nl dl bl <> AccumSeqSplit er nr dr _ + | el /= er = + internalBug + "AccumSeqSplit: trying to merge splits at opposite ends" + | nl /= nr = + internalBug + "AccumSeqSplit: trying to merge splits at different positions" + | otherwise = + AccumSeqSplit el nl (dl <|> dr) bl + AccumDefault dl <> AccumSeqSplit er nr _ br = + AccumSeqSplit er nr (Just dl) br + AccumSeqSplit el nl dl bl <> AccumDefault dr = + AccumSeqSplit el nl (dl <|> Just dr) bl + _ <> _ = internalBug $ "cannot merge data cases for different types" + +instance Monoid (BranchAccum e) where + mempty = AccumEmpty + +data Func v + = -- variable + FVar v + | -- top-level combinator + FComb !Reference + | -- continuation jump + FCont v + | -- data constructor + FCon !Reference !CTag + | -- ability request + FReq !Reference !CTag + | -- prim op + FPrim (Either POp ForeignFunc) + deriving (Show, Eq, Functor, Foldable, Traversable) + +data Lit + = I Int64 + | N Word64 + | F Double + | T Util.Text.Text + | C Char + | LM Referent -- Term Link + | LY Reference -- Type Link + deriving (Show, Eq) + +litRef :: Lit -> Reference +litRef (I _) = Ty.intRef +litRef (N _) = Ty.natRef +litRef (F _) = Ty.floatRef +litRef (T _) = Ty.textRef +litRef (C _) = Ty.charRef +litRef (LM _) = Ty.termLinkRef +litRef (LY _) = Ty.typeLinkRef + +-- Note: Enum/Bounded instances should only be used for things like +-- getting a list of all ops. Using auto-generated numberings for +-- serialization, for instance, could cause observable changes to +-- formats that we want to control and version. +data POp + = -- Int + ADDI -- + + | SUBI -- - + | MULI + | DIVI -- / + | SGNI -- sgn + | NEGI -- neg + | MODI -- mod + | POWI -- pow + | SHLI -- shiftl + | SHRI -- shiftr + | ANDI -- and + | IORI -- or + | XORI -- xor + | COMI -- complement + | INCI -- inc + | DECI -- dec + | LEQI -- <= + | LESI -- < + | EQLI -- == + | NEQI -- != + | TRNC -- truncate0 + -- Nat + | ADDN -- + + | SUBN -- - + | DRPN -- drop + | MULN + | DIVN -- / + | MODN -- mod + | TZRO -- trailingZeros + | LZRO -- leadingZeros + | POPC -- popCount + | POWN -- pow + | SHLN -- shiftl + | SHRN -- shiftr + | ANDN -- and + | IORN -- or + | XORN -- xor + | COMN -- complement + | INCN -- inc + | DECN -- dec + | LEQN -- <= + | LESN -- < + | EQLN -- == + | NEQN -- != + -- Float + | ADDF -- + + | SUBF -- - + | MULF + | DIVF -- / + | MINF -- min + | MAXF -- max + | LEQF -- <= + | LESF -- < + | EQLF -- == + | NEQF -- != + | POWF -- pow + | EXPF -- exp + | SQRT -- sqrt + | LOGF -- log + | LOGB -- logBase + | ABSF -- abs + | CEIL -- ceil + | FLOR -- floor + | TRNF -- truncate + | RNDF -- round + -- Trig + | COSF -- cos + | ACOS -- acos + | COSH -- cosh + | ACSH -- acosh + | SINF -- sin + | ASIN -- asin + | SINH -- sinh + | ASNH -- asinh + | TANF -- tan + | ATAN -- atan + | TANH -- tanh + | ATNH -- atanh + | ATN2 -- atan2 + -- Text + | CATT -- ++ + | TAKT -- take + | DRPT -- drop + | SIZT -- size + | IXOT -- indexOf + | UCNS -- uncons + | USNC -- unsnoc + | EQLT -- == + | LEQT -- <= + | PAKT -- pack + | UPKT -- unpack + -- Sequence + | CATS -- ++ + | TAKS -- take + | DRPS -- drop + | SIZS -- size + | CONS -- cons + | SNOC -- snoc + | IDXS -- at + | BLDS -- build + | VWLS -- viewl + | VWRS -- viewr + | SPLL -- splitl + | SPLR -- splitr + -- Bytes + | PAKB -- pack + | UPKB -- unpack + | TAKB -- take + | DRPB -- drop + | IXOB -- indexOf + | IDXB -- index + | SIZB -- size + | FLTB -- flatten + | CATB -- append + -- Conversion + | ITOF -- intToFloat + | NTOF -- natToFloat + | ITOT -- intToText + | NTOT -- natToText + | TTOI -- textToInt + | TTON -- textToNat + | TTOF -- textToFloat + | FTOT -- floatToText + | CAST -- runtime type cast for unboxed values. + | -- Concurrency + FORK -- fork + | -- Universal operations + EQLU -- == + | CMPU -- compare + | LEQU -- <= + | LESU -- < + | EROR -- error + | -- Code + MISS -- isMissing + | CACH -- cache_ + | LKUP -- lookup + | LOAD -- load + | CVLD -- validate + | SDBX -- sandbox + | VALU -- value + | TLTT -- Term.Link.toText + -- Debug + | PRNT -- print + | INFO -- info + | TRCE -- trace + | DBTX -- debugText + | -- STM + ATOM -- atomically + | TFRC -- try force + | SDBL -- sandbox link list + | SDBV -- sandbox check for Values + -- Refs + | REFN -- Ref.new + | REFR -- Ref.read + | REFW -- Ref.write + | RCAS -- Ref.cas + | RRFC -- Ref.readForCas + | TIKR -- Ref.Ticket.read + -- Bools + | NOTB -- not + | ANDB -- and + | IORB -- or + deriving (Show, Eq, Ord, Enum, Bounded) + +type ANormal = ABTN.Term ANormalF + +type Cte v = CTE v (ANormal v) + +type Ctx v = Directed () [Cte v] + +data Direction a = Indirect a | Direct + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +directed :: (Foldable f) => f (Cte v) -> Directed () (f (Cte v)) +directed x = (foldMap f x, x) + where + f (ST d _ _ _) = () <$ d + f _ = Direct + +instance (Semigroup a) => Semigroup (Direction a) where + Indirect l <> Indirect r = Indirect $ l <> r + Direct <> r = r + l <> Direct = l + +instance (Semigroup a) => Monoid (Direction a) where + mempty = Direct + +type Directed a = (,) (Direction a) + +type DNormal v = Directed () (ANormal v) + +-- Should be a completely closed term +data SuperNormal v = Lambda {conventions :: [Mem], bound :: ANormal v} + deriving (Show, Eq) + +data SuperGroup v = Rec + { group :: [(v, SuperNormal v)], + entry :: SuperNormal v + } + deriving (Show) + +-- | Whether the evaluation of a given definition is cacheable or not. +-- i.e. it's a top-level pure value. +data Cacheability = Cacheable | Uncacheable + deriving stock (Eq, Show) + +instance (Var v) => Eq (SuperGroup v) where + g0 == g1 | Left _ <- equivocate g0 g1 = False | otherwise = True + +-- Failure modes for SuperGroup alpha equivalence test +data SGEqv v + = -- mismatch number of definitions in group + NumDefns (SuperGroup v) (SuperGroup v) + | -- mismatched SuperNormal calling conventions + DefnConventions (SuperNormal v) (SuperNormal v) + | -- mismatched subterms in corresponding definition + Subterms (ANormal v) (ANormal v) + +-- Yields the number of arguments directly accepted by a combinator. +arity :: SuperNormal v -> Int +arity (Lambda ccs _) = length ccs + +-- Yields the numbers of arguments directly accepted by the +-- combinators in a group. The main entry is the first element, and +-- local bindings follow in their original order. +arities :: SuperGroup v -> [Int] +arities (Rec bs e) = arity e : fmap (arity . snd) bs + +-- Checks the body of a SuperGroup makes it eligible for inlining. +-- See below for the discussion. +isInlinable :: (Var v) => Reference -> ANormal v -> Bool +isInlinable r (TApp (FComb s) _) = r /= s +isInlinable _ TApp {} = True +isInlinable _ TBLit {} = True +isInlinable _ TVar {} = True +isInlinable _ _ = False + +-- Checks a SuperGroup makes it eligible to be inlined. +-- Unfortunately we need to be quite conservative about this. +-- +-- The heuristic implemented below is as follows: +-- +-- 1. There are no local bindings, so only the 'entry point' +-- matters. +-- 2. The entry point body is just a single expression, that is, +-- an application, variable or literal. +-- +-- The first condition ensures that there isn't any need to jump +-- into a non-entrypoint from outside a group. These should be rare +-- anyway, because the local bindings are no longer used for +-- (unison-level) local function definitions (those are lifted +-- out). The second condition ensures that inlining the body should +-- have no effect on the runtime stack of of the function we're +-- inlining into, because the combinator is just a wrapper around +-- the simple expression. +-- +-- Fortunately, it should be possible to make _most_ builtins have +-- this form, so that their instructions can be inlined directly +-- into the call sites when saturated. +-- +-- The result of this function is the information necessary to +-- inline the combinator—an arity and the body expression with +-- bound variables. This should allow checking if the call is +-- saturated and make it possible to locally substitute for an +-- inlined expression. +-- +-- The `Reference` argument allows us to check if the body is a +-- direct recursive call to the same function, which would result +-- in infinite inlining. This isn't the only such scenario, but +-- it's one we can opportunistically rule out. +inlineInfo :: (Var v) => Reference -> SuperGroup v -> Maybe (Int, ANormal v) +inlineInfo r (Rec [] (Lambda ccs body@(ABTN.TAbss _ e))) + | isInlinable r e = Just (length ccs, body) +inlineInfo _ _ = Nothing + +-- Builds inlining information from a collection of SuperGroups. +-- They are all tested for inlinability, and the result map +-- contains only the information for groups that are able to be +-- inlined. +buildInlineMap :: + (Var v) => + Map Reference (SuperGroup v) -> + Map Reference (Int, ANormal v) +buildInlineMap = + runIdentity + . Map.traverseMaybeWithKey (\r g -> Identity $ inlineInfo r g) + +-- Checks if two SuperGroups are equivalent up to renaming. The rest +-- of the structure must match on the nose. If the two groups are not +-- equivalent, an example of conflicting structure is returned. +equivocate :: + (Var v) => + SuperGroup v -> + SuperGroup v -> + Either (SGEqv v) () +equivocate g0@(Rec bs0 e0) g1@(Rec bs1 e1) + | length bs0 == length bs1 = + traverse_ eqvSN (zip ns0 ns1) *> eqvSN (e0, e1) + | otherwise = Left $ NumDefns g0 g1 + where + (vs0, ns0) = unzip bs0 + (vs1, ns1) = unzip bs1 + vm = Map.fromList (zip vs1 vs0) + + promote (Left (l, r)) = Left $ Subterms l r + promote (Right v) = Right v + + eqvSN (Lambda ccs0 e0, Lambda ccs1 e1) + | ccs0 == ccs1 = promote $ ABTN.alpha vm e0 e1 + eqvSN (n0, n1) = Left $ DefnConventions n0 n1 + +type ANFM v = + ReaderT + (Set v) + (State (Word64, Word16, [(v, SuperNormal v)])) + +type ANFD v = Compose (ANFM v) (Directed ()) + +data GroupRef = GR Reference Word64 + deriving (Show, Eq) + +-- | A list of either unboxed or boxed values. +-- Each slot is one of unboxed or boxed but not both. +type ValList = [Value] + +data Value + = Partial GroupRef ValList + | Data Reference Word64 ValList + | Cont ValList Cont + | BLit BLit + deriving (Show, Eq) + +-- Since we can now track cacheability of supergroups, this type +-- pairs the two together. This is the type that should be used +-- as the representation of unison Code values rather than the +-- previous `SuperGroup Symbol`. +data Code = CodeRep (SuperGroup Symbol) Cacheability + deriving (Show) + +codeGroup :: Code -> SuperGroup Symbol +codeGroup (CodeRep sg _) = sg + +instance Eq Code where + CodeRep sg1 _ == CodeRep sg2 _ = sg1 == sg2 + +overGroup :: (SuperGroup Symbol -> SuperGroup Symbol) -> Code -> Code +overGroup f (CodeRep sg ch) = CodeRep (f sg) ch + +foldGroup :: (Monoid m) => (SuperGroup Symbol -> m) -> Code -> m +foldGroup f (CodeRep sg _) = f sg + +traverseGroup :: + (Applicative f) => + (SuperGroup Symbol -> f (SuperGroup Symbol)) -> + Code -> + f Code +traverseGroup f (CodeRep sg ch) = flip CodeRep ch <$> f sg + +data Cont + = KE + | Mark + Word64 -- pending args + [Reference] + (Map Reference Value) + Cont + | Push + Word64 -- Frame size + Word64 -- Pending args + GroupRef + Cont + deriving (Show, Eq) + +data BLit + = Text Util.Text.Text + | List (Seq Value) + | TmLink Referent + | TyLink Reference + | Bytes Bytes + | Quote Value + | Code Code + | BArr PA.ByteArray + | Arr (PA.Array Value) + | -- Despite the following being in the Boxed Literal type, they all represent unboxed values + Pos Word64 + | Neg Word64 + | Char Char + | Float Double + deriving (Show, Eq) + +groupVars :: ANFM v (Set v) +groupVars = ask + +bindLocal :: (Ord v) => [v] -> ANFM v r -> ANFM v r +bindLocal vs = local (Set.\\ Set.fromList vs) + +freshANF :: (Var v) => Word64 -> v +freshANF fr = Var.freshenId fr $ typed Var.ANFBlank + +fresh :: (Var v) => ANFM v v +fresh = state $ \(fr, bnd, cs) -> (freshANF fr, (fr + 1, bnd, cs)) + +contextualize :: (Var v) => DNormal v -> ANFM v (Ctx v, v) +contextualize (_, TVar cv) = do + gvs <- groupVars + if cv `Set.notMember` gvs + then pure (pure [], cv) + else do + bv <- fresh + d <- Indirect <$> binder + pure (directed [ST1 d bv BX $ TApv cv []], bv) +contextualize (d0, tm) = do + fv <- fresh + d <- bindDirection d0 + pure ((d0, [ST1 d fv BX tm]), fv) + +binder :: ANFM v Word16 +binder = state $ \(fr, bnd, cs) -> (bnd, (fr, bnd + 1, cs)) + +bindDirection :: Direction a -> ANFM v (Direction Word16) +bindDirection = traverse (const binder) + +record :: (Var v) => (v, SuperNormal v) -> ANFM v () +record p = modify $ \(fr, bnd, to) -> (fr, bnd, p : to) + +superNormalize :: (Var v) => Term v a -> SuperGroup v +superNormalize tm = Rec l c + where + (bs, e) + | LetRecNamed' bs e <- tm = (bs, e) + | otherwise = ([], tm) + grp = Set.fromList $ fst <$> bs + comp = traverse_ superBinding bs *> toSuperNormal e + subc = runReaderT comp grp + (c, (_, _, l)) = runState subc (0, 1, []) + +superBinding :: (Var v) => (v, Term v a) -> ANFM v () +superBinding (v, tm) = do + nf <- toSuperNormal tm + modify $ \(cvs, bnd, ctx) -> (cvs, bnd, (v, nf) : ctx) + +toSuperNormal :: (Var v) => Term v a -> ANFM v (SuperNormal v) +toSuperNormal tm = do + grp <- groupVars + if not . Set.null . (Set.\\ grp) $ freeVars tm + then internalBug $ "free variables in supercombinator: " ++ show tm + else + Lambda (BX <$ vs) . ABTN.TAbss vs . snd + <$> bindLocal vs (anfTerm body) + where + (vs, body) = fromMaybe ([], tm) $ unLams' tm + +anfTerm :: (Var v) => Term v a -> ANFM v (DNormal v) +anfTerm tm = f <$> anfBlock tm + where + -- f = uncurry (liftA2 TBinds) + f ((_, []), dtm) = dtm + f ((_, cx), (_, tm)) = (Indirect (), TBinds cx tm) + +floatableCtx :: (Var v) => Ctx v -> Bool +floatableCtx = all p . snd + where + p (LZ _ _ _) = True + p (ST _ _ _ tm) = q tm + q (TLit _) = True + q (TVar _) = True + q (TCon _ _ _) = True + q _ = False + +anfHandled :: (Var v) => Term v a -> ANFM v (Ctx v, DNormal v) +anfHandled body = + anfBlock body >>= \case + (ctx, (_, t@TCon {})) -> + fresh <&> \v -> + (ctx <> pure [ST1 Direct v BX t], pure $ TVar v) + (ctx, (_, t@(TLit l))) -> + fresh <&> \v -> + (ctx <> pure [ST1 Direct v cc t], pure $ TVar v) + where + cc = case l of T {} -> BX; LM {} -> BX; LY {} -> BX; _ -> UN + p -> pure p + +pattern UFalse <- TCon ((== Ty.booleanRef) -> True) 0 [] + where + UFalse = TCon Ty.booleanRef 0 [] + +pattern UTrue <- TCon ((== Ty.booleanRef) -> True) 1 [] + where + UTrue = TCon Ty.booleanRef 1 [] + +-- Helper function for renaming a variable arising from a +-- let v = u +-- binding during ANF translation. Renames a variable in a +-- context, and returns an indication of whether the varible +-- was shadowed by one of the context bindings. +-- +-- Note: this assumes that `u` is not bound by any of the context +-- entries, as no effort is made to rename them to avoid capturing +-- `u`. +renameCtx :: (Var v) => v -> v -> Ctx v -> (Ctx v, Bool) +renameCtx v u (d, ctx) | (ctx, b) <- renameCtes v u ctx = ((d, ctx), b) + +-- As above, but without the Direction. +renameCtes :: (Var v) => v -> v -> [Cte v] -> ([Cte v], Bool) +renameCtes v u = rn [] + where + swap w + | w == v = u + | otherwise = w + + rn acc [] = (reverse acc, False) + rn acc (ST d vs ccs b : es) + | any (== v) vs = (reverse acc ++ e : es, True) + | otherwise = rn (e : acc) es + where + e = ST d vs ccs $ ABTN.rename v u b + rn acc (LZ w f as : es) + | w == v = (reverse acc ++ e : es, True) + | otherwise = rn (e : acc) es + where + e = LZ w (swap <$> f) (swap <$> as) + +-- Simultaneously renames variables in a list of context entries. +-- +-- Assumes that the variables being renamed to are not bound by the +-- context entries, so that it is unnecessary to rename them. +renamesCtes :: (Var v) => Map v v -> [Cte v] -> [Cte v] +renamesCtes rn = map f + where + swap w + | Just u <- Map.lookup w rn = u + | otherwise = w + + f (ST d vs ccs b) = ST d vs ccs (ABTN.renames rn b) + f (LZ v r as) = LZ v (second swap r) (map swap as) + +-- Calculates the free variables occurring in a context. This +-- consists of the free variables in the expressions being bound, +-- but with previously bound variables subtracted. +freeVarsCtx :: (Ord v) => Ctx v -> Set v +freeVarsCtx = freeVarsCte . snd + +freeVarsCte :: (Ord v) => [Cte v] -> Set v +freeVarsCte = foldr m Set.empty + where + m (ST _ vs _ bn) rest = + ABTN.freeVars bn `Set.union` (rest Set.\\ Set.fromList vs) + m (LZ v r as) rest = + Set.fromList (either (const id) (:) r as) + `Set.union` Set.delete v rest + +-- Conditionally freshens a list of variables. The predicate +-- argument selects which variables to freshen, and the set is a set +-- of variables to avoid for freshness. The process ensures that the +-- result is mutually fresh, and returns a new set of variables to +-- avoid, which includes the freshened variables. +-- +-- Presumably any variables selected by the predicate should be +-- included in the set, but the set may contain additional variables +-- to avoid, when freshening. +freshens :: (Var v) => (v -> Bool) -> Set v -> [v] -> (Set v, [v]) +freshens p avoid0 vs = + mapAccumL f (Set.union avoid0 (Set.fromList vs)) vs + where + f avoid v + | p v, u <- Var.freshIn avoid v = (Set.insert u avoid, u) + | otherwise = (avoid, v) + +-- Freshens the variable bindings in a context to avoid a set of +-- variables. Returns the renaming necessary for anything that was +-- bound in the freshened context. +-- +-- Note: this only freshens if it's necessary to avoid variables in +-- the _original_ set. We need to keep track of other variables to +-- avoid when making up new names for those, but it it isn't +-- necessary to freshen variables to remove shadowing _within_ the +-- context, since it is presumably already correctly formed. +freshenCtx :: (Var v) => Set v -> Ctx v -> (Map v v, Ctx v) +freshenCtx avoid0 (d, ctx) = + case go lavoid Map.empty [] $ reverse ctx of + (rn, ctx) -> (rn, (d, ctx)) + where + -- precalculate all variable occurrences in the context to just + -- completely avoid those as well. + lavoid = + foldl (flip $ Set.union . cteVars) avoid0 ctx + + go _ rns fresh [] = (rns, fresh) + go avoid rns fresh (bn : bns) = case bn of + LZ v r as + | v `Set.member` avoid0, + u <- Var.freshIn avoid v, + (fresh, _) <- renameCtes v u fresh, + avoid <- Set.insert u avoid, + rns <- Map.alter (Just . fromMaybe u) v rns -> + go avoid rns (LZ u r as : fresh) bns + ST d vs ccs expr + | (avoid, us) <- freshens (`Set.member` avoid0) avoid vs, + rn <- Map.fromList (filter (uncurry (/=)) $ zip vs us), + not (Map.null rn), + fresh <- renamesCtes rn fresh, + -- Note: rns union left-biased, so inner contexts take + -- priority. + rns <- Map.union rns rn -> + go avoid rns (ST d us ccs expr : fresh) bns + _ -> go avoid rns (bn : fresh) bns + +anfBlock :: (Ord v, Var v) => Term v a -> ANFM v (Ctx v, DNormal v) +anfBlock (Var' v) = pure (mempty, pure $ TVar v) +anfBlock (If' c t f) = do + (cctx, cc) <- anfBlock c + (df, cf) <- anfTerm f + (dt, ct) <- anfTerm t + (cx, v) <- contextualize cc + let cases = + MatchData + (Builtin $ Data.Text.pack "Boolean") + (EC.mapSingleton 0 ([], cf)) + (Just ct) + pure (cctx <> cx, (Indirect () <> df <> dt, TMatch v cases)) +anfBlock (And' l r) = do + (lctx, vl) <- anfArg l + (d, tmr) <- anfTerm r + let tree = + TMatch vl . MatchDataCover Ty.booleanRef $ + mapFromList + [ (0, ([], UFalse)), + (1, ([], tmr)) + ] + pure (lctx, (Indirect () <> d, tree)) +anfBlock (Or' l r) = do + (lctx, vl) <- anfArg l + (d, tmr) <- anfTerm r + let tree = + TMatch vl . MatchDataCover Ty.booleanRef $ + mapFromList + [ (1, ([], UTrue)), + (0, ([], tmr)) + ] + pure (lctx, (Indirect () <> d, tree)) +anfBlock (Handle' h body) = + anfArg h >>= \(hctx, vh) -> + anfHandled body >>= \case + (ctx, (_, TCom f as)) | floatableCtx ctx -> do + v <- fresh + pure + ( hctx <> ctx <> pure [LZ v (Left f) as], + (Indirect (), TApp (FVar vh) [v]) + ) + (ctx, (_, TApv f as)) | floatableCtx ctx -> do + v <- fresh + pure + ( hctx <> ctx <> pure [LZ v (Right f) as], + (Indirect (), TApp (FVar vh) [v]) + ) + (ctx, (_, TVar v)) | floatableCtx ctx -> do + pure (hctx <> ctx, (Indirect (), TApp (FVar vh) [v])) + p@(_, _) -> + internalBug $ "handle body should be a simple call: " ++ show p +anfBlock (Match' scrut cas) = do + (sctx, sc) <- anfBlock scrut + (cx, v) <- contextualize sc + (d, brn) <- anfCases v cas + fmap (first ((Indirect () <> d) <>)) <$> case brn of + AccumDefault (TBinds (directed -> dctx) df) -> do + pure (sctx <> cx <> dctx, pure df) + AccumRequest _ Nothing -> + internalBug "anfBlock: AccumRequest without default" + AccumPure (ABTN.TAbss us bd) + | [u] <- us, + TBinds (directed -> bx) bd <- bd -> + case cx of + (_, []) -> do + d0 <- Indirect <$> binder + pure (sctx <> pure [ST1 d0 u BX (TFrc v)] <> bx, pure bd) + (d0, [ST1 d1 _ BX tm]) -> + pure (sctx <> (d0, [ST1 d1 u BX tm]) <> bx, pure bd) + _ -> internalBug "anfBlock|AccumPure: impossible" + | otherwise -> internalBug "pure handler with too many variables" + AccumRequest abr (Just df) -> do + (r, vs) <- do + r <- fresh + v <- fresh + gvs <- groupVars + let hfb = ABTN.TAbs v . TMatch v $ MatchRequest abr df + hfvs = Set.toList $ ABTN.freeVars hfb `Set.difference` gvs + record (r, Lambda (BX <$ hfvs ++ [v]) . ABTN.TAbss hfvs $ hfb) + pure (r, hfvs) + hv <- fresh + let (d, msc) + | (d, [ST1 _ _ BX tm]) <- cx = (d, tm) + | (_, [ST _ _ _ _]) <- cx = + internalBug "anfBlock: impossible" + | otherwise = (Indirect (), TFrc v) + pure + ( sctx <> pure [LZ hv (Right r) vs], + (d, THnd (Map.keys abr) hv msc) + ) + AccumText df cs -> + pure (sctx <> cx, pure . TMatch v $ MatchText cs df) + AccumIntegral r df cs -> + pure (sctx <> cx, pure $ TMatch v $ MatchNumeric r cs df) + AccumData r df cs -> + pure (sctx <> cx, pure . TMatch v $ MatchData r cs df) + AccumSeqEmpty _ -> + internalBug "anfBlock: non-exhaustive AccumSeqEmpty" + AccumSeqView en (Just em) bd -> do + r <- fresh + let op + | SLeft <- en = Builtin "List.viewl" + | otherwise = Builtin "List.viewr" + b <- binder + pure + ( sctx + <> cx + <> (Indirect (), [ST1 (Indirect b) r BX (TCom op [v])]), + pure . TMatch r $ + MatchDataCover + Ty.seqViewRef + ( EC.mapFromList + [ (fromIntegral Ty.seqViewEmpty, ([], em)), + (fromIntegral Ty.seqViewElem, ([BX, BX], bd)) + ] + ) + ) + AccumSeqView {} -> + internalBug "anfBlock: non-exhaustive AccumSeqView" + AccumSeqSplit en n mdf bd -> do + i <- fresh + r <- fresh + s <- fresh + b <- binder + let split = ST1 (Indirect b) r BX (TCom op [i, v]) + pure + ( sctx <> cx <> directed [lit i, split], + pure . TMatch r . MatchDataCover Ty.seqViewRef $ + mapFromList + [ (fromIntegral Ty.seqViewEmpty, ([], df s)), + (fromIntegral Ty.seqViewElem, ([BX, BX], bd)) + ] + ) + where + op + | SLeft <- en = Builtin "List.splitLeft" + | otherwise = Builtin "List.splitRight" + lit i = ST1 Direct i BX (TBLit . N $ fromIntegral n) + df n = + fromMaybe + ( TLet Direct n BX (TLit (T "pattern match failure")) $ + TPrm EROR [n, v] + ) + mdf + AccumEmpty -> pure (sctx <> cx, pure $ TMatch v MatchEmpty) +anfBlock (Let1Named' v b e) = + anfBlock b >>= \case + (bctx, (Direct, TVar u)) -> do + (ectx, ce) <- anfBlock e + (brn, bctx) <- fixupBctx bctx ectx ce + u <- pure $ Map.findWithDefault u u brn + (ectx, shaded) <- pure $ renameCtx v u ectx + ce <- pure $ if shaded then ce else ABTN.rename v u <$> ce + pure (bctx <> ectx, ce) + (bctx, (d0, cb)) -> bindLocal [v] $ do + (ectx, ce) <- anfBlock e + d <- bindDirection d0 + (brn, bctx) <- fixupBctx bctx ectx ce + cb <- pure $ ABTN.renames brn cb + let octx = bctx <> directed [ST1 d v BX cb] <> ectx + pure (octx, ce) + where + fixupBctx bctx ectx (_, ce) = + pure $ freshenCtx (Set.union ecfvs efvs) bctx + where + ecfvs = freeVarsCtx ectx + efvs = ABTN.freeVars ce +anfBlock (Apps' (Blank' b) args) = do + nm <- fresh + (actx, cas) <- anfArgs args + pure + ( actx <> pure [ST1 Direct nm BX (TLit (T msg))], + pure $ TPrm EROR (nm : cas) + ) + where + msg = Util.Text.pack . fromMaybe "blank expression" $ nameb b +anfBlock (Apps' f args) = do + (fctx, (d, cf)) <- anfFunc f + (actx, cas) <- anfArgs args + pure (fctx <> actx, (d, TApp cf cas)) +anfBlock (Constructor' (ConstructorReference r t)) = + pure (mempty, pure $ TCon r (fromIntegral t) []) +anfBlock (Request' (ConstructorReference r t)) = + pure (mempty, (Indirect (), TReq r (fromIntegral t) [])) +anfBlock (Boolean' b) = + pure (mempty, pure $ TCon Ty.booleanRef (if b then 1 else 0) []) +anfBlock (Lit' l@(T _)) = + pure (mempty, pure $ TLit l) +anfBlock (Lit' l) = + pure (mempty, pure $ TBLit l) +anfBlock (Ref' r) = pure (mempty, (Indirect (), TCom r [])) +anfBlock (Blank' b) = do + nm <- fresh + ev <- fresh + pure + ( pure + [ ST1 Direct nm BX (TLit (T name)), + ST1 Direct ev BX (TLit (T $ Util.Text.pack msg)) + ], + pure $ TPrm EROR [nm, ev] + ) + where + name = "blank expression" + msg = fromMaybe "blank expression" $ nameb b +anfBlock (TermLink' r) = pure (mempty, pure . TLit $ LM r) +anfBlock (TypeLink' r) = pure (mempty, pure . TLit $ LY r) +anfBlock (List' as) = fmap (pure . TPrm BLDS) <$> anfArgs tms + where + tms = toList as +anfBlock t = internalBug $ "anf: unhandled term: " ++ show t + +-- Note: this assumes that patterns have already been translated +-- to a state in which every case matches a single layer of data, +-- with no guards, and no variables ignored. This is not checked +-- completely. +anfInitCase :: + (Var v) => + v -> + MatchCase p (Term v a) -> + ANFD v (BranchAccum v) +anfInitCase u (MatchCase p guard (ABT.AbsN' vs bd)) + | Just _ <- guard = internalBug "anfInitCase: unexpected guard" + | P.Unbound _ <- p, + [] <- vs = + AccumDefault <$> anfBody bd + | P.Var _ <- p, + [v] <- vs = + AccumDefault . ABTN.rename v u <$> anfBody bd + | P.Var _ <- p = + internalBug $ "vars: " ++ show (length vs) + | P.Int _ (fromIntegral -> i) <- p = + AccumIntegral Ty.intRef Nothing . EC.mapSingleton i <$> anfBody bd + | P.Nat _ i <- p = + AccumIntegral Ty.natRef Nothing . EC.mapSingleton i <$> anfBody bd + | P.Char _ c <- p, + w <- fromIntegral $ fromEnum c = + AccumIntegral Ty.charRef Nothing . EC.mapSingleton w <$> anfBody bd + | P.Boolean _ b <- p, + t <- if b then 1 else 0 = + AccumData Ty.booleanRef Nothing + . EC.mapSingleton t + . ([],) + <$> anfBody bd + | P.Text _ t <- p, + [] <- vs = + AccumText Nothing . Map.singleton (Util.Text.fromText t) <$> anfBody bd + | P.Constructor _ (ConstructorReference r t) ps <- p = do + (,) + <$> expandBindings ps vs + <*> anfBody bd + <&> \(us, bd) -> + AccumData r Nothing . EC.mapSingleton (fromIntegral t) . (BX <$ us,) $ ABTN.TAbss us bd + | P.EffectPure _ q <- p = + (,) + <$> expandBindings [q] vs + <*> anfBody bd + <&> \(us, bd) -> AccumPure $ ABTN.TAbss us bd + | P.EffectBind _ (ConstructorReference r t) ps pk <- p = do + (,,) + <$> expandBindings (snoc ps pk) vs + <*> Compose (pure <$> fresh) + <*> anfBody bd + <&> \(exp, kf, bd) -> + let (us, uk) = + maybe (internalBug "anfInitCase: unsnoc impossible") id $ + unsnoc exp + jn = Builtin "jumpCont" + in flip AccumRequest Nothing + . Map.singleton r + . EC.mapSingleton (fromIntegral t) + . (BX <$ us,) + . ABTN.TAbss us + . TShift r kf + $ TName uk (Left jn) [kf] bd + | P.SequenceLiteral _ [] <- p = + AccumSeqEmpty <$> anfBody bd + | P.SequenceOp _ l op r <- p, + Concat <- op, + P.SequenceLiteral p ll <- l = do + AccumSeqSplit SLeft (length ll) Nothing + <$> (ABTN.TAbss <$> expandBindings [P.Var p, r] vs <*> anfBody bd) + | P.SequenceOp _ l op r <- p, + Concat <- op, + P.SequenceLiteral p rl <- r = + AccumSeqSplit SLeft (length rl) Nothing + <$> (ABTN.TAbss <$> expandBindings [l, P.Var p] vs <*> anfBody bd) + | P.SequenceOp _ l op r <- p, + dir <- case op of Cons -> SLeft; _ -> SRight = + AccumSeqView dir Nothing + <$> (ABTN.TAbss <$> expandBindings [l, r] vs <*> anfBody bd) + where + anfBody tm = Compose . bindLocal vs $ anfTerm tm +anfInitCase _ (MatchCase p _ _) = + internalBug $ "anfInitCase: unexpected pattern: " ++ show p + +valueTermLinks :: Value -> [Reference] +valueTermLinks = Set.toList . valueLinks f + where + f False r = Set.singleton r + f _ _ = Set.empty + +valueLinks :: (Monoid a) => (Bool -> Reference -> a) -> Value -> a +valueLinks f (Partial (GR cr _) vs) = + f False cr <> foldMap (valueLinks f) vs +valueLinks f (Data dr _ vs) = + f True dr <> foldMap (valueLinks f) vs +valueLinks f (Cont vs k) = + foldMap (valueLinks f) vs <> contLinks f k +valueLinks f (BLit l) = blitLinks f l + +contLinks :: (Monoid a) => (Bool -> Reference -> a) -> Cont -> a +contLinks f (Push _ _ (GR cr _) k) = + f False cr <> contLinks f k +contLinks f (Mark _ ps de k) = + foldMap (f True) ps + <> Map.foldMapWithKey (\k c -> f True k <> valueLinks f c) de + <> contLinks f k +contLinks _ KE = mempty + +blitLinks :: (Monoid a) => (Bool -> Reference -> a) -> BLit -> a +blitLinks f (List s) = foldMap (valueLinks f) s +blitLinks _ _ = mempty + +groupTermLinks :: (Var v) => SuperGroup v -> [Reference] +groupTermLinks = Set.toList . foldGroupLinks f + where + f False r = Set.singleton r + f _ _ = Set.empty + +overGroupLinks :: + (Var v) => + (Bool -> Reference -> Reference) -> + SuperGroup v -> + SuperGroup v +overGroupLinks f = + runIdentity . traverseGroupLinks (\b -> Identity . f b) + +traverseGroupLinks :: + (Applicative f, Var v) => + (Bool -> Reference -> f Reference) -> + SuperGroup v -> + f (SuperGroup v) +traverseGroupLinks f (Rec bs e) = + Rec <$> (traverse . traverse) (normalLinks f) bs <*> normalLinks f e + +foldGroupLinks :: + (Monoid r, Var v) => + (Bool -> Reference -> r) -> + SuperGroup v -> + r +foldGroupLinks f = getConst . traverseGroupLinks (\b -> Const . f b) + +normalLinks :: + (Applicative f, Var v) => + (Bool -> Reference -> f Reference) -> + SuperNormal v -> + f (SuperNormal v) +normalLinks f (Lambda ccs e) = Lambda ccs <$> anfLinks f e + +anfLinks :: + (Applicative f, Var v) => + (Bool -> Reference -> f Reference) -> + ANormal v -> + f (ANormal v) +anfLinks f (ABTN.Term _ (ABTN.Abs v e)) = + ABTN.TAbs v <$> anfLinks f e +anfLinks f (ABTN.Term _ (ABTN.Tm e)) = + ABTN.TTm <$> anfFLinks f (anfLinks f) e + +anfFLinks :: + (Applicative f) => + (Bool -> Reference -> f Reference) -> + (e -> f e) -> + ANormalF v e -> + f (ANormalF v e) +anfFLinks _ g (ALet d ccs b e) = ALet d ccs <$> g b <*> g e +anfFLinks f g (AName er vs e) = + flip AName vs <$> bitraverse (f False) pure er <*> g e +anfFLinks f g (AMatch v bs) = + AMatch v <$> branchLinks (f True) g bs +anfFLinks f g (AShift r e) = + AShift <$> f True r <*> g e +anfFLinks f g (AHnd rs v e) = + flip AHnd v <$> traverse (f True) rs <*> g e +anfFLinks f _ (AApp fu vs) = flip AApp vs <$> funcLinks f fu +anfFLinks f _ (ALit l) = ALit <$> litLinks f l +anfFLinks _ _ v = pure v + +litLinks :: + (Applicative f) => + (Bool -> Reference -> f Reference) -> + Lit -> + f Lit +litLinks f (LY r) = LY <$> f True r +litLinks f (LM (Con (ConstructorReference r i) t)) = + LM . flip Con t . flip ConstructorReference i <$> f True r +litLinks f (LM (Ref r)) = LM . Ref <$> f False r +litLinks _ v = pure v + +branchLinks :: + (Applicative f) => + (Reference -> f Reference) -> + (e -> f e) -> + Branched e -> + f (Branched e) +branchLinks f g (MatchRequest m e) = + MatchRequest . Map.fromList + <$> traverse (bitraverse f $ (traverse . traverse) g) (Map.toList m) + <*> g e +branchLinks f g (MatchData r m e) = + MatchData <$> f r <*> (traverse . traverse) g m <*> traverse g e +branchLinks _ g (MatchText m e) = + MatchText <$> traverse g m <*> traverse g e +branchLinks _ g (MatchIntegral m e) = + MatchIntegral <$> traverse g m <*> traverse g e +branchLinks _ g (MatchNumeric r m e) = + MatchNumeric r <$> traverse g m <*> traverse g e +branchLinks _ g (MatchSum m) = + MatchSum <$> (traverse . traverse) g m +branchLinks _ _ MatchEmpty = pure MatchEmpty + +funcLinks :: + (Applicative f) => + (Bool -> Reference -> f Reference) -> + Func v -> + f (Func v) +funcLinks f (FComb r) = FComb <$> f False r +funcLinks f (FCon r t) = flip FCon t <$> f True r +funcLinks f (FReq r t) = flip FReq t <$> f True r +funcLinks _ ff = pure ff + +expandBindings' :: + (Var v) => + Word64 -> + [P.Pattern p] -> + [v] -> + Either String (Word64, [v]) +expandBindings' fr [] [] = Right (fr, []) +expandBindings' fr (P.Unbound _ : ps) vs = + fmap (u :) <$> expandBindings' (fr + 1) ps vs + where + u = freshANF fr +expandBindings' fr (P.Var _ : ps) (v : vs) = + fmap (v :) <$> expandBindings' fr ps vs +expandBindings' _ [] (_ : _) = + Left "expandBindings': more bindings than expected" +expandBindings' _ (_ : _) [] = + Left "expandBindings': more patterns than expected" +expandBindings' _ _ _ = + Left $ "expandBindings': unexpected pattern" + +expandBindings :: (Var v) => [P.Pattern p] -> [v] -> ANFD v [v] +expandBindings ps vs = + Compose . state $ \(fr, bnd, co) -> case expandBindings' fr ps vs of + Left err -> internalBug $ err ++ " " ++ show (ps, vs) + Right (fr, l) -> (pure l, (fr, bnd, co)) + +anfCases :: + (Var v) => + v -> + [MatchCase p (Term v a)] -> + ANFM v (Directed () (BranchAccum v)) +anfCases u = getCompose . fmap fold . traverse (anfInitCase u) + +anfFunc :: (Var v) => Term v a -> ANFM v (Ctx v, Directed () (Func v)) +anfFunc (Var' v) = pure (mempty, (Indirect (), FVar v)) +anfFunc (Ref' r) = pure (mempty, (Indirect (), FComb r)) +anfFunc (Constructor' (ConstructorReference r t)) = pure (mempty, (Direct, FCon r $ fromIntegral t)) +anfFunc (Request' (ConstructorReference r t)) = pure (mempty, (Indirect (), FReq r $ fromIntegral t)) +anfFunc tm = do + (fctx, ctm) <- anfBlock tm + (cx, v) <- contextualize ctm + pure (fctx <> cx, (Indirect (), FVar v)) + +anfArg :: (Var v) => Term v a -> ANFM v (Ctx v, v) +anfArg tm = do + (ctx, ctm) <- anfBlock tm + (cx, v) <- contextualize ctm + pure (ctx <> cx, v) + +anfArgs :: (Var v) => [Term v a] -> ANFM v (Ctx v, [v]) +anfArgs tms = first fold . unzip <$> traverse anfArg tms + +indent :: Int -> ShowS +indent ind = showString (replicate (ind * 2) ' ') + +prettyGroup :: (Var v) => String -> SuperGroup v -> ShowS +prettyGroup s (Rec grp ent) = + showString ("let rec[" ++ s ++ "]\n") + . foldr f id grp + . showString "entry" + . prettySuperNormal 1 ent + where + f (v, sn) r = + indent 1 + . pvar v + . prettySuperNormal 2 sn + . showString "\n" + . r + +pvar :: (Var v) => v -> ShowS +pvar v = showString . Data.Text.unpack $ Var.name v + +prettyVars :: (Var v) => [v] -> ShowS +prettyVars = + foldr (\v r -> showString " " . pvar v . r) id + +prettyLVars :: (Var v) => [Mem] -> [v] -> ShowS +prettyLVars [] [] = showString " " +prettyLVars (c : cs) (v : vs) = + showString " " + . showParen True (pvar v . showString ":" . shows c) + . prettyLVars cs vs +prettyLVars [] (_ : _) = internalBug "more variables than conventions" +prettyLVars (_ : _) [] = internalBug "more conventions than variables" + +prettyRBind :: (Var v) => [v] -> ShowS +prettyRBind [] = showString "()" +prettyRBind [v] = pvar v +prettyRBind (v : vs) = + showParen True $ + pvar v . foldr (\v r -> shows v . showString "," . r) id vs + +prettySuperNormal :: (Var v) => Int -> SuperNormal v -> ShowS +prettySuperNormal ind (Lambda ccs (ABTN.TAbss vs tm)) = + prettyLVars ccs vs + . showString "=" + . prettyANF False (ind + 1) tm + +reqSpace :: (Var v) => Bool -> ANormal v -> Bool +reqSpace _ TLets {} = True +reqSpace _ TName {} = True +reqSpace b _ = b + +prettyANF :: (Var v) => Bool -> Int -> ANormal v -> ShowS +prettyANF m ind tm = + prettySpace (reqSpace m tm) ind . case tm of + TLets _ vs _ bn bo -> + prettyRBind vs + . showString " =" + . prettyANF False (ind + 1) bn + . prettyANF True ind bo + TName v f vs bo -> + prettyRBind [v] + . showString " := " + . prettyLZF f + . prettyVars vs + . prettyANF True ind bo + TLit l -> shows l + TFrc v -> showString "!" . pvar v + TVar v -> pvar v + TApp f vs -> prettyFunc f . prettyVars vs + TMatch v bs -> + showString "match " + . pvar v + . showString " with" + . prettyBranches (ind + 1) bs + TShift r v bo -> + showString "shift[" + . shows r + . showString "]" + . prettyVars [v] + . showString "." + . prettyANF False (ind + 1) bo + THnd rs v bo -> + showString "handle" + . prettyRefs rs + . prettyANF False (ind + 1) bo + . showString " with " + . pvar v + _ -> shows tm + +prettySpace :: Bool -> Int -> ShowS +prettySpace False _ = showString " " +prettySpace True ind = showString "\n" . indent ind + +prettyLZF :: (Var v) => Either Reference v -> ShowS +prettyLZF (Left w) = showString "ENV(" . shows w . showString ") " +prettyLZF (Right v) = pvar v . showString " " + +prettyRefs :: [Reference] -> ShowS +prettyRefs [] = showString "{}" +prettyRefs (r : rs) = + showString "{" + . shows r + . foldr (\t r -> shows t . showString "," . r) id rs + . showString "}" + +prettyFunc :: (Var v) => Func v -> ShowS +prettyFunc (FVar v) = pvar v . showString " " +prettyFunc (FCont v) = pvar v . showString " " +prettyFunc (FComb w) = showString "ENV(" . shows w . showString ")" +prettyFunc (FCon r t) = + showString "CON(" + . shows r + . showString "," + . shows t + . showString ")" +prettyFunc (FReq r t) = + showString "REQ(" + . shows r + . showString "," + . shows t + . showString ")" +prettyFunc (FPrim op) = either shows shows op . showString " " + +prettyBranches :: (Var v) => Int -> Branched (ANormal v) -> ShowS +prettyBranches ind bs = case bs of + MatchEmpty -> showString "{}" + MatchIntegral bs df -> + maybe id (\e -> prettyCase ind (showString "_") e id) df + . foldr (uncurry $ prettyCase ind . shows) id (mapToList bs) + MatchText bs df -> + maybe id (\e -> prettyCase ind (showString "_") e id) df + . foldr (uncurry $ prettyCase ind . shows) id (Map.toList bs) + MatchData _ bs df -> + maybe id (\e -> prettyCase ind (showString "_") e id) df + . foldr + (uncurry $ prettyCase ind . shows) + id + (mapToList $ snd <$> bs) + MatchRequest bs df -> + foldr + ( \(r, m) s -> + foldr + (\(c, e) -> prettyCase ind (prettyReq r c) e) + s + (mapToList $ snd <$> m) + ) + (prettyCase ind (prettyReq (0 :: Int) (0 :: Int)) df id) + (Map.toList bs) + MatchSum bs -> + foldr + (uncurry $ prettyCase ind . shows) + id + (mapToList $ snd <$> bs) + MatchNumeric _ bs df -> + maybe id (\e -> prettyCase ind (showString "_") e id) df + . foldr (uncurry $ prettyCase ind . shows) id (mapToList bs) + -- _ -> error "prettyBranches: todo" + where + -- prettyReq :: Reference -> CTag -> ShowS + prettyReq r c = + showString "REQ(" + . shows r + . showString "," + . shows c + . showString ")" + +prettyCase :: (Var v) => Int -> ShowS -> ANormal v -> ShowS -> ShowS +prettyCase ind sc (ABTN.TAbss vs e) r = + showString "\n" + . indent ind + . sc + . prettyVars vs + . showString " ->" + . prettyANF False (ind + 1) e + . r diff --git a/parser-typechecker/src/Unison/Runtime/ANF/Rehash.hs b/unison-runtime/src/Unison/Runtime/ANF/Rehash.hs similarity index 84% rename from parser-typechecker/src/Unison/Runtime/ANF/Rehash.hs rename to unison-runtime/src/Unison/Runtime/ANF/Rehash.hs index 3a501744ff..a6a50722d8 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF/Rehash.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Rehash.hs @@ -1,7 +1,7 @@ module Unison.Runtime.ANF.Rehash where import Crypto.Hash -import Data.Bifunctor (bimap, first, second) +import Data.Bifunctor (bimap, second) import Data.ByteArray (convert) import Data.ByteString (cons) import Data.ByteString.Lazy (toChunks) @@ -16,25 +16,23 @@ import Unison.Reference as Reference import Unison.Referent as Referent import Unison.Runtime.ANF as ANF import Unison.Runtime.ANF.Serialize as ANF -import Unison.Var (Var) +import Unison.Symbol (Symbol) checkGroupHashes :: - Var v => - [(Referent, SuperGroup v)] -> + [(Referent, Code)] -> Either (Text, [Referent]) (Either [Referent] [Referent]) checkGroupHashes rgs = case checkMissing rgs of Left err -> Left err Right [] -> - case rehashGroups . Map.fromList $ first toReference <$> rgs of + case rehashGroups . Map.fromList $ bimap toReference codeGroup <$> rgs of Left err -> Left err Right (rrs, _) -> Right . Right . fmap (Ref . fst) . filter (uncurry (/=)) $ Map.toList rrs Right ms -> Right (Left $ Ref <$> ms) rehashGroups :: - Var v => - Map.Map Reference (SuperGroup v) -> - Either (Text, [Referent]) (Map.Map Reference Reference, Map.Map Reference (SuperGroup v)) + Map.Map Reference (SuperGroup Symbol) -> + Either (Text, [Referent]) (Map.Map Reference Reference, Map.Map Reference (SuperGroup Symbol)) rehashGroups m | badsccs <- filter (not . checkSCC) sccs, not $ null badsccs = @@ -56,12 +54,11 @@ rehashGroups m (rm, sgs) = rehashSCC scc checkMissing :: - Var v => - [(Referent, SuperGroup v)] -> + [(Referent, Code)] -> Either (Text, [Referent]) [Reference] -checkMissing (unzip -> (rs, gs)) = do +checkMissing (unzip -> (rs, cs)) = do is <- fmap Set.fromList . traverse f $ rs - pure . nub . foldMap (filter (p is) . groupTermLinks) $ gs + pure . nub . foldMap (filter (p is) . groupTermLinks . codeGroup) $ cs where f (Ref (DerivedId i)) = pure i f r@Ref {} = @@ -74,9 +71,8 @@ checkMissing (unzip -> (rs, gs)) = do p _ _ = False rehashSCC :: - Var v => - SCC (Reference, SuperGroup v) -> - (Map.Map Reference Reference, Map.Map Reference (SuperGroup v)) + SCC (Reference, SuperGroup Symbol) -> + (Map.Map Reference Reference, Map.Map Reference (SuperGroup Symbol)) rehashSCC scc | checkSCC scc = (refreps, newSGs) where @@ -103,7 +99,7 @@ rehashSCC scc refreps = Map.fromList $ fmap (\(r, _) -> (r, replace r)) ps rehashSCC scc = error $ "unexpected SCC:\n" ++ show scc -checkSCC :: SCC (Reference, SuperGroup v) -> Bool +checkSCC :: SCC (Reference, a) -> Bool checkSCC AcyclicSCC {} = True checkSCC (CyclicSCC []) = True checkSCC (CyclicSCC (p : ps)) = all (same p) ps diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs new file mode 100644 index 0000000000..4b0759ad0f --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs @@ -0,0 +1,1081 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Runtime.ANF.Serialize where + +import Control.Monad +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as L +import Data.Bytes.Get hiding (getBytes) +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Bytes.VarInt +import Data.Foldable (traverse_) +import Data.Functor ((<&>)) +import Data.Map as Map (Map, fromList, lookup) +import Data.Maybe (mapMaybe) +import Data.Sequence qualified as Seq +import Data.Serialize.Put (runPutLazy) +import Data.Text (Text) +import Data.Word (Word16, Word32, Word64) +import GHC.IsList qualified (fromList) +import GHC.Stack +import Unison.ABT.Normalized (Term (..)) +import Unison.Reference (Reference, Reference' (Builtin), pattern Derived) +import Unison.Runtime.ANF as ANF hiding (Tag) +import Unison.Runtime.Exception +import Unison.Runtime.Foreign.Function.Type (ForeignFunc) +import Unison.Runtime.Serialize +import Unison.Util.Text qualified as Util.Text +import Unison.Var (Type (ANFBlank), Var (..)) +import Prelude hiding (getChar, putChar) + +-- Version information is threaded through to allow handling +-- different formats. Transfer means that it is for saving +-- code/values to be restored later. Hash means we're just getting +-- bytes for hashing, so we don't need perfect information. +data Version = Transfer Word32 | Hash Word32 + deriving (Show) + +data TmTag + = VarT + | ForceT + | AppT + | HandleT + | ShiftT + | MatchT + | LitT + | NameRefT + | NameVarT + | LetDirT + | LetIndT + | BxLitT + +data FnTag + = FVarT + | FCombT + | FContT + | FConT + | FReqT + | FPrimT + | FForeignT + +data MtTag + = MIntT + | MTextT + | MReqT + | MEmptyT + | MDataT + | MSumT + | MNumT + +data LtTag + = IT + | NT + | FT + | TT + | CT + | LMT + | LYT + +data BLTag + = TextT + | ListT + | TmLinkT + | TyLinkT + | BytesT + | QuoteT + | CodeT + | BArrT + | PosT + | NegT + | CharT + | FloatT + | ArrT + | CachedCodeT + +data VaTag = PartialT | DataT | ContT | BLitT + +data CoTag = KET | MarkT | PushT + +instance Tag TmTag where + tag2word = \case + VarT -> 1 + ForceT -> 2 + AppT -> 3 + HandleT -> 4 + ShiftT -> 5 + MatchT -> 6 + LitT -> 7 + NameRefT -> 8 + NameVarT -> 9 + LetDirT -> 10 + LetIndT -> 11 + BxLitT -> 12 + word2tag = \case + 1 -> pure VarT + 2 -> pure ForceT + 3 -> pure AppT + 4 -> pure HandleT + 5 -> pure ShiftT + 6 -> pure MatchT + 7 -> pure LitT + 8 -> pure NameRefT + 9 -> pure NameVarT + 10 -> pure LetDirT + 11 -> pure LetIndT + 12 -> pure BxLitT + n -> unknownTag "TmTag" n + +instance Tag FnTag where + tag2word = \case + FVarT -> 0 + FCombT -> 1 + FContT -> 2 + FConT -> 3 + FReqT -> 4 + FPrimT -> 5 + FForeignT -> 6 + + word2tag = \case + 0 -> pure FVarT + 1 -> pure FCombT + 2 -> pure FContT + 3 -> pure FConT + 4 -> pure FReqT + 5 -> pure FPrimT + 6 -> pure FForeignT + n -> unknownTag "FnTag" n + +instance Tag MtTag where + tag2word = \case + MIntT -> 0 + MTextT -> 1 + MReqT -> 2 + MEmptyT -> 3 + MDataT -> 4 + MSumT -> 5 + MNumT -> 6 + + word2tag = \case + 0 -> pure MIntT + 1 -> pure MTextT + 2 -> pure MReqT + 3 -> pure MEmptyT + 4 -> pure MDataT + 5 -> pure MSumT + 6 -> pure MNumT + n -> unknownTag "MtTag" n + +instance Tag LtTag where + tag2word = \case + IT -> 0 + NT -> 1 + FT -> 2 + TT -> 3 + CT -> 4 + LMT -> 5 + LYT -> 6 + + word2tag = \case + 0 -> pure IT + 1 -> pure NT + 2 -> pure FT + 3 -> pure TT + 4 -> pure CT + 5 -> pure LMT + 6 -> pure LYT + n -> unknownTag "LtTag" n + +instance Tag BLTag where + tag2word = \case + TextT -> 0 + ListT -> 1 + TmLinkT -> 2 + TyLinkT -> 3 + BytesT -> 4 + QuoteT -> 5 + CodeT -> 6 + BArrT -> 7 + PosT -> 8 + NegT -> 9 + CharT -> 10 + FloatT -> 11 + ArrT -> 12 + CachedCodeT -> 13 + + word2tag = \case + 0 -> pure TextT + 1 -> pure ListT + 2 -> pure TmLinkT + 3 -> pure TyLinkT + 4 -> pure BytesT + 5 -> pure QuoteT + 6 -> pure CodeT + 7 -> pure BArrT + 8 -> pure PosT + 9 -> pure NegT + 10 -> pure CharT + 11 -> pure FloatT + 12 -> pure ArrT + 13 -> pure CachedCodeT + t -> unknownTag "BLTag" t + +instance Tag VaTag where + tag2word = \case + PartialT -> 0 + DataT -> 1 + ContT -> 2 + BLitT -> 3 + + word2tag = \case + 0 -> pure PartialT + 1 -> pure DataT + 2 -> pure ContT + 3 -> pure BLitT + t -> unknownTag "VaTag" t + +instance Tag CoTag where + tag2word = \case + KET -> 0 + MarkT -> 1 + PushT -> 2 + word2tag = \case + 0 -> pure KET + 1 -> pure MarkT + 2 -> pure PushT + t -> unknownTag "CoTag" t + +index :: (Eq v) => [v] -> v -> Maybe Word64 +index ctx u = go 0 ctx + where + go !_ [] = Nothing + go n (v : vs) + | v == u = Just n + | otherwise = go (n + 1) vs + +deindex :: (HasCallStack) => [v] -> Word64 -> v +deindex [] _ = exn "deindex: bad index" +deindex (v : vs) n + | n == 0 = v + | otherwise = deindex vs (n - 1) + +pushCtx :: [v] -> [v] -> [v] +pushCtx us vs = reverse us ++ vs + +putIndex :: (MonadPut m) => Word64 -> m () +putIndex = serialize . VarInt + +getIndex :: (MonadGet m) => m Word64 +getIndex = unVarInt <$> deserialize + +putVar :: (MonadPut m) => (Eq v) => [v] -> v -> m () +putVar ctx v + | Just i <- index ctx v = putIndex i + | otherwise = exn "putVar: variable not in context" + +getVar :: (MonadGet m) => [v] -> m v +getVar ctx = deindex ctx <$> getIndex + +putArgs :: (MonadPut m) => (Eq v) => [v] -> [v] -> m () +putArgs ctx is = putFoldable (putVar ctx) is + +getArgs :: (MonadGet m) => [v] -> m [v] +getArgs ctx = getList (getVar ctx) + +putCCs :: (MonadPut m) => [Mem] -> m () +putCCs ccs = putLength n *> traverse_ putCC ccs + where + n = length ccs + putCC UN = putWord8 0 + putCC BX = putWord8 1 + +getCCs :: (MonadGet m) => m [Mem] +getCCs = + getList $ + getWord8 <&> \case + 0 -> UN + 1 -> BX + _ -> exn "getCCs: bad calling convention" + +-- Serializes a `SuperGroup`. +-- +-- The Reference map allows certain term references to be switched out +-- for a given 64 bit word. This is used when re-hashing intermediate +-- code. For actual serialization, the empty map should be used, so +-- that the process is reversible. The purpose of this is merely to +-- strip out (mutual/)self-references when producing a byte sequence +-- to recompute a hash of a connected component of intermediate +-- definitons, since it is infeasible to +-- +-- The EnumMap associates 'foreign' operations with a textual name +-- that is used as the serialized representation. Since they are +-- generated somewhat dynamically, it is not easy to associate them +-- with a fixed numbering like we can with POps. +putGroup :: + (MonadPut m) => + (Var v) => + Map Reference Word64 -> + Map ForeignFunc Text -> + SuperGroup v -> + m () +putGroup refrep fops (Rec bs e) = + putLength n + *> traverse_ (putComb refrep fops ctx) cs + *> putComb refrep fops ctx e + where + n = length us + (us, cs) = unzip bs + ctx = pushCtx us [] + +getGroup :: (MonadGet m) => (Var v) => m (SuperGroup v) +getGroup = do + l <- getLength + let n = fromIntegral l + vs = getFresh <$> take l [0 ..] + ctx = pushCtx vs [] + cs <- replicateM l (getComb ctx n) + Rec (zip vs cs) <$> getComb ctx n + +putCode :: (MonadPut m) => Map ForeignFunc Text -> Code -> m () +putCode fops (CodeRep g c) = putGroup mempty fops g *> putCacheability c + +getCode :: (MonadGet m) => Word32 -> m Code +getCode v = CodeRep <$> getGroup <*> getCache + where + getCache + | v == 3 = getCacheability + | otherwise = pure Uncacheable + +putCacheability :: (MonadPut m) => Cacheability -> m () +putCacheability Uncacheable = putWord8 0 +putCacheability Cacheable = putWord8 1 + +getCacheability :: (MonadGet m) => m Cacheability +getCacheability = + getWord8 >>= \case + 0 -> pure Uncacheable + 1 -> pure Cacheable + n -> exn $ "getBLit: unrecognized cacheability byte: " ++ show n + +putComb :: + (MonadPut m) => + (Var v) => + Map Reference Word64 -> + Map ForeignFunc Text -> + [v] -> + SuperNormal v -> + m () +putComb refrep fops ctx (Lambda ccs (TAbss us e)) = + putCCs ccs *> putNormal refrep fops (pushCtx us ctx) e + +getFresh :: (Var v) => Word64 -> v +getFresh n = freshenId n $ typed ANFBlank + +getComb :: (MonadGet m) => (Var v) => [v] -> Word64 -> m (SuperNormal v) +getComb ctx frsh0 = do + ccs <- getCCs + let us = zipWith (\_ -> getFresh) ccs [frsh0 ..] + frsh = frsh0 + fromIntegral (length ccs) + Lambda ccs . TAbss us <$> getNormal (pushCtx us ctx) frsh + +putNormal :: + (MonadPut m) => + (Var v) => + Map Reference Word64 -> + Map ForeignFunc Text -> + [v] -> + ANormal v -> + m () +putNormal refrep fops ctx tm = case tm of + TVar v -> putTag VarT *> putVar ctx v + TFrc v -> putTag ForceT *> putVar ctx v + TApp f as -> putTag AppT *> putFunc refrep fops ctx f *> putArgs ctx as + THnd rs h e -> + putTag HandleT + *> putRefs rs + *> putVar ctx h + *> putNormal refrep fops ctx e + TShift r v e -> + putTag ShiftT *> putReference r *> putNormal refrep fops (v : ctx) e + TMatch v bs -> + putTag MatchT + *> putVar ctx v + *> putBranches refrep fops ctx bs + TLit l -> putTag LitT *> putLit l + TBLit l -> putTag BxLitT *> putLit l + TName v (Left r) as e -> + putTag NameRefT + *> pr + *> putArgs ctx as + *> putNormal refrep fops (v : ctx) e + where + pr + | Just w <- Map.lookup r refrep = putWord64be w + | otherwise = putReference r + TName v (Right u) as e -> + putTag NameVarT + *> putVar ctx u + *> putArgs ctx as + *> putNormal refrep fops (v : ctx) e + TLets Direct us ccs l e -> + putTag LetDirT + *> putCCs ccs + *> putNormal refrep fops ctx l + *> putNormal refrep fops (pushCtx us ctx) e + TLets (Indirect w) us ccs l e -> + putTag LetIndT + *> putWord16be w + *> putCCs ccs + *> putNormal refrep fops ctx l + *> putNormal refrep fops (pushCtx us ctx) e + _ -> exn "putNormal: malformed term" + +getNormal :: (MonadGet m) => (Var v) => [v] -> Word64 -> m (ANormal v) +getNormal ctx frsh0 = + getTag >>= \case + VarT -> TVar <$> getVar ctx + ForceT -> TFrc <$> getVar ctx + AppT -> TApp <$> getFunc ctx <*> getArgs ctx + HandleT -> THnd <$> getRefs <*> getVar ctx <*> getNormal ctx frsh0 + ShiftT -> + flip TShift v <$> getReference <*> getNormal (v : ctx) (frsh0 + 1) + where + v = getFresh frsh0 + MatchT -> TMatch <$> getVar ctx <*> getBranches ctx frsh0 + LitT -> TLit <$> getLit + BxLitT -> TBLit <$> getLit + NameRefT -> + TName v . Left + <$> getReference + <*> getArgs ctx + <*> getNormal (v : ctx) (frsh0 + 1) + where + v = getFresh frsh0 + NameVarT -> + TName v . Right + <$> getVar ctx + <*> getArgs ctx + <*> getNormal (v : ctx) (frsh0 + 1) + where + v = getFresh frsh0 + LetDirT -> do + ccs <- getCCs + let l = length ccs + frsh = frsh0 + fromIntegral l + us = getFresh <$> take l [frsh0 ..] + TLets Direct us ccs + <$> getNormal ctx frsh0 + <*> getNormal (pushCtx us ctx) frsh + LetIndT -> do + w <- getWord16be + ccs <- getCCs + let l = length ccs + frsh = frsh0 + fromIntegral l + us = getFresh <$> take l [frsh0 ..] + TLets (Indirect w) us ccs + <$> getNormal ctx frsh0 + <*> getNormal (pushCtx us ctx) frsh + +putFunc :: + (MonadPut m) => + (Var v) => + Map Reference Word64 -> + Map ForeignFunc Text -> + [v] -> + Func v -> + m () +putFunc refrep fops ctx f = case f of + FVar v -> putTag FVarT *> putVar ctx v + FComb r + | Just w <- Map.lookup r refrep -> putTag FCombT *> putWord64be w + | otherwise -> putTag FCombT *> putReference r + FCont v -> putTag FContT *> putVar ctx v + FCon r c -> putTag FConT *> putReference r *> putCTag c + FReq r c -> putTag FReqT *> putReference r *> putCTag c + FPrim (Left p) -> putTag FPrimT *> putPOp p + FPrim (Right f) + | Just nm <- Map.lookup f fops -> + putTag FForeignT *> putText nm + | otherwise -> + exn $ "putFunc: could not serialize foreign operation: " ++ show f + +getFunc :: (MonadGet m) => (Var v) => [v] -> m (Func v) +getFunc ctx = + getTag >>= \case + FVarT -> FVar <$> getVar ctx + FCombT -> FComb <$> getReference + FContT -> FCont <$> getVar ctx + FConT -> FCon <$> getReference <*> getCTag + FReqT -> FReq <$> getReference <*> getCTag + FPrimT -> FPrim . Left <$> getPOp + FForeignT -> exn "getFunc: can't deserialize a foreign func" + +putPOp :: (MonadPut m) => POp -> m () +putPOp op + | Just w <- Map.lookup op pop2word = putWord16be w + | otherwise = exn $ "putPOp: unknown POp: " ++ show op + +getPOp :: (MonadGet m) => m POp +getPOp = + getWord16be >>= \w -> case Map.lookup w word2pop of + Just op -> pure op + Nothing -> exn "getPOp: unknown enum code" + +pOpCode :: POp -> Word16 +pOpCode op = case op of + ADDI -> 0 + SUBI -> 1 + MULI -> 2 + DIVI -> 3 + SGNI -> 4 + NEGI -> 5 + MODI -> 6 + POWI -> 7 + SHLI -> 8 + SHRI -> 9 + INCI -> 10 + DECI -> 11 + LEQI -> 12 + EQLI -> 13 + ADDN -> 14 + SUBN -> 15 + MULN -> 16 + DIVN -> 17 + MODN -> 18 + TZRO -> 19 + LZRO -> 20 + POWN -> 21 + SHLN -> 22 + SHRN -> 23 + ANDN -> 24 + IORN -> 25 + XORN -> 26 + COMN -> 27 + INCN -> 28 + DECN -> 29 + LEQN -> 30 + EQLN -> 31 + ADDF -> 32 + SUBF -> 33 + MULF -> 34 + DIVF -> 35 + MINF -> 36 + MAXF -> 37 + LEQF -> 38 + EQLF -> 39 + POWF -> 40 + EXPF -> 41 + SQRT -> 42 + LOGF -> 43 + LOGB -> 44 + ABSF -> 45 + CEIL -> 46 + FLOR -> 47 + TRNF -> 48 + RNDF -> 49 + COSF -> 50 + ACOS -> 51 + COSH -> 52 + ACSH -> 53 + SINF -> 54 + ASIN -> 55 + SINH -> 56 + ASNH -> 57 + TANF -> 58 + ATAN -> 59 + TANH -> 60 + ATNH -> 61 + ATN2 -> 62 + CATT -> 63 + TAKT -> 64 + DRPT -> 65 + SIZT -> 66 + UCNS -> 67 + USNC -> 68 + EQLT -> 69 + LEQT -> 70 + PAKT -> 71 + UPKT -> 72 + CATS -> 73 + TAKS -> 74 + DRPS -> 75 + SIZS -> 76 + CONS -> 77 + SNOC -> 78 + IDXS -> 79 + BLDS -> 80 + VWLS -> 81 + VWRS -> 82 + SPLL -> 83 + SPLR -> 84 + PAKB -> 85 + UPKB -> 86 + TAKB -> 87 + DRPB -> 88 + IDXB -> 89 + SIZB -> 90 + FLTB -> 91 + CATB -> 92 + ITOF -> 93 + NTOF -> 94 + ITOT -> 95 + NTOT -> 96 + TTOI -> 97 + TTON -> 98 + TTOF -> 99 + FTOT -> 100 + FORK -> 101 + EQLU -> 102 + CMPU -> 103 + EROR -> 104 + PRNT -> 105 + INFO -> 106 + POPC -> 107 + MISS -> 108 + CACH -> 109 + LKUP -> 110 + LOAD -> 111 + CVLD -> 112 + SDBX -> 113 + VALU -> 114 + TLTT -> 115 + TRCE -> 116 + ATOM -> 117 + TFRC -> 118 + DBTX -> 119 + IXOT -> 120 + IXOB -> 121 + SDBL -> 122 + SDBV -> 123 + CAST -> 124 + ANDI -> 125 + IORI -> 126 + XORI -> 127 + COMI -> 128 + DRPN -> 129 + TRNC -> 130 + REFN -> 131 + REFR -> 132 + REFW -> 133 + RCAS -> 134 + RRFC -> 135 + TIKR -> 136 + LESI -> 137 + NEQI -> 138 + LESN -> 139 + NEQN -> 140 + LESF -> 141 + NEQF -> 142 + LEQU -> 143 + LESU -> 144 + NOTB -> 145 + ANDB -> 146 + IORB -> 147 + +pOpAssoc :: [(POp, Word16)] +pOpAssoc = map (\op -> (op, pOpCode op)) [minBound .. maxBound] + +pop2word :: Map POp Word16 +pop2word = fromList pOpAssoc + +word2pop :: Map Word16 POp +word2pop = fromList $ swap <$> pOpAssoc + where + swap (x, y) = (y, x) + +putLit :: (MonadPut m) => Lit -> m () +putLit (I i) = putTag IT *> putInt i +putLit (N n) = putTag NT *> putNat n +putLit (F f) = putTag FT *> putFloat f +putLit (T t) = putTag TT *> putText (Util.Text.toText t) +putLit (C c) = putTag CT *> putChar c +putLit (LM r) = putTag LMT *> putReferent r +putLit (LY r) = putTag LYT *> putReference r + +getLit :: (MonadGet m) => m Lit +getLit = + getTag >>= \case + IT -> I <$> getInt + NT -> N <$> getNat + FT -> F <$> getFloat + TT -> T . Util.Text.fromText <$> getText + CT -> C <$> getChar + LMT -> LM <$> getReferent + LYT -> LY <$> getReference + +putBLit :: (MonadPut m) => Version -> BLit -> m () +putBLit _ (Text t) = putTag TextT *> putText (Util.Text.toText t) +putBLit v (List s) = putTag ListT *> putFoldable (putValue v) s +putBLit _ (TmLink r) = putTag TmLinkT *> putReferent r +putBLit _ (TyLink r) = putTag TyLinkT *> putReference r +putBLit _ (Bytes b) = putTag BytesT *> putBytes b +putBLit v (Quote vl) = putTag QuoteT *> putValue v vl +putBLit v (Code (CodeRep sg ch)) = + putTag tag *> putGroup mempty mempty sg + where + -- Hashing treats everything as uncacheable for consistent + -- results. + tag + | Cacheable <- ch, + Transfer _ <- v = + CachedCodeT + | otherwise = CodeT +putBLit _ (BArr a) = putTag BArrT *> putByteArray a +putBLit _ (Pos n) = putTag PosT *> putPositive n +putBLit _ (Neg n) = putTag NegT *> putPositive n +putBLit _ (Char c) = putTag CharT *> putChar c +putBLit _ (Float d) = putTag FloatT *> putFloat d +putBLit v (Arr a) = putTag ArrT *> putFoldable (putValue v) a + +getBLit :: (MonadGet m) => Version -> m BLit +getBLit v = + getTag >>= \case + TextT -> Text . Util.Text.fromText <$> getText + ListT -> List . Seq.fromList <$> getList (getValue v) + TmLinkT -> TmLink <$> getReferent + TyLinkT -> TyLink <$> getReference + BytesT -> Bytes <$> getBytes + QuoteT -> Quote <$> getValue v + CodeT -> Code . flip CodeRep Uncacheable <$> getGroup + BArrT -> BArr <$> getByteArray + PosT -> Pos <$> getPositive + NegT -> Neg <$> getPositive + CharT -> Char <$> getChar + FloatT -> Float <$> getFloat + ArrT -> Arr . GHC.IsList.fromList <$> getList (getValue v) + CachedCodeT -> Code . flip CodeRep Cacheable <$> getGroup + +putRefs :: (MonadPut m) => [Reference] -> m () +putRefs rs = putFoldable putReference rs + +getRefs :: (MonadGet m) => m [Reference] +getRefs = getList getReference + +putBranches :: + (MonadPut m) => + (Var v) => + Map Reference Word64 -> + Map ForeignFunc Text -> + [v] -> + Branched (ANormal v) -> + m () +putBranches refrep fops ctx bs = case bs of + MatchEmpty -> putTag MEmptyT + MatchIntegral m df -> do + putTag MIntT + putEnumMap putWord64be (putNormal refrep fops ctx) m + putMaybe df $ putNormal refrep fops ctx + MatchText m df -> do + putTag MTextT + putMap (putText . Util.Text.toText) (putNormal refrep fops ctx) m + putMaybe df $ putNormal refrep fops ctx + MatchRequest m (TAbs v df) -> do + putTag MReqT + putMap putReference (putEnumMap putCTag (putCase refrep fops ctx)) m + putNormal refrep fops (v : ctx) df + MatchData r m df -> do + putTag MDataT + putReference r + putEnumMap putCTag (putCase refrep fops ctx) m + putMaybe df $ putNormal refrep fops ctx + MatchSum m -> do + putTag MSumT + putEnumMap putWord64be (putCase refrep fops ctx) m + MatchNumeric r m df -> do + putTag MNumT + putReference r + putEnumMap putWord64be (putNormal refrep fops ctx) m + putMaybe df $ putNormal refrep fops ctx + _ -> exn "putBranches: malformed intermediate term" + +getBranches :: + (MonadGet m) => (Var v) => [v] -> Word64 -> m (Branched (ANormal v)) +getBranches ctx frsh0 = + getTag >>= \case + MEmptyT -> pure MatchEmpty + MIntT -> + MatchIntegral + <$> getEnumMap getWord64be (getNormal ctx frsh0) + <*> getMaybe (getNormal ctx frsh0) + MTextT -> + MatchText + <$> getMap (Util.Text.fromText <$> getText) (getNormal ctx frsh0) + <*> getMaybe (getNormal ctx frsh0) + MReqT -> + MatchRequest + <$> getMap getReference (getEnumMap getCTag (getCase ctx frsh0)) + <*> (TAbs v <$> getNormal (v : ctx) (frsh0 + 1)) + where + v = getFresh frsh0 + MDataT -> + MatchData + <$> getReference + <*> getEnumMap getCTag (getCase ctx frsh0) + <*> getMaybe (getNormal ctx frsh0) + MSumT -> MatchSum <$> getEnumMap getWord64be (getCase ctx frsh0) + MNumT -> + MatchNumeric + <$> getReference + <*> getEnumMap getWord64be (getNormal ctx frsh0) + <*> getMaybe (getNormal ctx frsh0) + +putCase :: + (MonadPut m) => + (Var v) => + Map Reference Word64 -> + Map ForeignFunc Text -> + [v] -> + ([Mem], ANormal v) -> + m () +putCase refrep fops ctx (ccs, (TAbss us e)) = + putCCs ccs *> putNormal refrep fops (pushCtx us ctx) e + +getCase :: (MonadGet m) => (Var v) => [v] -> Word64 -> m ([Mem], ANormal v) +getCase ctx frsh0 = do + ccs <- getCCs + let l = length ccs + frsh = frsh0 + fromIntegral l + us = getFresh <$> take l [frsh0 ..] + (,) ccs . TAbss us <$> getNormal (pushCtx us ctx) frsh + +putCTag :: (MonadPut m) => CTag -> m () +putCTag c = serialize (VarInt $ fromEnum c) + +getCTag :: (MonadGet m) => m CTag +getCTag = toEnum . unVarInt <$> deserialize + +putGroupRef :: (MonadPut m) => GroupRef -> m () +putGroupRef (GR r i) = + putReference r *> putWord64be i + +getGroupRef :: (MonadGet m) => m GroupRef +getGroupRef = GR <$> getReference <*> getWord64be + +-- Notes +-- +-- Starting with version 4 of the value format, it is expected that +-- unboxed data does not actually occur in the values being sent. For +-- most values this was not a problem: +-- +-- - Partial applications had no way of directly including unboxed +-- values, because they all result from surface level unison +-- applications +-- - Unboxed values in Data only occurred to represent certain +-- builtin types. Those have been replaced by BLits. +-- +-- However, some work was required to make sure no unboxed data ended +-- up in Cont. The runtime has been modified to avoid using the +-- unboxed stack in generated code, so now only builtins use it, +-- effectively. Since continuations are never captured inside builtins +-- (and even if we wanted to do that, we could arrange for a clean +-- unboxed stack), this is no longer a problem, either. +-- +-- So, unboxed data is completely absent from the format. We are now +-- exchanging unison surface values, effectively. +putValue :: (MonadPut m) => Version -> Value -> m () +putValue v (Partial gr vs) = + putTag PartialT + *> putGroupRef gr + *> putFoldable (putValue v) vs +putValue v (Data r t vs) = + putTag DataT + *> putReference r + *> putWord64be t + *> putFoldable (putValue v) vs +putValue v (Cont bs k) = + putTag ContT + *> putFoldable (putValue v) bs + *> putCont v k +putValue v (BLit l) = + putTag BLitT *> putBLit v l + +getValue :: (MonadGet m) => Version -> m Value +getValue v = + getTag >>= \case + PartialT + | Transfer vn <- v, + vn < 4 -> do + gr <- getGroupRef + getList getWord64be >>= assertEmptyUnboxed + bs <- getList (getValue v) + pure $ Partial gr bs + | otherwise -> do + gr <- getGroupRef + vs <- getList (getValue v) + pure $ Partial gr vs + DataT + | Transfer vn <- v, + vn < 4 -> do + r <- getReference + w <- getWord64be + getList getWord64be >>= assertEmptyUnboxed + vs <- getList (getValue v) + pure $ Data r w vs + | otherwise -> do + r <- getReference + w <- getWord64be + vs <- getList (getValue v) + pure $ Data r w vs + ContT + | Transfer vn <- v, + vn < 4 -> do + getList getWord64be >>= assertEmptyUnboxed + bs <- getList (getValue v) + k <- getCont v + pure $ Cont bs k + | otherwise -> do + bs <- getList (getValue v) + k <- getCont v + pure $ Cont bs k + BLitT -> BLit <$> getBLit v + where + assertEmptyUnboxed :: (MonadGet m) => [a] -> m () + assertEmptyUnboxed [] = pure () + assertEmptyUnboxed _ = exn "getValue: unboxed values no longer supported" + +putCont :: (MonadPut m) => Version -> Cont -> m () +putCont _ KE = putTag KET +putCont v (Mark a rs ds k) = + putTag MarkT + *> putWord64be a + *> putFoldable putReference rs + *> putMap putReference (putValue v) ds + *> putCont v k +putCont v (Push f n gr k) = + putTag PushT + *> putWord64be f + *> putWord64be n + *> putGroupRef gr + *> putCont v k + +getCont :: (MonadGet m) => Version -> m Cont +getCont v = + getTag >>= \case + KET -> pure KE + MarkT + | Transfer vn <- v, + vn < 4 -> do + getWord64be >>= assert0 "unboxed arg size" + ba <- getWord64be + refs <- getList getReference + vals <- getMap getReference (getValue v) + cont <- getCont v + pure $ Mark ba refs vals cont + | otherwise -> + Mark + <$> getWord64be + <*> getList getReference + <*> getMap getReference (getValue v) + <*> getCont v + PushT + | Transfer vn <- v, + vn < 4 -> do + getWord64be >>= assert0 "unboxed frame size" + bf <- getWord64be + getWord64be >>= assert0 "unboxed arg size" + ba <- getWord64be + gr <- getGroupRef + cont <- getCont v + pure $ Push bf ba gr cont + | otherwise -> + Push + <$> getWord64be + <*> getWord64be + <*> getGroupRef + <*> getCont v + where + assert0 _name 0 = pure () + assert0 name n = exn $ "getCont: malformed intermediate term. Expected " <> name <> " to be 0, but got " <> show n + +deserializeCode :: ByteString -> Either String Code +deserializeCode bs = runGetS (getVersion >>= getCode) bs + where + getVersion = + getWord32be >>= \case + n | 1 <= n && n <= 3 -> pure n + n -> fail $ "deserializeGroup: unknown version: " ++ show n + +serializeCode :: Map ForeignFunc Text -> Code -> ByteString +serializeCode fops co = runPutS (putVersion *> putCode fops co) + where + putVersion = putWord32be codeVersion + +-- | Serializes a `SuperGroup` for rehashing. +-- +-- Expected as arguments are some code, and the `Reference` that +-- refers to it. In particular, if the code refers to itself by +-- reference, or if the code is part of a mututally-recursive set of +-- definitions (which have a common hash), the reference used as part +-- of that (mutual) recursion must be supplied. +-- +-- Using that reference, we find all references in the code to that +-- connected component. In the resulting byte string, those references +-- are instead replaced by positions in a listing of the connected +-- component. This means that the byte string is independent of the +-- hash used for the self reference. Only the order matters (which is +-- determined by the `Reference`). Then the bytes can be re-hashed to +-- establish a new hash for the connected component. This operation +-- should be idempotent as long as the indexing is preserved. +-- +-- Supplying a `Builtin` reference is not supported. Such code +-- shouldn't be subject to rehashing. +serializeGroupForRehash :: + (Var v) => + Map ForeignFunc Text -> + Reference -> + SuperGroup v -> + L.ByteString +serializeGroupForRehash _ (Builtin _) _ = + error "serializeForRehash: builtin reference" +serializeGroupForRehash fops (Derived h _) sg = + runPutLazy $ putGroup refrep fops sg + where + f r@(Derived h' i) | h == h' = Just (r, i) + f _ = Nothing + refrep = Map.fromList . mapMaybe f $ groupTermLinks sg + +getVersionedValue :: (MonadGet m) => m Value +getVersionedValue = getVersion >>= getValue . Transfer + where + getVersion = + getWord32be >>= \case + n + | n < 1 -> fail $ "deserializeValue: unknown version: " ++ show n + | n < 3 -> fail $ "deserializeValue: unsupported version: " ++ show n + | n <= 4 -> pure n + | otherwise -> fail $ "deserializeValue: unknown version: " ++ show n + +deserializeValue :: ByteString -> Either String Value +deserializeValue bs = runGetS getVersionedValue bs + +serializeValue :: Value -> ByteString +serializeValue v = + runPutS (putVersion *> putValue (Transfer valueVersion) v) + where + putVersion = putWord32be valueVersion + +-- This serializer is used exclusively for hashing unison values. +-- For this reason, it doesn't prefix the string with the current +-- version, so that only genuine changes in the way things are +-- serialized will change hashes. +-- +-- The 4 prefix is used because we were previously including the +-- version in the hash, so to maintain the same hashes, we need to +-- include the extra bytes that were previously there. +-- +-- Additionally, any major serialization changes should consider +-- retaining this representation as much as possible, even if it +-- becomes a separate format, because there is no need to parse from +-- the hash serialization, just generate and hash it. +serializeValueForHash :: Value -> L.ByteString +serializeValueForHash v = runPutLazy (putPrefix *> putValue (Hash 4) v) + where + putPrefix = putWord32be 4 + +valueVersion :: Word32 +valueVersion = 4 + +codeVersion :: Word32 +codeVersion = 3 diff --git a/unison-runtime/src/Unison/Runtime/Array.hs b/unison-runtime/src/Unison/Runtime/Array.hs new file mode 100644 index 0000000000..e34ff20efb --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Array.hs @@ -0,0 +1,429 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +-- This module wraps the operations in the primitive package so that +-- bounds checks can be toggled on during the build for debugging +-- purposes. It exports the entire API for the three array types +-- needed, and adds wrappers for the operations that are unchecked in +-- the base library. +-- +-- Checking is toggled using the `arraychecks` flag. +module Unison.Runtime.Array + ( module EPA, + byteArrayToList, + readArray, + writeArray, + copyArray, + copyMutableArray, + cloneMutableArray, + readByteArray, + writeByteArray, + indexByteArray, + copyByteArray, + copyMutableByteArray, + moveByteArray, + readPrimArray, + writePrimArray, + indexPrimArray, + ) +where + +import Control.Monad.Primitive +import Data.Kind (Constraint) +import Data.Primitive.Array as EPA hiding + ( cloneMutableArray, + copyArray, + copyMutableArray, + readArray, + writeArray, + ) +import Data.Primitive.Array qualified as PA +import Data.Primitive.ByteArray as EPA hiding + ( copyByteArray, + copyMutableByteArray, + indexByteArray, + moveByteArray, + readByteArray, + writeByteArray, + ) +import Data.Primitive.ByteArray qualified as PA +import Data.Primitive.PrimArray as EPA hiding + ( indexPrimArray, + readPrimArray, + writePrimArray, + ) +import Data.Primitive.PrimArray qualified as PA +import Data.Primitive.Types +import Data.Word (Word8) +import GHC.IsList (toList) + +#ifdef ARRAY_CHECK +import GHC.Stack + +type CheckCtx :: Constraint +type CheckCtx = HasCallStack + +type MA = MutableArray +type MBA = MutableByteArray +type A = Array +type BA = ByteArray + +-- check index mutable array +checkIMArray + :: CheckCtx + => String + -> (MA s a -> Int -> r) + -> MA s a -> Int -> r +checkIMArray name f arr i + | i < 0 || sizeofMutableArray arr <= i + = error $ name ++ " unsafe check out of bounds: " ++ show i + | otherwise = f arr i +{-# inline checkIMArray #-} + +-- check copy array +checkCArray + :: CheckCtx + => String + -> (MA s a -> Int -> A a -> Int -> Int -> r) + -> MA s a -> Int -> A a -> Int -> Int -> r +checkCArray name f dst d src s l + | d < 0 + || s < 0 + || sizeofMutableArray dst < d + l + || sizeofArray src < s + l + = error $ name ++ " unsafe check out of bounds: " ++ show (d, s, l) + | otherwise = f dst d src s l +{-# inline checkCArray #-} + +-- check copy mutable array +checkCMArray + :: CheckCtx + => String + -> (MA s a -> Int -> MA s a -> Int -> Int -> r) + -> MA s a -> Int -> MA s a -> Int -> Int -> r +checkCMArray name f dst d src s l + | d < 0 + || s < 0 + || sizeofMutableArray dst < d + l + || sizeofMutableArray src < s + l + = error $ name ++ " unsafe check out of bounds: " ++ show (d, s, l) + | otherwise = f dst d src s l +{-# inline checkCMArray #-} + +-- check range mutable array +checkRMArray + :: CheckCtx + => String + -> (MA s a -> Int -> Int -> r) + -> MA s a -> Int -> Int -> r +checkRMArray name f arr o l + | o < 0 || sizeofMutableArray arr < o+l + = error $ name ++ "unsafe check out of bounds: " ++ show (o, l) + | otherwise = f arr o l +{-# inline checkRMArray #-} + +-- check index byte array +checkIBArray + :: CheckCtx + => Prim a + => String + -> a + -> (ByteArray -> Int -> r) + -> ByteArray -> Int -> r +checkIBArray name a f arr i + | i < 0 || sizeofByteArray arr `quot` sizeOf a <= i + = error $ name ++ " unsafe check out of bounds: " ++ show i + | otherwise = f arr i +{-# inline checkIBArray #-} + +-- check index mutable byte array +checkIMBArray + :: CheckCtx + => Prim a + => PrimMonad m + => String + -> a + -> (MutableByteArray (PrimState m) -> Int -> m r) + -> MutableByteArray (PrimState m) -> Int -> m r +checkIMBArray name a f arr i = do + sz <- getSizeofMutableByteArray arr + if (i < 0 || sz `quot` sizeOf a <= i) + then error $ name ++ " unsafe check out of bounds: " ++ show i + else f arr i +{-# inline checkIMBArray #-} + +-- check write mutable byte array +checkWMBArray + :: CheckCtx + => Prim a + => PrimMonad m + => String + -> (MutableByteArray (PrimState m) -> Int -> a -> m r) + -> MutableByteArray (PrimState m) -> Int -> a -> m r +checkWMBArray name f arr i a = do + sz <- getSizeofMutableByteArray arr + if (i < 0 || sz `quot` sizeOf a <= i) + then error $ name ++ " unsafe check out of bounds: " ++ show i + else f arr i a +{-# inline checkWMBArray #-} + + +-- check copy byte array +checkCBArray + :: CheckCtx + => PrimMonad m + => String + -> (MBA (PrimState m) -> Int -> BA -> Int -> Int -> m r) + -> MBA (PrimState m) -> Int -> BA -> Int -> Int -> m r +checkCBArray name f dst d src s l = do + szd <- getSizeofMutableByteArray dst + if (d < 0 + || s < 0 + || szd < d + l + || sizeofByteArray src < s + l + ) then error $ name ++ " unsafe check out of bounds: " ++ show (d, s, l) + else f dst d src s l +{-# inline checkCBArray #-} + +-- check copy mutable byte array +checkCMBArray + :: CheckCtx + => PrimMonad m + => String + -> (MBA (PrimState m) -> Int -> MBA (PrimState m) -> Int -> Int -> m r) + -> MBA (PrimState m) -> Int -> MBA (PrimState m) -> Int -> Int -> m r +checkCMBArray name f dst d src s l = do + szd <- getSizeofMutableByteArray dst + szs <- getSizeofMutableByteArray src + if ( d < 0 + || s < 0 + || szd < d + l + || szs < s + l + ) then error $ name ++ " unsafe check out of bounds: " ++ show (d, s, l) + else f dst d src s l +{-# inline checkCMBArray #-} + +-- check index prim array +checkIPArray + :: CheckCtx + => Prim a + => String + -> (PrimArray a -> Int -> r) + -> PrimArray a -> Int -> r +checkIPArray name f arr i + | i < 0 || sizeofPrimArray arr <= i + = error $ name ++ " unsafe check out of bounds: " ++ show i + | otherwise = f arr i +{-# inline checkIPArray #-} + +-- check index mutable prim array +checkIMPArray + :: CheckCtx + => PrimMonad m + => Prim a + => String + -> (MutablePrimArray (PrimState m) a -> Int -> m r) + -> MutablePrimArray (PrimState m) a -> Int -> m r +checkIMPArray name f arr i = do + asz <- getSizeofMutablePrimArray arr + if (i < 0 || asz <= i) + then error $ name ++ " unsafe check out of bounds: " ++ show i + else f arr i +{-# inline checkIMPArray #-} + +-- check write mutable prim array +checkWMPArray + :: CheckCtx + => PrimMonad m + => Prim a + => String + -> (MutablePrimArray (PrimState m) a -> Int -> a -> m r) + -> MutablePrimArray (PrimState m) a -> Int -> a -> m r +checkWMPArray name f arr i a = do + asz <- getSizeofMutablePrimArray arr + if (i < 0 || asz <= i) + then error $ name ++ " unsafe check out of bounds: " ++ show i + else f arr i a +{-# inline checkWMPArray #-} + + +#else +type CheckCtx :: Constraint +type CheckCtx = () + +checkIMArray, checkIMPArray, checkWMPArray, checkIPArray :: String -> r -> r +checkCArray, checkCMArray, checkRMArray :: String -> r -> r +checkIMArray _ = id +checkIMPArray _ = id +checkWMPArray _ = id +checkCArray _ = id +checkCMArray _ = id +checkRMArray _ = id +checkIPArray _ = id + +checkIBArray, checkIMBArray:: String -> a -> r -> r +checkCBArray, checkCMBArray :: String -> r -> r +checkIBArray _ _ = id +checkIMBArray _ _ = id +checkCBArray _ = id +checkCMBArray _ = id + +checkWMBArray :: String -> r -> r +checkWMBArray _ = id +#endif + +readArray :: + (CheckCtx) => + (PrimMonad m) => + MutableArray (PrimState m) a -> + Int -> + m a +readArray = checkIMArray "readArray" PA.readArray +{-# INLINE readArray #-} + +writeArray :: + (CheckCtx) => + (PrimMonad m) => + MutableArray (PrimState m) a -> + Int -> + a -> + m () +writeArray = checkIMArray "writeArray" PA.writeArray +{-# INLINE writeArray #-} + +copyArray :: + (CheckCtx) => + (PrimMonad m) => + MutableArray (PrimState m) a -> + Int -> + Array a -> + Int -> + Int -> + m () +copyArray = checkCArray "copyArray" PA.copyArray +{-# INLINE copyArray #-} + +cloneMutableArray :: + (CheckCtx) => + (PrimMonad m) => + MutableArray (PrimState m) a -> + Int -> + Int -> + m (MutableArray (PrimState m) a) +cloneMutableArray = checkRMArray "cloneMutableArray" PA.cloneMutableArray +{-# INLINE cloneMutableArray #-} + +copyMutableArray :: + (CheckCtx) => + (PrimMonad m) => + MutableArray (PrimState m) a -> + Int -> + MutableArray (PrimState m) a -> + Int -> + Int -> + m () +copyMutableArray = checkCMArray "copyMutableArray" PA.copyMutableArray +{-# INLINE copyMutableArray #-} + +readByteArray :: + forall a m. + (CheckCtx) => + (PrimMonad m) => + (Prim a) => + MutableByteArray (PrimState m) -> + Int -> + m a +readByteArray = checkIMBArray @a "readByteArray" undefined PA.readByteArray +{-# INLINE readByteArray #-} + +writeByteArray :: + forall a m. + (CheckCtx) => + (PrimMonad m) => + (Prim a) => + MutableByteArray (PrimState m) -> + Int -> + a -> + m () +writeByteArray = checkWMBArray "writeByteArray" PA.writeByteArray +{-# INLINE writeByteArray #-} + +indexByteArray :: + forall a. + (CheckCtx) => + (Prim a) => + ByteArray -> + Int -> + a +indexByteArray = checkIBArray @a "indexByteArray" undefined PA.indexByteArray +{-# INLINE indexByteArray #-} + +copyByteArray :: + (CheckCtx) => + (PrimMonad m) => + MutableByteArray (PrimState m) -> + Int -> + ByteArray -> + Int -> + Int -> + m () +copyByteArray = checkCBArray "copyByteArray" PA.copyByteArray +{-# INLINE copyByteArray #-} + +copyMutableByteArray :: + (CheckCtx) => + (PrimMonad m) => + MutableByteArray (PrimState m) -> + Int -> + MutableByteArray (PrimState m) -> + Int -> + Int -> + m () +copyMutableByteArray = checkCMBArray "copyMutableByteArray" PA.copyMutableByteArray +{-# INLINE copyMutableByteArray #-} + +moveByteArray :: + (CheckCtx) => + (PrimMonad m) => + MutableByteArray (PrimState m) -> + Int -> + MutableByteArray (PrimState m) -> + Int -> + Int -> + m () +moveByteArray = checkCMBArray "moveByteArray" PA.moveByteArray +{-# INLINE moveByteArray #-} + +readPrimArray :: + (CheckCtx) => + (PrimMonad m) => + (Prim a) => + MutablePrimArray (PrimState m) a -> + Int -> + m a +readPrimArray = checkIMPArray "readPrimArray" PA.readPrimArray +{-# INLINE readPrimArray #-} + +writePrimArray :: + (CheckCtx) => + (PrimMonad m) => + (Prim a) => + MutablePrimArray (PrimState m) a -> + Int -> + a -> + m () +writePrimArray = checkWMPArray "writePrimArray" PA.writePrimArray +{-# INLINE writePrimArray #-} + +indexPrimArray :: + (CheckCtx) => + (Prim a) => + PrimArray a -> + Int -> + a +indexPrimArray = checkIPArray "indexPrimArray" PA.indexPrimArray +{-# INLINE indexPrimArray #-} + +byteArrayToList :: ByteArray -> [Word8] +byteArrayToList = toList diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs new file mode 100644 index 0000000000..6752dcbd34 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -0,0 +1,2132 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Unison.Runtime.Builtin + ( builtinTermNumbering, + builtinTypeNumbering, + builtinTermBackref, + builtinTypeBackref, + builtinArities, + builtinInlineInfo, + numberedTermLookup, + Sandbox (..), + baseSandboxInfo, + unitValue, + natValue, + builtinForeignNames, + sandboxedForeignFuncs, + ) +where + +import Control.Monad.State.Strict (State, execState, modify) +import Data.Map qualified as Map +import Data.Set (insert) +import Data.Set qualified as Set +import Data.Text qualified +import Unison.ABT.Normalized hiding (TTm) +import Unison.Builtin.Decls qualified as Ty +import Unison.Prelude hiding (Text, some) +import Unison.Reference +import Unison.Runtime.ANF as ANF +import Unison.Runtime.Builtin.Types +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..), foreignFuncBuiltinName) +import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), unboxedTypeTagToInt) +import Unison.Runtime.Stack qualified as Closure +import Unison.Symbol +import Unison.Type qualified as Ty +import Unison.Util.EnumContainers as EC +import Unison.Util.Text qualified as Util.Text +import Unison.Var + +freshes :: (Var v) => Int -> [v] +freshes = freshes' mempty + +freshes' :: (Var v) => Set v -> Int -> [v] +freshes' avoid0 = go avoid0 [] + where + go _ vs 0 = vs + go avoid vs n = + let v = freshIn avoid $ typed ANFBlank + in go (insert v avoid) (v : vs) (n - 1) + +class Fresh t where fresh :: t + +fresh1 :: (Var v) => v +fresh1 = head $ freshes 1 + +instance (Var v) => Fresh (v, v) where + fresh = (v1, v2) + where + [v1, v2] = freshes 2 + +instance (Var v) => Fresh (v, v, v) where + fresh = (v1, v2, v3) + where + [v1, v2, v3] = freshes 3 + +instance (Var v) => Fresh (v, v, v, v) where + fresh = (v1, v2, v3, v4) + where + [v1, v2, v3, v4] = freshes 4 + +instance (Var v) => Fresh (v, v, v, v, v) where + fresh = (v1, v2, v3, v4, v5) + where + [v1, v2, v3, v4, v5] = freshes 5 + +instance (Var v) => Fresh (v, v, v, v, v, v) where + fresh = (v1, v2, v3, v4, v5, v6) + where + [v1, v2, v3, v4, v5, v6] = freshes 6 + +instance (Var v) => Fresh (v, v, v, v, v, v, v) where + fresh = (v1, v2, v3, v4, v5, v6, v7) + where + [v1, v2, v3, v4, v5, v6, v7] = freshes 7 + +instance (Var v) => Fresh (v, v, v, v, v, v, v, v) where + fresh = (v1, v2, v3, v4, v5, v6, v7, v8) + where + [v1, v2, v3, v4, v5, v6, v7, v8] = freshes 8 + +instance (Var v) => Fresh (v, v, v, v, v, v, v, v, v) where + fresh = (v1, v2, v3, v4, v5, v6, v7, v8, v9) + where + [v1, v2, v3, v4, v5, v6, v7, v8, v9] = freshes 9 + +instance (Var v) => Fresh (v, v, v, v, v, v, v, v, v, v) where + fresh = (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) + where + [v1, v2, v3, v4, v5, v6, v7, v8, v9, v10] = freshes 10 + +instance (Var v) => Fresh (v, v, v, v, v, v, v, v, v, v, v) where + fresh = (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11) + where + [v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11] = freshes 11 + +instance (Var v) => Fresh (v, v, v, v, v, v, v, v, v, v, v, v, v) where + fresh = (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13) + where + [v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13] = freshes 13 + +instance (Var v) => Fresh (v, v, v, v, v, v, v, v, v, v, v, v, v, v) where + fresh = (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14) + where + [v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14] = freshes 14 + +fls, tru :: (Var v) => ANormal v +fls = TCon Ty.booleanRef 0 [] +tru = TCon Ty.booleanRef 1 [] + +none :: (Var v) => ANormal v +none = TCon Ty.optionalRef (fromIntegral Ty.noneId) [] + +some, left, right :: (Var v) => v -> ANormal v +some a = TCon Ty.optionalRef (fromIntegral Ty.someId) [a] +left x = TCon Ty.eitherRef (fromIntegral Ty.eitherLeftId) [x] +right x = TCon Ty.eitherRef (fromIntegral Ty.eitherRightId) [x] + +seqViewEmpty :: (Var v) => ANormal v +seqViewEmpty = TCon Ty.seqViewRef (fromIntegral Ty.seqViewEmpty) [] + +seqViewElem :: (Var v) => v -> v -> ANormal v +seqViewElem l r = TCon Ty.seqViewRef (fromIntegral Ty.seqViewElem) [l, r] + +unenum :: (Var v) => Int -> v -> Reference -> v -> ANormal v -> ANormal v +unenum n v0 r v nx = + TMatch v0 $ MatchData r cases Nothing + where + mkCase i = (toEnum i, ([], TLetD v UN (TLit . I $ fromIntegral i) nx)) + cases = mapFromList . fmap mkCase $ [0 .. n - 1] + +unop0 :: (Var v) => Int -> ([v] -> ANormal v) -> SuperNormal v +unop0 n f = + Lambda [BX] + . TAbss [x0] + $ f xs + where + xs@(x0 : _) = freshes (1 + n) + +binop0 :: (Var v) => Int -> ([v] -> ANormal v) -> SuperNormal v +binop0 n f = + Lambda [BX, BX] + . TAbss [x0, y0] + $ f xs + where + xs@(x0 : y0 : _) = freshes (2 + n) + +unop :: (Var v) => POp -> SuperNormal v +unop pop = + unop0 0 $ \[x] -> + (TPrm pop [x]) + +binop :: + (Var v) => + POp -> + SuperNormal v +binop pop = + binop0 0 $ \[x, y] -> TPrm pop [x, y] + +-- | Like `binop`, but swaps the arguments. +binopSwap :: (Var v) => POp -> SuperNormal v +binopSwap pop = + binop0 0 $ \[x, y] -> TPrm pop [y, x] + +addi, subi, muli, divi, modi, shli, shri, powi :: (Var v) => SuperNormal v +addi = binop ADDI +subi = binop SUBI +muli = binop MULI +divi = binop DIVI +modi = binop MODI +shli = binop SHLI +shri = binop SHRI +powi = binop POWI + +addn, subn, muln, divn, modn, shln, shrn, pown, dropn :: (Var v) => SuperNormal v +addn = binop ADDN +subn = binop SUBN +muln = binop MULN +divn = binop DIVN +modn = binop MODN +shln = binop SHLN +shrn = binop SHRN +pown = binop POWN +dropn = binop DRPN + +eqi, eqn, lti, ltn, lei, len :: (Var v) => SuperNormal v +eqi = binop EQLI +lti = binop LESI +lei = binop LEQI +eqn = binop EQLN +ltn = binop LESN +len = binop LEQN + +gti, gtn, gei, gen :: (Var v) => SuperNormal v +gti = binopSwap LESI +gei = binopSwap LEQI +gtn = binopSwap LESN +gen = binopSwap LEQN + +inci, incn :: (Var v) => SuperNormal v +inci = unop INCI +incn = unop INCN + +sgni, negi :: (Var v) => SuperNormal v +sgni = unop SGNI +negi = unop NEGI + +lzeron, tzeron, lzeroi, tzeroi, popn, popi :: (Var v) => SuperNormal v +lzeron = unop LZRO +tzeron = unop TZRO +popn = unop POPC +popi = unop POPC +lzeroi = unop LZRO +tzeroi = unop TZRO + +andn, orn, xorn, compln, andi, ori, xori, compli :: (Var v) => SuperNormal v +andn = binop ANDN +orn = binop IORN +xorn = binop XORN +compln = unop COMN +andi = binop ANDI +ori = binop IORI +xori = binop XORI +compli = unop COMI + +addf, + subf, + mulf, + divf, + powf, + sqrtf, + logf, + logbf :: + (Var v) => SuperNormal v +addf = binop ADDF +subf = binop SUBF +mulf = binop MULF +divf = binop DIVF +powf = binop POWF +sqrtf = unop SQRT +logf = unop LOGF +logbf = binop LOGB + +expf, absf :: (Var v) => SuperNormal v +expf = unop EXPF +absf = unop ABSF + +cosf, sinf, tanf, acosf, asinf, atanf :: (Var v) => SuperNormal v +cosf = unop COSF +sinf = unop SINF +tanf = unop TANF +acosf = unop ACOS +asinf = unop ASIN +atanf = unop ATAN + +coshf, + sinhf, + tanhf, + acoshf, + asinhf, + atanhf, + atan2f :: + (Var v) => SuperNormal v +coshf = unop COSH +sinhf = unop SINH +tanhf = unop TANH +acoshf = unop ACSH +asinhf = unop ASNH +atanhf = unop ATNH +atan2f = binop ATN2 + +ltf, gtf, lef, gef, eqf, neqf :: (Var v) => SuperNormal v +ltf = binop LESF +gtf = binopSwap LESF +lef = binop LEQF +gef = binopSwap LEQF +eqf = binop EQLF +neqf = binop NEQF + +minf, maxf :: (Var v) => SuperNormal v +minf = binop MINF +maxf = binop MAXF + +ceilf, floorf, truncf, roundf, i2f, n2f :: (Var v) => SuperNormal v +ceilf = unop CEIL +floorf = unop FLOR +truncf = unop TRNF +roundf = unop RNDF +i2f = unop ITOF +n2f = unop NTOF + +trni :: (Var v) => SuperNormal v +trni = unop TRNC + +modular :: (Var v) => POp -> (Bool -> ANormal v) -> SuperNormal v +modular pop ret = + unop0 2 $ \[x, m, t] -> + TLetD t UN (TLit $ I 2) + . TLetD m UN (TPrm pop [x, t]) + . TMatch m + $ MatchIntegral + (mapSingleton 1 $ ret True) + (Just $ ret False) + +evni, evnn, oddi, oddn :: (Var v) => SuperNormal v +evni = modular MODI (\b -> if b then fls else tru) +oddi = modular MODI (\b -> if b then tru else fls) +evnn = modular MODN (\b -> if b then fls else tru) +oddn = modular MODN (\b -> if b then tru else fls) + +appendt, taket, dropt, indext, indexb, sizet, unconst, unsnoct :: (Var v) => SuperNormal v +appendt = binop0 0 $ \[x, y] -> TPrm CATT [x, y] +taket = binop0 0 $ \[x, y] -> + TPrm TAKT [x, y] +dropt = binop0 0 $ \[x, y] -> + TPrm DRPT [x, y] + +atb = binop0 2 $ \[n, b, t, r] -> + TLetD t UN (TPrm IDXB [n, b]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([], none)), + ( 1, + ( [UN], + TAbs r $ some r + ) + ) + ] + +indext = binop0 2 $ \[x, y, t, r] -> + TLetD t UN (TPrm IXOT [x, y]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([], none)), + ( 1, + ( [UN], + TAbs r $ some r + ) + ) + ] + +indexb = binop0 2 $ \[x, y, t, r] -> + TLetD t UN (TPrm IXOB [x, y]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([], none)), + ( 1, + ( [UN], + TAbs r $ some r + ) + ) + ] + +sizet = unop0 0 $ \[x] -> TPrm SIZT [x] + +unconst = unop0 6 $ \[x, t, c, y, p, u, yp] -> + TLetD t UN (TPrm UCNS [x]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([], none)), + ( 1, + ( [UN, BX], + TAbss [c, y] + . TLetD u BX (TCon Ty.unitRef 0 []) + . TLetD yp BX (TCon Ty.pairRef 0 [y, u]) + . TLetD p BX (TCon Ty.pairRef 0 [c, yp]) + $ some p + ) + ) + ] + +unsnoct = unop0 6 $ \[x, t, c, y, p, u, cp] -> + TLetD t UN (TPrm USNC [x]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([], none)), + ( 1, + ( [BX, UN], + TAbss [y, c] + . TLetD u BX (TCon Ty.unitRef 0 []) + . TLetD cp BX (TCon Ty.pairRef 0 [c, u]) + . TLetD p BX (TCon Ty.pairRef 0 [y, cp]) + $ some p + ) + ) + ] + +appends, conss, snocs :: (Var v) => SuperNormal v +appends = binop0 0 $ \[x, y] -> TPrm CATS [x, y] +conss = binop0 0 $ \[x, y] -> TPrm CONS [x, y] +snocs = binop0 0 $ \[x, y] -> TPrm SNOC [x, y] + +takes, drops, sizes, ats, emptys :: (Var v) => SuperNormal v +takes = binop0 0 $ \[x, y] -> TPrm TAKS [x, y] +drops = binop0 0 $ \[x, y] -> TPrm DRPS [x, y] +sizes = unop0 0 $ \[x] -> (TPrm SIZS [x]) +ats = binop0 2 $ \[x, y, t, r] -> + TLetD t UN (TPrm IDXS [x, y]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([], none)), + (1, ([BX], TAbs r $ some r)) + ] +emptys = Lambda [] $ TPrm BLDS [] + +viewls, viewrs :: (Var v) => SuperNormal v +viewls = unop0 3 $ \[s, u, h, t] -> + TLetD u UN (TPrm VWLS [s]) + . TMatch u + . MatchSum + $ mapFromList + [ (0, ([], seqViewEmpty)), + (1, ([BX, BX], TAbss [h, t] $ seqViewElem h t)) + ] +viewrs = unop0 3 $ \[s, u, i, l] -> + TLetD u UN (TPrm VWRS [s]) + . TMatch u + . MatchSum + $ mapFromList + [ (0, ([], seqViewEmpty)), + (1, ([BX, BX], TAbss [i, l] $ seqViewElem i l)) + ] + +splitls, splitrs :: (Var v) => SuperNormal v +splitls = binop0 3 $ \[n, s, t, l, r] -> + TLetD t UN (TPrm SPLL [n, s]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([], seqViewEmpty)), + (1, ([BX, BX], TAbss [l, r] $ seqViewElem l r)) + ] +splitrs = binop0 3 $ \[n, s, t, l, r] -> + TLetD t UN (TPrm SPLR [n, s]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([], seqViewEmpty)), + (1, ([BX, BX], TAbss [l, r] $ seqViewElem l r)) + ] + +eqt, neqt, leqt, geqt, lesst, great :: SuperNormal Symbol +eqt = binop EQLT +neqt = binop0 1 $ \[x, y, b] -> + TLetD b UN (TPrm EQLT [x, y]) $ + TPrm NOTB [b] +leqt = binop LEQT +geqt = binopSwap LEQT +lesst = binop0 1 $ \[x, y, b] -> + TLetD b UN (TPrm LEQT [y, x]) $ + TPrm NOTB [b] +great = binop0 1 $ \[x, y, b] -> + TLetD b UN (TPrm LEQT [x, y]) $ + TPrm NOTB [b] + +packt, unpackt :: SuperNormal Symbol +packt = unop0 0 $ \[s] -> TPrm PAKT [s] +unpackt = unop0 0 $ \[t] -> TPrm UPKT [t] + +packb, unpackb, emptyb, appendb :: SuperNormal Symbol +packb = unop0 0 $ \[s] -> TPrm PAKB [s] +unpackb = unop0 0 $ \[b] -> TPrm UPKB [b] +emptyb = + Lambda [] + . TLetD es BX (TPrm BLDS []) + $ TPrm PAKB [es] + where + es = fresh1 +appendb = binop0 0 $ \[x, y] -> TPrm CATB [x, y] + +takeb, dropb, atb, sizeb, flattenb :: SuperNormal Symbol +takeb = binop0 0 $ \[n, b] -> TPrm TAKB [n, b] +dropb = binop0 0 $ \[n, b] -> TPrm DRPB [n, b] +sizeb = unop0 0 $ \[b] -> (TPrm SIZB [b]) +flattenb = unop0 0 $ \[b] -> TPrm FLTB [b] + +i2t, n2t, f2t :: SuperNormal Symbol +i2t = unop0 0 $ \[n] -> TPrm ITOT [n] +n2t = unop0 0 $ \[n] -> TPrm NTOT [n] +f2t = unop0 0 $ \[f] -> TPrm FTOT [f] + +t2i, t2n, t2f :: SuperNormal Symbol +t2i = unop0 2 $ \[x, t, n] -> + TLetD t UN (TPrm TTOI [x]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([], none)), + ( 1, + ( [UN], + TAbs n $ some n + ) + ) + ] +t2n = unop0 2 $ \[x, t, n] -> + TLetD t UN (TPrm TTON [x]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([], none)), + ( 1, + ( [UN], + TAbs n $ some n + ) + ) + ] +t2f = unop0 2 $ \[x, t, f] -> + TLetD t UN (TPrm TTOF [x]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([], none)), + ( 1, + ( [UN], + TAbs f $ some f + ) + ) + ] + +equ :: SuperNormal Symbol +equ = binop EQLU + +cmpu :: SuperNormal Symbol +cmpu = binop CMPU + +ltu :: SuperNormal Symbol +ltu = binop LESU + +gtu :: SuperNormal Symbol +gtu = binopSwap LESU + +geu :: SuperNormal Symbol +geu = binopSwap LEQU + +leu :: SuperNormal Symbol +leu = binop LEQU + +notb :: SuperNormal Symbol +notb = unop NOTB + +orb :: SuperNormal Symbol +orb = binop IORB + +andb :: SuperNormal Symbol +andb = binop ANDB + +-- A runtime type-cast. Used to unsafely coerce between unboxed +-- types at runtime without changing their representation. +coerceType :: UnboxedTypeTag -> SuperNormal Symbol +coerceType destType = + unop0 1 $ \[v, tag] -> + TLetD tag UN (TLit $ I $ fromIntegral $ unboxedTypeTagToInt destType) $ + TPrm CAST [v, tag] + +-- This version of unsafeCoerce is the identity function. It works +-- only if the two types being coerced between are actually the same, +-- because it keeps the same representation. It is not capable of +-- e.g. correctly translating between two types with compatible bit +-- representations, because tagging information will be retained. +poly'coerce :: SuperNormal Symbol +poly'coerce = unop0 0 $ \[x] -> TVar x + +jumpk :: SuperNormal Symbol +jumpk = binop0 0 $ \[k, a] -> TKon k [a] + +scope'run :: SuperNormal Symbol +scope'run = + unop0 1 $ \[e, un] -> + TLetD un BX (TCon Ty.unitRef 0 []) $ + TApp (FVar e) [un] + +fork'comp :: SuperNormal Symbol +fork'comp = + Lambda [BX] + . TAbs act + . TLetD unit BX (TCon Ty.unitRef 0 []) + . TName lz (Right act) [unit] + $ TPrm FORK [lz] + where + (act, unit, lz) = fresh + +try'eval :: SuperNormal Symbol +try'eval = + Lambda [BX] + . TAbs act + . TLetD unit BX (TCon Ty.unitRef 0 []) + . TName lz (Right act) [unit] + . TLetD ta UN (TPrm TFRC [lz]) + . TMatch ta + . MatchSum + $ mapFromList + [ exnCase lnk msg xtra any fail, + (1, ([BX], TAbs r (TVar r))) + ] + where + (act, unit, lz, ta, lnk, msg, xtra, any, fail, r) = fresh + +bug :: Util.Text.Text -> SuperNormal Symbol +bug name = + unop0 1 $ \[x, n] -> + TLetD n BX (TLit $ T name) $ + TPrm EROR [n, x] + +watch :: SuperNormal Symbol +watch = + binop0 0 $ \[t, v] -> + TLets Direct [] [] (TPrm PRNT [t]) $ + TVar v + +raise :: SuperNormal Symbol +raise = + unop0 3 $ \[r, f, n, k] -> + TMatch r + . flip MatchRequest (TAbs f $ TVar f) + . Map.singleton Ty.exceptionRef + $ mapSingleton + 0 + ( [BX], + TAbs f + . TShift Ty.exceptionRef k + . TLetD n BX (TLit $ T "builtin.raise") + $ TPrm EROR [n, f] + ) + +gen'trace :: SuperNormal Symbol +gen'trace = + binop0 0 $ \[t, v] -> + TLets Direct [] [] (TPrm TRCE [t, v]) $ + TCon Ty.unitRef 0 [] + +debug'text :: SuperNormal Symbol +debug'text = + unop0 3 $ \[c, r, t, e] -> + TLetD r UN (TPrm DBTX [c]) + . TMatch r + . MatchSum + $ mapFromList + [ (0, ([], none)), + (1, ([BX], TAbs t . TLetD e BX (left t) $ some e)), + (2, ([BX], TAbs t . TLetD e BX (right t) $ some e)) + ] + +code'missing :: SuperNormal Symbol +code'missing = unop MISS + +code'cache :: SuperNormal Symbol +code'cache = unop0 0 $ \[new] -> TPrm CACH [new] + +code'lookup :: SuperNormal Symbol +code'lookup = + unop0 2 $ \[link, t, r] -> + TLetD t UN (TPrm LKUP [link]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([], none)), + (1, ([BX], TAbs r $ some r)) + ] + +code'validate :: SuperNormal Symbol +code'validate = + unop0 6 $ \[item, t, ref, msg, extra, any, fail] -> + TLetD t UN (TPrm CVLD [item]) + . TMatch t + . MatchSum + $ mapFromList + [ ( 1, + ([BX, BX, BX],) + . TAbss [ref, msg, extra] + . TLetD any BX (TCon Ty.anyRef 0 [extra]) + . TLetD fail BX (TCon Ty.failureRef 0 [ref, msg, any]) + $ some fail + ), + ( 0, + ([],) $ + none + ) + ] + +term'link'to'text :: SuperNormal Symbol +term'link'to'text = + unop0 0 $ \[link] -> TPrm TLTT [link] + +value'load :: SuperNormal Symbol +value'load = + unop0 2 $ \[vlu, t, r] -> + TLetD t UN (TPrm LOAD [vlu]) + . TMatch t + . MatchSum + $ mapFromList + [ (0, ([BX], TAbs r $ left r)), + (1, ([BX], TAbs r $ right r)) + ] + +value'create :: SuperNormal Symbol +value'create = unop0 0 $ \[x] -> TPrm VALU [x] + +check'sandbox :: SuperNormal Symbol +check'sandbox = binop SDBX + +sandbox'links :: SuperNormal Symbol +sandbox'links = Lambda [BX] . TAbs ln $ TPrm SDBL [ln] + where + ln = fresh1 + +value'sandbox :: SuperNormal Symbol +value'sandbox = + Lambda [BX, BX] + . TAbss [refs, val] + $ TPrm SDBV [refs, val] + where + (refs, val) = fresh + +stm'atomic :: SuperNormal Symbol +stm'atomic = + Lambda [BX] + . TAbs act + . TLetD unit BX (TCon Ty.unitRef 0 []) + . TName lz (Right act) [unit] + $ TPrm ATOM [lz] + where + (act, unit, lz) = fresh + +type ForeignOp = ForeignFunc -> ([Mem], ANormal Symbol) + +standard'handle :: ForeignOp +standard'handle instr = + ([BX],) + . TAbss [h0] + . unenum 3 h0 Ty.stdHandleRef h + $ TFOp instr [h] + where + (h0, h) = fresh + +any'construct :: SuperNormal Symbol +any'construct = + unop0 0 $ \[v] -> + TCon Ty.anyRef 0 [v] + +any'extract :: SuperNormal Symbol +any'extract = + unop0 1 $ + \[v, v1] -> + TMatch v $ + MatchData Ty.anyRef (mapSingleton 0 $ ([BX], TAbs v1 (TVar v1))) Nothing + +-- Refs + +-- The docs for IORef state that IORef operations can be observed +-- out of order ([1]) but actually GHC does emit the appropriate +-- load and store barriers nowadays ([2], [3]). +-- +-- [1] https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-IORef.html#g:2 +-- [2] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L286 +-- [3] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L298 +ref'read :: SuperNormal Symbol +ref'read = + unop0 0 $ \[ref] -> (TPrm REFR [ref]) + +ref'write :: SuperNormal Symbol +ref'write = + binop0 0 $ \[ref, val] -> (TPrm REFW [ref, val]) + +-- In GHC, CAS returns both a Boolean and the current value of the +-- IORef, which can be used to retry a failed CAS. +-- This strategy is more efficient than returning a Boolean only +-- because it uses a single call to cmpxchg in assembly (see [1]) to +-- avoid an extra read per CAS iteration, however it's not supported +-- in Scheme. +-- Therefore, we adopt the more common signature that only returns a +-- Boolean, which doesn't even suffer from spurious failures because +-- GHC issues loads of mutable variables with memory_order_acquire +-- (see [2]) +-- +-- [1]: https://github.com/ghc/ghc/blob/master/rts/PrimOps.cmm#L697 +-- [2]: https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L285 +ref'cas :: SuperNormal Symbol +ref'cas = + Lambda [BX, BX, BX] + . TAbss [x, y, z] + $ TPrm RCAS [x, y, z] + where + (x, y, z) = fresh + +ref'ticket'read :: SuperNormal Symbol +ref'ticket'read = unop0 0 $ TPrm TIKR + +ref'readForCas :: SuperNormal Symbol +ref'readForCas = unop0 0 $ TPrm RRFC + +ref'new :: SuperNormal Symbol +ref'new = unop0 0 $ TPrm REFN + +seek'handle :: ForeignOp +seek'handle instr = + ([BX, BX, BX],) + . TAbss [arg1, arg2, arg3] + . unenum 3 arg2 Ty.seekModeRef seek + . TLetD result UN (TFOp instr [arg1, seek, arg3]) + $ outIoFailUnit stack1 stack2 stack3 unit fail result + where + (arg1, arg2, arg3, seek, stack1, stack2, stack3, unit, fail, result) = fresh + +no'buf, line'buf, block'buf, sblock'buf :: (Enum e) => e +no'buf = toEnum $ fromIntegral Ty.bufferModeNoBufferingId +line'buf = toEnum $ fromIntegral Ty.bufferModeLineBufferingId +block'buf = toEnum $ fromIntegral Ty.bufferModeBlockBufferingId +sblock'buf = toEnum $ fromIntegral Ty.bufferModeSizedBlockBufferingId + +infixr 0 --> + +(-->) :: a -> b -> (a, b) +x --> y = (x, y) + +time'zone :: ForeignOp +time'zone instr = + ([BX],) + . TAbss [secs] + . TLets Direct [offset, summer, name] [UN, UN, BX] (TFOp instr [secs]) + . TLetD un BX (TCon Ty.unitRef 0 []) + . TLetD p2 BX (TCon Ty.pairRef 0 [name, un]) + . TLetD p1 BX (TCon Ty.pairRef 0 [summer, p2]) + $ TCon Ty.pairRef 0 [offset, p1] + where + (secs, offset, summer, name, un, p2, p1) = fresh + +start'process :: ForeignOp +start'process instr = + ([BX, BX],) + . TAbss [exe, args] + . TLets Direct [hin, hout, herr, hproc] [BX, BX, BX, BX] (TFOp instr [exe, args]) + . TLetD un BX (TCon Ty.unitRef 0 []) + . TLetD p3 BX (TCon Ty.pairRef 0 [hproc, un]) + . TLetD p2 BX (TCon Ty.pairRef 0 [herr, p3]) + . TLetD p1 BX (TCon Ty.pairRef 0 [hout, p2]) + $ TCon Ty.pairRef 0 [hin, p1] + where + (exe, args, hin, hout, herr, hproc, un, p3, p2, p1) = fresh + +set'buffering :: ForeignOp +set'buffering instr = + ([BX, BX],) + . TAbss [handle, bmode] + . TMatch bmode + . MatchDataCover Ty.bufferModeRef + $ mapFromList + [ no'buf --> [] --> k1 no'buf, + line'buf --> [] --> k1 line'buf, + block'buf --> [] --> k1 block'buf, + sblock'buf + --> [BX] + --> TAbs n + . TMatch n + . MatchDataCover Ty.bufferModeRef + $ mapFromList + [ 0 + --> [UN] + --> TAbs w + . TLetD tag UN (TLit (N sblock'buf)) + $ k2 [tag, w] + ] + ] + where + k1 num = + TLetD tag UN (TLit (N num)) $ + k2 [tag] + k2 args = + TLetD r UN (TFOp instr (handle : args)) $ + outIoFailUnit s1 s2 s3 u f r + (handle, bmode, tag, n, w, s1, s2, s3, u, f, r) = fresh + +get'buffering'output :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> v -> v -> ANormal v +get'buffering'output eitherResult stack1 stack2 stack3 resultTag anyVar failVar successVar = + TMatch eitherResult . MatchSum $ + mapFromList + [ failureCase stack1 stack2 stack3 anyVar failVar, + ( 1, + ([UN],) + . TAbs resultTag + . TMatch resultTag + . MatchSum + $ mapFromList + [ no'buf + --> [] + --> TLetD successVar BX (TCon Ty.bufferModeRef no'buf []) + $ right successVar, + line'buf + --> [] + --> TLetD successVar BX (TCon Ty.bufferModeRef line'buf []) + $ right successVar, + block'buf + --> [] + --> TLetD successVar BX (TCon Ty.bufferModeRef block'buf []) + $ right successVar, + sblock'buf + --> [UN] + --> TAbs stack1 + . TLetD successVar BX (TCon Ty.bufferModeRef sblock'buf [stack1]) + $ right successVar + ] + ) + ] + +get'buffering :: ForeignOp +get'buffering = + in1 arg1 eitherResult $ + get'buffering'output eitherResult n n2 n3 resultTag anyVar failVar successVar + where + (arg1, eitherResult, n, n2, n3, resultTag, anyVar, failVar, successVar) = fresh + +crypto'hash :: ForeignOp +crypto'hash instr = + ([BX, BX],) + . TAbss [alg, x] + . TLetD vl BX (TPrm VALU [x]) + $ TFOp instr [alg, vl] + where + (alg, x, vl) = fresh + +murmur'hash :: ForeignOp +murmur'hash instr = + ([BX],) + . TAbss [x] + . TLetD vl BX (TPrm VALU [x]) + $ TFOp instr [vl] + where + (x, vl) = fresh + +crypto'hmac :: ForeignOp +crypto'hmac instr = + ([BX, BX, BX],) + . TAbss [alg, by, x] + . TLetD vl BX (TPrm VALU [x]) + $ TFOp instr [alg, by, vl] + where + (alg, by, x, vl) = fresh + +-- Input Shape -- these represent different argument lists a +-- foreign might expect +-- +-- They are named according to their shape: +-- inUnit : one input arg, unit output +-- in1 : one input arg +-- +-- All of these functions will have take (at least) the same three arguments +-- +-- instr : the foreign instruction to call +-- result : a variable containing the result of the foreign call +-- cont : a term which will be evaluated when a result from the foreign call is on the stack +-- + +-- () -> ... +inUnit :: forall v. (Var v) => v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) +inUnit unit result cont instr = + ([BX], TAbs unit $ TLetD result UN (TFOp instr []) cont) + +inN :: forall v. (Var v) => [v] -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) +inN args result cont instr = + (args $> BX,) + . TAbss args + $ TLetD result UN (TFOp instr args) cont + +-- a -> ... +in1 :: forall v. (Var v) => v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) +in1 arg result cont instr = inN [arg] result cont instr + +-- a -> b -> ... +in2 :: forall v. (Var v) => v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) +in2 arg1 arg2 result cont instr = inN [arg1, arg2] result cont instr + +-- a -> b -> c -> ... +in3 :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) +in3 arg1 arg2 arg3 result cont instr = inN [arg1, arg2, arg3] result cont instr + +-- Maybe a -> b -> ... +inMaybeBx :: forall v. (Var v) => v -> v -> v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) +inMaybeBx arg1 arg2 arg3 mb result cont instr = + ([BX, BX],) + . TAbss [arg1, arg2] + . TMatch arg1 + . flip (MatchData Ty.optionalRef) Nothing + $ mapFromList + [ ( fromIntegral Ty.noneId, + ( [], + TLetD mb UN (TLit $ I 0) $ + TLetD result UN (TFOp instr [mb, arg2]) cont + ) + ), + (fromIntegral Ty.someId, ([BX], TAbs arg3 . TLetD mb UN (TLit $ I 1) $ TLetD result UN (TFOp instr [mb, arg3, arg2]) cont)) + ] + +set'echo :: ForeignOp +set'echo instr = + ([BX, BX],) + . TAbss [arg1, arg2] + . TLetD result UN (TFOp instr [arg1, arg2]) + $ outIoFailUnit stack1 stack2 stack3 unit fail result + where + (arg1, arg2, stack1, stack2, stack3, unit, fail, result) = fresh + +-- a -> IOMode -> ... +inIomr :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) +inIomr arg1 arg2 fm result cont instr = + ([BX, BX],) + . TAbss [arg1, arg2] + . unenum 4 arg2 Ty.fileModeRef fm + $ TLetD result UN (TFOp instr [arg1, fm]) cont + +-- Output Shape -- these will represent different ways of translating +-- the result of a foreign call to a Unison Term +-- +-- They will be named according to the output type +-- outInt : a foreign function returning an Int +-- outBool : a foreign function returning a boolean +-- outIOFail : a function returning (Either Failure a) +-- +-- All of these functions will take a Var named result containing the +-- result of the foreign call +-- + +outMaybe :: forall v. (Var v) => v -> v -> ANormal v +outMaybe tag result = + TMatch tag . MatchSum $ + mapFromList + [ (0, ([], none)), + (1, ([BX], TAbs result $ some result)) + ] + +outMaybeNTup :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v +outMaybeNTup a b u bp p result = + TMatch result . MatchSum $ + mapFromList + [ (0, ([], none)), + ( 1, + ( [UN, BX], + TAbss [a, b] + . TLetD u BX (TCon Ty.unitRef 0 []) + . TLetD bp BX (TCon Ty.pairRef 0 [b, u]) + . TLetD p BX (TCon Ty.pairRef 0 [a, bp]) + $ some p + ) + ) + ] + +outMaybeTup :: (Var v) => v -> v -> v -> v -> v -> v -> ANormal v +outMaybeTup a b u bp ap result = + TMatch result . MatchSum $ + mapFromList + [ (0, ([], none)), + ( 1, + ( [BX, BX], + TAbss [a, b] + . TLetD u BX (TCon Ty.unitRef 0 []) + . TLetD bp BX (TCon Ty.pairRef 0 [b, u]) + . TLetD ap BX (TCon Ty.pairRef 0 [a, bp]) + $ some ap + ) + ) + ] + +-- Note: the Io part doesn't really do anything. There's no actual +-- representation of `IO`. +outIoFail :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v +outIoFail stack1 stack2 stack3 any fail result = + TMatch result . MatchSum $ + mapFromList + [ failureCase stack1 stack2 stack3 any fail, + (1, ([BX], TAbs stack1 $ right stack1)) + ] + +outIoFailChar :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v +outIoFailChar stack1 stack2 stack3 fail extra result = + TMatch result . MatchSum $ + mapFromList + [ failureCase stack1 stack2 stack3 extra fail, + ( 1, + ([UN],) + . TAbs extra + $ right extra + ) + ] + +failureCase :: + (Var v) => v -> v -> v -> v -> v -> (Word64, ([Mem], ANormal v)) +failureCase stack1 stack2 stack3 any fail = + (0,) + . ([BX, BX, BX],) + . TAbss [stack1, stack2, stack3] + . TLetD any BX (TCon Ty.anyRef 0 [stack3]) + . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2, any]) + $ left fail + +exnCase :: + (Var v) => v -> v -> v -> v -> v -> (Word64, ([Mem], ANormal v)) +exnCase stack1 stack2 stack3 any fail = + (0,) + . ([BX, BX, BX],) + . TAbss [stack1, stack2, stack3] + . TLetD any BX (TCon Ty.anyRef 0 [stack3]) + . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2, any]) + $ TReq Ty.exceptionRef 0 [fail] + +outIoExnUnit :: + forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v +outIoExnUnit stack1 stack2 stack3 any fail result = + TMatch result . MatchSum $ + mapFromList + [ exnCase stack1 stack2 stack3 any fail, + (1, ([], TCon Ty.unitRef 0 [])) + ] + +outIoExn :: + (Var v) => v -> v -> v -> v -> v -> v -> ANormal v +outIoExn stack1 stack2 stack3 any fail result = + TMatch result . MatchSum $ + mapFromList + [ exnCase stack1 stack2 stack3 any fail, + (1, ([BX], TAbs stack1 $ TVar stack1)) + ] + +outIoExnEither :: + (Var v) => v -> v -> v -> v -> v -> v -> v -> v -> ANormal v +outIoExnEither stack1 stack2 stack3 any fail t0 t1 res = + TMatch t0 . MatchSum $ + mapFromList + [ exnCase stack1 stack2 stack3 any fail, + ( 1, + ([UN],) + . TAbs t1 + . TMatch t1 + . MatchSum + $ mapFromList + [ (0, ([BX], TAbs res $ left res)), + (1, ([BX], TAbs res $ right res)) + ] + ) + ] + +outIoFailUnit :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v +outIoFailUnit stack1 stack2 stack3 extra fail result = + TMatch result . MatchSum $ + mapFromList + [ failureCase stack1 stack2 stack3 extra fail, + ( 1, + ([],) + . TLetD extra BX (TCon Ty.unitRef 0 []) + $ right extra + ) + ] + +outIoFailBool :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v +outIoFailBool stack1 stack2 stack3 extra fail result = + TMatch result . MatchSum $ + mapFromList + [ failureCase stack1 stack2 stack3 extra fail, + ( 1, + ([UN],) + . TAbs stack3 + $ right stack3 + ) + ] + +outIoFailTup :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> v -> v -> ANormal v +outIoFailTup stack1 stack2 stack3 stack4 stack5 extra fail result = + TMatch result . MatchSum $ + mapFromList + [ failureCase stack1 stack2 stack3 extra fail, + ( 1, + ( [BX, BX], + TAbss [stack1, stack2] + . TLetD stack3 BX (TCon Ty.unitRef 0 []) + . TLetD stack4 BX (TCon Ty.pairRef 0 [stack2, stack3]) + . TLetD stack5 BX (TCon Ty.pairRef 0 [stack1, stack4]) + $ right stack5 + ) + ) + ] + +outIoFailG :: + (Var v) => + v -> + v -> + v -> + v -> + v -> + v -> + ((ANormal v -> ANormal v) -> ([Mem], ANormal v)) -> + ANormal v +outIoFailG stack1 stack2 stack3 fail result output k = + TMatch result . MatchSum $ + mapFromList + [ failureCase stack1 stack2 stack3 output fail, + ( 1, + k $ \t -> + TLetD output BX t $ + right output + ) + ] + +-- Input / Output glue +-- +-- These are pairings of input and output functions to handle a +-- foreign call. The input function represents the numbers and types +-- of the inputs to a foreign call. The output function takes the +-- result of the foreign call and turns it into a Unison type. +-- + +-- a +direct :: ForeignOp +direct instr = ([], TFOp instr []) + +-- () -> r +unitToR :: ForeignOp +unitToR = + inUnit unit result $ TVar result + where + (unit, result) = fresh + +-- () -> Either Failure a +unitToEF :: ForeignOp +unitToEF = + inUnit unit result $ + outIoFail stack1 stack2 stack3 any fail result + where + (unit, stack1, stack2, stack3, fail, any, result) = fresh + +argIomrToEF :: ForeignOp +argIomrToEF = + inIomr arg1 arg2 enum result $ + outIoFail stack1 stack2 stack3 any fail result + where + (arg1, arg2, enum, stack1, stack2, stack3, any, fail, result) = fresh + +-- a -> () +argToUnit :: ForeignOp +argToUnit = in1 arg result (TCon Ty.unitRef 0 []) + where + (arg, result) = fresh + +-- a -> b ->{E} () +arg2To0 :: ForeignOp +arg2To0 instr = + ([BX, BX],) + . TAbss [arg1, arg2] + . TLets Direct [] [] (TFOp instr [arg1, arg2]) + $ TCon Ty.unitRef 0 [] + where + (arg1, arg2) = fresh + +argNDirect :: Int -> ForeignOp +argNDirect n instr = + (replicate n BX,) + . TAbss args + $ TFOp instr args + where + args = freshes n + +-- () -> a +-- +-- Unit is unique in that we don't actually pass it as an arg +unitDirect :: ForeignOp +unitDirect instr = ([BX],) . TAbs arg $ TFOp instr [] where arg = fresh1 + +-- a -> Either Failure b +argToEF :: ForeignOp +argToEF = + in1 arg result $ + outIoFail stack1 stack2 stack3 any fail result + where + (arg, result, stack1, stack2, stack3, any, fail) = fresh + +-- a -> Either Failure (b, c) +argToEFTup :: ForeignOp +argToEFTup = + in1 arg result $ + outIoFailTup stack1 stack2 stack3 stack4 stack5 extra fail result + where + (arg, result, stack1, stack2, stack3, stack4, stack5, extra, fail) = fresh + +-- a -> Either Failure (Maybe b) +argToEFM :: ForeignOp +argToEFM = + in1 arg result + . outIoFailG stack1 stack2 stack3 fail result output + $ \k -> + ( [UN], + TAbs stack3 . TMatch stack3 . MatchSum $ + mapFromList + [ (0, ([], k $ none)), + (1, ([BX], TAbs stack4 . k $ some stack4)) + ] + ) + where + (arg, result, stack1, stack2, stack3, stack4, fail, output) = fresh + +-- a -> Maybe b +argToMaybe :: ForeignOp +argToMaybe = in1 arg tag $ outMaybe tag result + where + (arg, tag, result) = fresh + +-- a -> Maybe (Nat, b) +argToMaybeNTup :: ForeignOp +argToMaybeNTup = + in1 arg result $ outMaybeNTup a b u bp p result + where + (arg, a, b, u, bp, p, result) = fresh + +-- a -> b -> Maybe (c, d) +arg2ToMaybeTup :: ForeignOp +arg2ToMaybeTup = + in2 arg1 arg2 result $ outMaybeTup a b u bp ap result + where + (arg1, arg2, a, b, u, bp, ap, result) = fresh + +-- a -> Either Failure Bool +argToEFBool :: ForeignOp +argToEFBool = + in1 arg result $ + outIoFailBool stack1 stack2 stack3 bool fail result + where + (arg, stack1, stack2, stack3, bool, fail, result) = fresh + +-- a -> Either Failure Char +argToEFChar :: ForeignOp +argToEFChar = + in1 arg result $ + outIoFailChar stack1 stack2 stack3 bool fail result + where + (arg, stack1, stack2, stack3, bool, fail, result) = fresh + +-- a -> b -> Either Failure Bool +arg2ToEFBool :: ForeignOp +arg2ToEFBool = + in2 arg1 arg2 result $ + outIoFailBool stack1 stack2 stack3 bool fail result + where + (arg1, arg2, stack1, stack2, stack3, bool, fail, result) = fresh + +-- a -> b -> c -> Either Failure Bool +arg3ToEFBool :: ForeignOp +arg3ToEFBool = + in3 arg1 arg2 arg3 result $ + outIoFailBool stack1 stack2 stack3 bool fail result + where + (arg1, arg2, arg3, stack1, stack2, stack3, bool, fail, result) = fresh + +-- a -> Either Failure () +argToEF0 :: ForeignOp +argToEF0 = + in1 arg result $ + outIoFailUnit stack1 stack2 stack3 unit fail result + where + (arg, result, stack1, stack2, stack3, unit, fail) = fresh + +-- a -> b -> Either Failure () +arg2ToEF0 :: ForeignOp +arg2ToEF0 = + in2 arg1 arg2 result $ + outIoFailUnit stack1 stack2 stack3 fail unit result + where + (arg1, arg2, result, stack1, stack2, stack3, fail, unit) = fresh + +-- a -> b -> c -> Either Failure () +arg3ToEF0 :: ForeignOp +arg3ToEF0 = + in3 arg1 arg2 arg3 result $ + outIoFailUnit stack1 stack2 stack3 fail unit result + where + (arg1, arg2, arg3, result, stack1, stack2, stack3, fail, unit) = fresh + +-- a -> Either Failure b +argToEFNat :: ForeignOp +argToEFNat = + in1 arg result $ + outIoFail stack1 stack2 stack3 nat fail result + where + (arg, result, stack1, stack2, stack3, nat, fail) = fresh + +-- Maybe a -> b -> Either Failure c +maybeToEF :: ForeignOp +maybeToEF = + inMaybeBx arg1 arg2 arg3 mb result $ + outIoFail stack1 stack2 stack3 any fail result + where + (arg1, arg2, arg3, mb, result, stack1, stack2, stack3, any, fail) = fresh + +-- a -> b -> Either Failure c +arg2ToEF :: ForeignOp +arg2ToEF = + in2 arg1 arg2 result $ + outIoFail stack1 stack2 stack3 any fail result + where + (arg1, arg2, result, stack1, stack2, stack3, any, fail) = fresh + +-- a -> b -> c -> Either Failure d +arg3ToEF :: ForeignOp +arg3ToEF = + in3 arg1 arg2 arg3 result $ + outIoFail stack1 stack2 stack3 any fail result + where + (arg1, arg2, arg3, result, stack1, stack2, stack3, any, fail) = fresh + +-- a -> b ->{Exception} c +arg2ToExn :: ForeignOp +arg2ToExn = + in2 arg1 arg2 result $ + outIoExn stack1 stack2 stack3 any fail result + where + (arg1, arg2, stack1, stack2, stack3, any, fail, result) = fresh + +-- a -> b -> c ->{Exception} () +arg3ToExnUnit :: ForeignOp +arg3ToExnUnit = + in3 arg1 arg2 arg3 result $ + outIoExnUnit stack1 stack2 stack3 any fail result + where + (arg1, arg2, arg3, stack1, stack2, stack3, any, fail, result) = fresh + +-- a -> Nat -> Nat ->{Exception} b +arg3ToExn :: ForeignOp +arg3ToExn = + in3 arg1 arg2 arg3 result $ + outIoExn stack1 stack2 stack3 any fail result + where + (arg1, arg2, arg3, result, stack1, stack2, stack3, any, fail) = fresh + +-- a -> Nat -> b -> Nat -> Nat ->{Exception} () +arg5ToExnUnit :: ForeignOp +arg5ToExnUnit instr = + ([BX, BX, BX, BX, BX],) + . TAbss [a0, ua1, a2, ua3, ua4] + . TLetD result UN (TFOp instr [a0, ua1, a2, ua3, ua4]) + $ outIoExnUnit stack1 stack2 stack3 any fail result + where + (a0, a2, ua1, ua3, ua4, result, stack1, stack2, stack3, any, fail) = fresh + +-- a ->{Exception} Either b c +argToExnE :: ForeignOp +argToExnE instr = + ([BX],) + . TAbs a + . TLetD t0 UN (TFOp instr [a]) + $ outIoExnEither stack1 stack2 stack3 any fail t0 t1 result + where + (a, stack1, stack2, stack3, any, fail, t0, t1, result) = fresh + +-- Nat -> Either Failure () +argToEFUnit :: ForeignOp +argToEFUnit = + in1 nat result + . TMatch result + . MatchSum + $ mapFromList + [ failureCase stack1 stack2 stack3 unit fail, + ( 1, + ([],) + . TLetD unit BX (TCon Ty.unitRef 0 []) + $ right unit + ) + ] + where + (nat, result, fail, stack1, stack2, stack3, unit) = fresh + +-- a -> Either b c +argToEither :: ForeignOp +argToEither instr = + ([BX],) + . TAbss [b] + . TLetD e UN (TFOp instr [b]) + . TMatch e + . MatchSum + $ mapFromList + [ (0, ([BX], TAbs ev $ left ev)), + (1, ([BX], TAbs ev $ right ev)) + ] + where + (e, b, ev) = fresh + +builtinLookup :: Map.Map Reference (Sandbox, SuperNormal Symbol) +builtinLookup = + Map.fromList + . map (\(t, f) -> (Builtin t, f)) + $ [ ("Int.+", (Untracked, addi)), + ("Int.-", (Untracked, subi)), + ("Int.*", (Untracked, muli)), + ("Int./", (Untracked, divi)), + ("Int.mod", (Untracked, modi)), + ("Int.==", (Untracked, eqi)), + ("Int.<", (Untracked, lti)), + ("Int.<=", (Untracked, lei)), + ("Int.>", (Untracked, gti)), + ("Int.>=", (Untracked, gei)), + ("Int.fromRepresentation", (Untracked, coerceType IntTag)), + ("Int.toRepresentation", (Untracked, coerceType NatTag)), + ("Int.increment", (Untracked, inci)), + ("Int.signum", (Untracked, sgni)), + ("Int.negate", (Untracked, negi)), + ("Int.truncate0", (Untracked, trni)), + ("Int.isEven", (Untracked, evni)), + ("Int.isOdd", (Untracked, oddi)), + ("Int.shiftLeft", (Untracked, shli)), + ("Int.shiftRight", (Untracked, shri)), + ("Int.trailingZeros", (Untracked, tzeroi)), + ("Int.leadingZeros", (Untracked, lzeroi)), + ("Int.and", (Untracked, andi)), + ("Int.or", (Untracked, ori)), + ("Int.xor", (Untracked, xori)), + ("Int.complement", (Untracked, compli)), + ("Int.pow", (Untracked, powi)), + ("Int.toText", (Untracked, i2t)), + ("Int.fromText", (Untracked, t2i)), + ("Int.toFloat", (Untracked, i2f)), + ("Int.popCount", (Untracked, popi)), + ("Nat.+", (Untracked, addn)), + ("Nat.-", (Untracked, subn)), + ("Nat.sub", (Untracked, subn)), + ("Nat.*", (Untracked, muln)), + ("Nat./", (Untracked, divn)), + ("Nat.mod", (Untracked, modn)), + ("Nat.==", (Untracked, eqn)), + ("Nat.<", (Untracked, ltn)), + ("Nat.<=", (Untracked, len)), + ("Nat.>", (Untracked, gtn)), + ("Nat.>=", (Untracked, gen)), + ("Nat.increment", (Untracked, incn)), + ("Nat.isEven", (Untracked, evnn)), + ("Nat.isOdd", (Untracked, oddn)), + ("Nat.shiftLeft", (Untracked, shln)), + ("Nat.shiftRight", (Untracked, shrn)), + ("Nat.trailingZeros", (Untracked, tzeron)), + ("Nat.leadingZeros", (Untracked, lzeron)), + ("Nat.and", (Untracked, andn)), + ("Nat.or", (Untracked, orn)), + ("Nat.xor", (Untracked, xorn)), + ("Nat.complement", (Untracked, compln)), + ("Nat.pow", (Untracked, pown)), + ("Nat.drop", (Untracked, dropn)), + ("Nat.toInt", (Untracked, coerceType IntTag)), + ("Nat.toFloat", (Untracked, n2f)), + ("Nat.toText", (Untracked, n2t)), + ("Nat.fromText", (Untracked, t2n)), + ("Nat.popCount", (Untracked, popn)), + ("Float.+", (Untracked, addf)), + ("Float.-", (Untracked, subf)), + ("Float.*", (Untracked, mulf)), + ("Float./", (Untracked, divf)), + ("Float.pow", (Untracked, powf)), + ("Float.log", (Untracked, logf)), + ("Float.logBase", (Untracked, logbf)), + ("Float.sqrt", (Untracked, sqrtf)), + ("Float.fromRepresentation", (Untracked, coerceType FloatTag)), + ("Float.toRepresentation", (Untracked, coerceType NatTag)), + ("Float.min", (Untracked, minf)), + ("Float.max", (Untracked, maxf)), + ("Float.<", (Untracked, ltf)), + ("Float.>", (Untracked, gtf)), + ("Float.<=", (Untracked, lef)), + ("Float.>=", (Untracked, gef)), + ("Float.==", (Untracked, eqf)), + ("Float.!=", (Untracked, neqf)), + ("Float.acos", (Untracked, acosf)), + ("Float.asin", (Untracked, asinf)), + ("Float.atan", (Untracked, atanf)), + ("Float.cos", (Untracked, cosf)), + ("Float.sin", (Untracked, sinf)), + ("Float.tan", (Untracked, tanf)), + ("Float.acosh", (Untracked, acoshf)), + ("Float.asinh", (Untracked, asinhf)), + ("Float.atanh", (Untracked, atanhf)), + ("Float.cosh", (Untracked, coshf)), + ("Float.sinh", (Untracked, sinhf)), + ("Float.tanh", (Untracked, tanhf)), + ("Float.exp", (Untracked, expf)), + ("Float.abs", (Untracked, absf)), + ("Float.ceiling", (Untracked, ceilf)), + ("Float.floor", (Untracked, floorf)), + ("Float.round", (Untracked, roundf)), + ("Float.truncate", (Untracked, truncf)), + ("Float.atan2", (Untracked, atan2f)), + ("Float.toText", (Untracked, f2t)), + ("Float.fromText", (Untracked, t2f)), + -- text + ("Text.empty", (Untracked, Lambda [] $ TLit (T ""))), + ("Text.++", (Untracked, appendt)), + ("Text.take", (Untracked, taket)), + ("Text.drop", (Untracked, dropt)), + ("Text.indexOf", (Untracked, indext)), + ("Text.size", (Untracked, sizet)), + ("Text.==", (Untracked, eqt)), + ("Text.!=", (Untracked, neqt)), + ("Text.<=", (Untracked, leqt)), + ("Text.>=", (Untracked, geqt)), + ("Text.<", (Untracked, lesst)), + ("Text.>", (Untracked, great)), + ("Text.uncons", (Untracked, unconst)), + ("Text.unsnoc", (Untracked, unsnoct)), + ("Text.toCharList", (Untracked, unpackt)), + ("Text.fromCharList", (Untracked, packt)), + ("Boolean.not", (Untracked, notb)), + ("Boolean.or", (Untracked, orb)), + ("Boolean.and", (Untracked, andb)), + ("bug", (Untracked, bug "builtin.bug")), + ("todo", (Untracked, bug "builtin.todo")), + ("Debug.watch", (Tracked, watch)), + ("Debug.trace", (Tracked, gen'trace)), + ("Debug.toText", (Tracked, debug'text)), + ("unsafe.coerceAbilities", (Untracked, poly'coerce)), + ("Char.toNat", (Untracked, coerceType NatTag)), + ("Char.fromNat", (Untracked, coerceType CharTag)), + ("Bytes.empty", (Untracked, emptyb)), + ("Bytes.fromList", (Untracked, packb)), + ("Bytes.toList", (Untracked, unpackb)), + ("Bytes.++", (Untracked, appendb)), + ("Bytes.take", (Untracked, takeb)), + ("Bytes.drop", (Untracked, dropb)), + ("Bytes.at", (Untracked, atb)), + ("Bytes.indexOf", (Untracked, indexb)), + ("Bytes.size", (Untracked, sizeb)), + ("Bytes.flatten", (Untracked, flattenb)), + ("List.take", (Untracked, takes)), + ("List.drop", (Untracked, drops)), + ("List.size", (Untracked, sizes)), + ("List.++", (Untracked, appends)), + ("List.at", (Untracked, ats)), + ("List.cons", (Untracked, conss)), + ("List.snoc", (Untracked, snocs)), + ("List.empty", (Untracked, emptys)), + ("List.viewl", (Untracked, viewls)), + ("List.viewr", (Untracked, viewrs)), + ("List.splitLeft", (Untracked, splitls)), + ("List.splitRight", (Untracked, splitrs)), + -- + -- , B "Debug.watch" $ forall1 "a" (\a -> text --> a --> a) + ("Universal.==", (Untracked, equ)), + ("Universal.compare", (Untracked, cmpu)), + ("Universal.>", (Untracked, gtu)), + ("Universal.<", (Untracked, ltu)), + ("Universal.>=", (Untracked, geu)), + ("Universal.<=", (Untracked, leu)), + -- internal stuff + ("jumpCont", (Untracked, jumpk)), + ("raise", (Untracked, raise)), + ("IO.forkComp.v2", (Tracked, fork'comp)), + ("Scope.run", (Untracked, scope'run)), + ("Code.isMissing", (Tracked, code'missing)), + ("Code.cache_", (Tracked, code'cache)), + ("Code.lookup", (Tracked, code'lookup)), + ("Code.validate", (Tracked, code'validate)), + ("Value.load", (Tracked, value'load)), + ("Value.value", (Tracked, value'create)), + ("Any.Any", (Untracked, any'construct)), + ("Any.unsafeExtract", (Untracked, any'extract)), + ("Link.Term.toText", (Untracked, term'link'to'text)), + ("STM.atomically", (Tracked, stm'atomic)), + ("validateSandboxed", (Untracked, check'sandbox)), + ("Value.validateSandboxed", (Tracked, value'sandbox)), + ("sandboxLinks", (Tracked, sandbox'links)), + ("IO.tryEval", (Tracked, try'eval)), + ("Ref.read", (Untracked, ref'read)), + ("Ref.write", (Untracked, ref'write)), + ("Ref.cas", (Tracked, ref'cas)), + ("Ref.Ticket.read", (Tracked, ref'ticket'read)), + ("Ref.readForCas", (Tracked, ref'readForCas)), + ("Scope.ref", (Untracked, ref'new)), + ("IO.ref", (Tracked, ref'new)) + ] + ++ foreignWrappers + +type FDecl v = State (Map ForeignFunc (Sandbox, SuperNormal v)) + +-- Data type to determine whether a builtin should be tracked for +-- sandboxing. Untracked means that it can be freely used, and Tracked +-- means that the sandboxing check will by default consider them +-- disallowed. +data Sandbox = Tracked | Untracked + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +declareForeign :: + Sandbox -> + ForeignOp -> + ForeignFunc -> + FDecl Symbol () +declareForeign sand op func = do + modify $ \funcs -> + let code = uncurry Lambda (op func) + in (Map.insert func (sand, code) funcs) + +unitValue :: Val +unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) + +natValue :: Word64 -> Val +natValue w = NatVal w + +declareUdpForeigns :: FDecl Symbol () +declareUdpForeigns = do + declareForeign Tracked arg2ToEF IO_UDP_clientSocket_impl_v1 + + declareForeign Tracked argToEF IO_UDP_UDPSocket_recv_impl_v1 + + declareForeign Tracked arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 + declareForeign Tracked argToEF0 IO_UDP_UDPSocket_close_impl_v1 + + declareForeign Tracked argToEF0 IO_UDP_ListenSocket_close_impl_v1 + + declareForeign Tracked (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 + + declareForeign Tracked arg2ToEF IO_UDP_serverSocket_impl_v1 + + declareForeign Tracked (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 + + declareForeign Tracked argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 + + declareForeign Tracked (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 + + declareForeign Tracked arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 + +declareForeigns :: FDecl Symbol () +declareForeigns = do + declareUdpForeigns + declareForeign Tracked argIomrToEF IO_openFile_impl_v3 + + declareForeign Tracked argToEF0 IO_closeFile_impl_v3 + declareForeign Tracked argToEFBool IO_isFileEOF_impl_v3 + declareForeign Tracked argToEFBool IO_isFileOpen_impl_v3 + declareForeign Tracked argToEFBool IO_getEcho_impl_v1 + declareForeign Tracked argToEFBool IO_ready_impl_v1 + declareForeign Tracked argToEFChar IO_getChar_impl_v1 + declareForeign Tracked argToEFBool IO_isSeekable_impl_v3 + + declareForeign Tracked seek'handle IO_seekHandle_impl_v3 + + declareForeign Tracked argToEFNat IO_handlePosition_impl_v3 + + declareForeign Tracked get'buffering IO_getBuffering_impl_v3 + + declareForeign Tracked set'buffering IO_setBuffering_impl_v3 + + declareForeign Tracked set'echo IO_setEcho_impl_v1 + + declareForeign Tracked argToEF IO_getLine_impl_v1 + + declareForeign Tracked arg2ToEF IO_getBytes_impl_v3 + declareForeign Tracked arg2ToEF IO_getSomeBytes_impl_v1 + declareForeign Tracked arg2ToEF0 IO_putBytes_impl_v3 + declareForeign Tracked unitToEF IO_systemTime_impl_v3 + + declareForeign Tracked unitToR IO_systemTimeMicroseconds_v1 + + declareForeign Tracked unitToEF Clock_internals_monotonic_v1 + + declareForeign Tracked unitToEF Clock_internals_realtime_v1 + + declareForeign Tracked unitToEF Clock_internals_processCPUTime_v1 + + declareForeign Tracked unitToEF Clock_internals_threadCPUTime_v1 + + declareForeign Tracked (argNDirect 1) Clock_internals_sec_v1 + + -- A TimeSpec that comes from getTime never has negative nanos, + -- so we can safely cast to Nat + declareForeign Tracked (argNDirect 1) Clock_internals_nsec_v1 + + declareForeign Tracked time'zone Clock_internals_systemTimeZone_v1 + + declareForeign Tracked unitToEF IO_getTempDirectory_impl_v3 + + declareForeign Tracked argToEF IO_createTempDirectory_impl_v3 + + declareForeign Tracked unitToEF IO_getCurrentDirectory_impl_v3 + + declareForeign Tracked argToEF0 IO_setCurrentDirectory_impl_v3 + + declareForeign Tracked argToEFBool IO_fileExists_impl_v3 + + declareForeign Tracked argToEF IO_getEnv_impl_v1 + + declareForeign Tracked unitToEF IO_getArgs_impl_v1 + + declareForeign Tracked argToEFBool IO_isDirectory_impl_v3 + + declareForeign Tracked argToEF0 IO_createDirectory_impl_v3 + + declareForeign Tracked argToEF0 IO_removeDirectory_impl_v3 + + declareForeign Tracked arg2ToEF0 IO_renameDirectory_impl_v3 + + declareForeign Tracked argToEF IO_directoryContents_impl_v3 + + declareForeign Tracked argToEF0 IO_removeFile_impl_v3 + + declareForeign Tracked arg2ToEF0 IO_renameFile_impl_v3 + + declareForeign Tracked argToEFNat IO_getFileTimestamp_impl_v3 + + declareForeign Tracked argToEFNat IO_getFileSize_impl_v3 + + declareForeign Tracked maybeToEF IO_serverSocket_impl_v3 + + declareForeign Tracked (argNDirect 1) Socket_toText + + declareForeign Tracked (argNDirect 1) Handle_toText + + declareForeign Tracked (argNDirect 1) ThreadId_toText + + declareForeign Tracked argToEFNat IO_socketPort_impl_v3 + + declareForeign Tracked argToEF0 IO_listen_impl_v3 + + declareForeign Tracked arg2ToEF IO_clientSocket_impl_v3 + + declareForeign Tracked argToEF0 IO_closeSocket_impl_v3 + + declareForeign Tracked argToEF IO_socketAccept_impl_v3 + + declareForeign Tracked arg2ToEF0 IO_socketSend_impl_v3 + + declareForeign Tracked arg2ToEF IO_socketReceive_impl_v3 + + declareForeign Tracked argToEF0 IO_kill_impl_v3 + + declareForeign Tracked argToEFUnit IO_delay_impl_v3 + + declareForeign Tracked standard'handle IO_stdHandle + + declareForeign Tracked (argNDirect 2) IO_process_call + + declareForeign Tracked start'process IO_process_start + + declareForeign Tracked argToUnit IO_process_kill + + declareForeign Tracked (argNDirect 1) IO_process_wait + + declareForeign Tracked argToMaybe IO_process_exitCode + declareForeign Tracked (argNDirect 1) MVar_new + + declareForeign Tracked unitDirect MVar_newEmpty_v2 + + declareForeign Tracked argToEF MVar_take_impl_v3 + + declareForeign Tracked argToMaybe MVar_tryTake + + declareForeign Tracked arg2ToEF0 MVar_put_impl_v3 + + declareForeign Tracked arg2ToEFBool MVar_tryPut_impl_v3 + + declareForeign Tracked arg2ToEF MVar_swap_impl_v3 + + declareForeign Tracked (argNDirect 1) MVar_isEmpty + + declareForeign Tracked argToEF MVar_read_impl_v3 + + declareForeign Tracked argToEFM MVar_tryRead_impl_v3 + + declareForeign Untracked (argNDirect 1) Char_toText + declareForeign Untracked (argNDirect 2) Text_repeat + declareForeign Untracked (argNDirect 1) Text_reverse + declareForeign Untracked (argNDirect 1) Text_toUppercase + declareForeign Untracked (argNDirect 1) Text_toLowercase + declareForeign Untracked (argNDirect 1) Text_toUtf8 + declareForeign Untracked argToEF Text_fromUtf8_impl_v3 + declareForeign Tracked (argNDirect 2) Tls_ClientConfig_default + declareForeign Tracked (argNDirect 2) Tls_ServerConfig_default + declareForeign Tracked (argNDirect 2) Tls_ClientConfig_certificates_set + + declareForeign Tracked (argNDirect 2) Tls_ServerConfig_certificates_set + + declareForeign Tracked (argNDirect 1) TVar_new + + declareForeign Tracked (argNDirect 1) TVar_read + declareForeign Tracked arg2To0 TVar_write + declareForeign Tracked (argNDirect 1) TVar_newIO + + declareForeign Tracked (argNDirect 1) TVar_readIO + declareForeign Tracked (argNDirect 2) TVar_swap + declareForeign Tracked unitDirect STM_retry + declareForeign Tracked unitDirect Promise_new + -- the only exceptions from Promise.read are async and shouldn't be caught + declareForeign Tracked (argNDirect 1) Promise_read + declareForeign Tracked argToMaybe Promise_tryRead + + declareForeign Tracked (argNDirect 2) Promise_write + declareForeign Tracked arg2ToEF Tls_newClient_impl_v3 + declareForeign Tracked arg2ToEF Tls_newServer_impl_v3 + declareForeign Tracked argToEF0 Tls_handshake_impl_v3 + declareForeign Tracked arg2ToEF0 Tls_send_impl_v3 + declareForeign Tracked argToEF Tls_decodeCert_impl_v3 + + declareForeign Tracked (argNDirect 1) Tls_encodeCert + + declareForeign Tracked (argNDirect 1) Tls_decodePrivateKey + declareForeign Tracked (argNDirect 1) Tls_encodePrivateKey + + declareForeign Tracked argToEF Tls_receive_impl_v3 + + declareForeign Tracked argToEF0 Tls_terminate_impl_v3 + declareForeign Untracked argToExnE Code_validateLinks + declareForeign Untracked (argNDirect 1) Code_dependencies + declareForeign Untracked (argNDirect 1) Code_serialize + declareForeign Untracked argToEither Code_deserialize + declareForeign Untracked (argNDirect 2) Code_display + declareForeign Untracked (argNDirect 1) Value_dependencies + declareForeign Untracked (argNDirect 1) Value_serialize + declareForeign Untracked argToEither Value_deserialize + -- Hashing functions + declareForeign Untracked direct Crypto_HashAlgorithm_Sha3_512 + declareForeign Untracked direct Crypto_HashAlgorithm_Sha3_256 + declareForeign Untracked direct Crypto_HashAlgorithm_Sha2_512 + declareForeign Untracked direct Crypto_HashAlgorithm_Sha2_256 + declareForeign Untracked direct Crypto_HashAlgorithm_Sha1 + declareForeign Untracked direct Crypto_HashAlgorithm_Blake2b_512 + declareForeign Untracked direct Crypto_HashAlgorithm_Blake2b_256 + declareForeign Untracked direct Crypto_HashAlgorithm_Blake2s_256 + declareForeign Untracked direct Crypto_HashAlgorithm_Md5 + + declareForeign Untracked (argNDirect 2) Crypto_hashBytes + declareForeign Untracked (argNDirect 3) Crypto_hmacBytes + + declareForeign Untracked crypto'hash Crypto_hash + declareForeign Untracked crypto'hmac Crypto_hmac + declareForeign Untracked arg3ToEF Crypto_Ed25519_sign_impl + + declareForeign Untracked arg3ToEFBool Crypto_Ed25519_verify_impl + + declareForeign Untracked arg2ToEF Crypto_Rsa_sign_impl + + declareForeign Untracked arg3ToEFBool Crypto_Rsa_verify_impl + + declareForeign Untracked murmur'hash Universal_murmurHash + declareForeign Tracked (argNDirect 1) IO_randomBytes + declareForeign Untracked (argNDirect 1) Bytes_zlib_compress + declareForeign Untracked (argNDirect 1) Bytes_gzip_compress + declareForeign Untracked argToEither Bytes_zlib_decompress + declareForeign Untracked argToEither Bytes_gzip_decompress + + declareForeign Untracked (argNDirect 1) Bytes_toBase16 + declareForeign Untracked (argNDirect 1) Bytes_toBase32 + declareForeign Untracked (argNDirect 1) Bytes_toBase64 + declareForeign Untracked (argNDirect 1) Bytes_toBase64UrlUnpadded + + declareForeign Untracked argToEither Bytes_fromBase16 + declareForeign Untracked argToEither Bytes_fromBase32 + declareForeign Untracked argToEither Bytes_fromBase64 + declareForeign Untracked argToEither Bytes_fromBase64UrlUnpadded + + declareForeign Untracked argToMaybeNTup Bytes_decodeNat64be + declareForeign Untracked argToMaybeNTup Bytes_decodeNat64le + declareForeign Untracked argToMaybeNTup Bytes_decodeNat32be + declareForeign Untracked argToMaybeNTup Bytes_decodeNat32le + declareForeign Untracked argToMaybeNTup Bytes_decodeNat16be + declareForeign Untracked argToMaybeNTup Bytes_decodeNat16le + + declareForeign Untracked (argNDirect 1) Bytes_encodeNat64be + declareForeign Untracked (argNDirect 1) Bytes_encodeNat64le + declareForeign Untracked (argNDirect 1) Bytes_encodeNat32be + declareForeign Untracked (argNDirect 1) Bytes_encodeNat32le + declareForeign Untracked (argNDirect 1) Bytes_encodeNat16be + declareForeign Untracked (argNDirect 1) Bytes_encodeNat16le + + declareForeign Untracked arg5ToExnUnit MutableArray_copyTo_force + + declareForeign Untracked arg5ToExnUnit MutableByteArray_copyTo_force + + declareForeign Untracked arg5ToExnUnit ImmutableArray_copyTo_force + + declareForeign Untracked (argNDirect 1) ImmutableArray_size + declareForeign Untracked (argNDirect 1) MutableArray_size + declareForeign Untracked (argNDirect 1) ImmutableByteArray_size + declareForeign Untracked (argNDirect 1) MutableByteArray_size + + declareForeign Untracked arg5ToExnUnit ImmutableByteArray_copyTo_force + + declareForeign Untracked arg2ToExn MutableArray_read + declareForeign Untracked arg2ToExn MutableByteArray_read8 + declareForeign Untracked arg2ToExn MutableByteArray_read16be + declareForeign Untracked arg2ToExn MutableByteArray_read24be + declareForeign Untracked arg2ToExn MutableByteArray_read32be + declareForeign Untracked arg2ToExn MutableByteArray_read40be + declareForeign Untracked arg2ToExn MutableByteArray_read64be + + declareForeign Untracked arg3ToExnUnit MutableArray_write + declareForeign Untracked arg3ToExnUnit MutableByteArray_write8 + declareForeign Untracked arg3ToExnUnit MutableByteArray_write16be + declareForeign Untracked arg3ToExnUnit MutableByteArray_write32be + declareForeign Untracked arg3ToExnUnit MutableByteArray_write64be + + declareForeign Untracked arg2ToExn ImmutableArray_read + declareForeign Untracked arg2ToExn ImmutableByteArray_read8 + declareForeign Untracked arg2ToExn ImmutableByteArray_read16be + declareForeign Untracked arg2ToExn ImmutableByteArray_read24be + declareForeign Untracked arg2ToExn ImmutableByteArray_read32be + declareForeign Untracked arg2ToExn ImmutableByteArray_read40be + declareForeign Untracked arg2ToExn ImmutableByteArray_read64be + + declareForeign Untracked (argNDirect 1) MutableByteArray_freeze_force + declareForeign Untracked (argNDirect 1) MutableArray_freeze_force + + declareForeign Untracked arg3ToExn MutableByteArray_freeze + declareForeign Untracked arg3ToExn MutableArray_freeze + + declareForeign Untracked (argNDirect 1) MutableByteArray_length + + declareForeign Untracked (argNDirect 1) ImmutableByteArray_length + + declareForeign Tracked (argNDirect 1) IO_array + declareForeign Tracked (argNDirect 2) IO_arrayOf + declareForeign Tracked (argNDirect 1) IO_bytearray + declareForeign Tracked (argNDirect 2) IO_bytearrayOf + + declareForeign Untracked (argNDirect 1) Scope_array + declareForeign Untracked (argNDirect 2) Scope_arrayOf + declareForeign Untracked (argNDirect 1) Scope_bytearray + declareForeign Untracked (argNDirect 2) Scope_bytearrayOf + + declareForeign Untracked (argNDirect 1) Text_patterns_literal + declareForeign Untracked direct Text_patterns_digit + declareForeign Untracked direct Text_patterns_letter + declareForeign Untracked direct Text_patterns_space + declareForeign Untracked direct Text_patterns_punctuation + declareForeign Untracked direct Text_patterns_anyChar + declareForeign Untracked direct Text_patterns_eof + declareForeign Untracked (argNDirect 2) Text_patterns_charRange + declareForeign Untracked (argNDirect 2) Text_patterns_notCharRange + declareForeign Untracked (argNDirect 1) Text_patterns_charIn + declareForeign Untracked (argNDirect 1) Text_patterns_notCharIn + declareForeign Untracked (argNDirect 1) Pattern_many + declareForeign Untracked (argNDirect 1) Pattern_many_corrected + declareForeign Untracked (argNDirect 1) Pattern_capture + declareForeign Untracked (argNDirect 2) Pattern_captureAs + declareForeign Untracked (argNDirect 1) Pattern_join + declareForeign Untracked (argNDirect 2) Pattern_or + declareForeign Untracked (argNDirect 3) Pattern_replicate + + declareForeign Untracked arg2ToMaybeTup Pattern_run + + declareForeign Untracked (argNDirect 2) Pattern_isMatch + + declareForeign Untracked direct Char_Class_any + declareForeign Untracked (argNDirect 1) Char_Class_not + declareForeign Untracked (argNDirect 2) Char_Class_and + declareForeign Untracked (argNDirect 2) Char_Class_or + declareForeign Untracked (argNDirect 2) Char_Class_range + declareForeign Untracked (argNDirect 1) Char_Class_anyOf + declareForeign Untracked direct Char_Class_alphanumeric + declareForeign Untracked direct Char_Class_upper + declareForeign Untracked direct Char_Class_lower + declareForeign Untracked direct Char_Class_whitespace + declareForeign Untracked direct Char_Class_control + declareForeign Untracked direct Char_Class_printable + declareForeign Untracked direct Char_Class_mark + declareForeign Untracked direct Char_Class_number + declareForeign Untracked direct Char_Class_punctuation + declareForeign Untracked direct Char_Class_symbol + declareForeign Untracked direct Char_Class_separator + declareForeign Untracked direct Char_Class_letter + declareForeign Untracked (argNDirect 2) Char_Class_is + declareForeign Untracked (argNDirect 1) Text_patterns_char + +foreignDeclResults :: (Map ForeignFunc (Sandbox, SuperNormal Symbol)) +foreignDeclResults = + execState declareForeigns mempty + +foreignWrappers :: [(Data.Text.Text, (Sandbox, SuperNormal Symbol))] +foreignWrappers = + Map.toList foreignDeclResults + <&> \(ff, (sand, code)) -> (foreignFuncBuiltinName ff, (sand, code)) + +numberedTermLookup :: EnumMap Word64 (SuperNormal Symbol) +numberedTermLookup = + mapFromList . zip [1 ..] . Map.elems . fmap snd $ builtinLookup + +builtinTermNumbering :: Map Reference Word64 +builtinTermNumbering = + Map.fromList (zip (Map.keys $ builtinLookup) [1 ..]) + +builtinTermBackref :: EnumMap Word64 Reference +builtinTermBackref = + mapFromList . zip [1 ..] . Map.keys $ builtinLookup + +builtinForeignNames :: Map ForeignFunc Data.Text.Text +builtinForeignNames = + foreignDeclResults + & Map.keys + & map (\f -> (f, foreignFuncBuiltinName f)) + & Map.fromList + +-- Bootstrapping for sandbox check. The eventual map will be one with +-- associations `r -> s` where `s` is all the 'sensitive' base +-- functions that `r` calls. +baseSandboxInfo :: Map Reference (Set Reference) +baseSandboxInfo = + Map.fromList $ + [ (r, Set.singleton r) + | (r, (sb, _)) <- Map.toList builtinLookup, + sb == Tracked + ] + +builtinArities :: Map Reference Int +builtinArities = + Map.fromList $ + [(r, arity s) | (r, (_, s)) <- Map.toList builtinLookup] + +builtinInlineInfo :: Map Reference (Int, ANormal Symbol) +builtinInlineInfo = + ANF.buildInlineMap $ fmap (Rec [] . snd) builtinLookup + +sandboxedForeignFuncs :: Set ForeignFunc +sandboxedForeignFuncs = + Map.keysSet $ + Map.filter (\(sb, _) -> sb == Tracked) foreignDeclResults diff --git a/unison-runtime/src/Unison/Runtime/Builtin/Types.hs b/unison-runtime/src/Unison/Runtime/Builtin/Types.hs new file mode 100644 index 0000000000..fe82680dae --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Builtin/Types.hs @@ -0,0 +1,29 @@ +module Unison.Runtime.Builtin.Types + ( typeReferences, + builtinTypeNumbering, + builtinTypeBackref, + ) +where + +import Data.Map qualified as Map +import Unison.Builtin qualified as Ty (builtinTypes) +import Unison.Builtin.Decls qualified as Ty +import Unison.Prelude hiding (Text, some) +import Unison.Reference +import Unison.Util.EnumContainers as EC + +builtinTypeNumbering :: Map Reference Word64 +builtinTypeNumbering = Map.fromList typeReferences + +typeReferences :: [(Reference, Word64)] +typeReferences = zip rs [1 ..] + where + rs = + [r | (_, r) <- Ty.builtinTypes] + ++ [DerivedId i | (_, i, _) <- Ty.builtinDataDecls] + ++ [DerivedId i | (_, i, _) <- Ty.builtinEffectDecls] + +builtinTypeBackref :: EnumMap Word64 Reference +builtinTypeBackref = mapFromList $ swap <$> typeReferences + where + swap (x, y) = (y, x) diff --git a/parser-typechecker/src/Unison/Runtime/Crypto/Rsa.hs b/unison-runtime/src/Unison/Runtime/Crypto/Rsa.hs similarity index 100% rename from parser-typechecker/src/Unison/Runtime/Crypto/Rsa.hs rename to unison-runtime/src/Unison/Runtime/Crypto/Rsa.hs diff --git a/parser-typechecker/src/Unison/Runtime/Debug.hs b/unison-runtime/src/Unison/Runtime/Debug.hs similarity index 92% rename from parser-typechecker/src/Unison/Runtime/Debug.hs rename to unison-runtime/src/Unison/Runtime/Debug.hs index cc47c54bc8..e162fa32e4 100644 --- a/parser-typechecker/src/Unison/Runtime/Debug.hs +++ b/unison-runtime/src/Unison/Runtime/Debug.hs @@ -20,7 +20,7 @@ import Unison.Var (Var) type Term v = Tm.Term v () -traceComb :: Bool -> Word64 -> Comb -> Bool +traceComb :: (Show clos, Show comb) => Bool -> Word64 -> GComb clos comb -> Bool traceComb False _ _ = True traceComb True w c = trace (prettyComb w 0 c "\n") True diff --git a/unison-runtime/src/Unison/Runtime/Decompile.hs b/unison-runtime/src/Unison/Runtime/Decompile.hs new file mode 100644 index 0000000000..b650f450c9 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Decompile.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Runtime.Decompile + ( decompile, + DecompResult, + DecompError (..), + renderDecompError, + ) +where + +import Data.Set (singleton) +import Unison.ABT (substs) +import Unison.Codebase.Runtime (Error) +import Unison.ConstructorReference (GConstructorReference (..)) +import Unison.Prelude +import Unison.Reference (Reference, pattern Builtin) +import Unison.Referent (pattern Ref) +import Unison.Runtime.ANF (maskTags) +import Unison.Runtime.Array + ( Array, + ByteArray, + byteArrayToList, + ) +import Unison.Runtime.Foreign + ( Foreign (..), + HashAlgorithm (..), + maybeUnwrapBuiltin, + maybeUnwrapForeign, + ) +import Unison.Runtime.IOSource (iarrayFromListRef, ibarrayFromBytesRef) +import Unison.Runtime.MCode (CombIx (..)) +import Unison.Runtime.Stack + ( Closure (..), + USeq, + UnboxedTypeTag (..), + Val (..), + pattern DataC, + pattern PApV, + ) +import Unison.Syntax.NamePrinter (prettyReference) +import Unison.Term + ( Term, + app, + apps', + boolean, + builtin, + char, + constructor, + float, + int, + list, + list', + nat, + ref, + termLink, + text, + typeLink, + pattern LamNamed', + ) +import Unison.Term qualified as Term +import Unison.Type + ( anyRef, + booleanRef, + iarrayRef, + ibytearrayRef, + listRef, + termLinkRef, + typeLinkRef, + ) +import Unison.Util.Bytes qualified as By +import Unison.Util.Pretty (indentN, lines, lit, shown, syntaxToColor, wrap) +import Unison.Util.Text qualified as Text +import Unison.Var (Var) +import Prelude hiding (lines) + +con :: (Var v) => Reference -> Word64 -> Term v () +con rf ct = constructor () (ConstructorReference rf $ fromIntegral ct) + +bug :: (Var v) => Text -> Term v () +bug msg = app () (builtin () "bug") (text () msg) + +err :: DecompError -> a -> (Set DecompError, a) +err err x = (singleton err, x) + +data DecompError + = BadBool !Word64 + | BadUnboxed !UnboxedTypeTag + | BadForeign !Reference + | BadData !Reference + | BadPAp !Reference + | UnkComb !Reference + | UnkLocal !Reference !Word64 + | Cont + | Exn + deriving (Eq, Ord) + +type DecompResult v = (Set DecompError, Term v ()) + +prf :: Reference -> Error +prf = syntaxToColor . prettyReference 10 + +printUnboxedTypeTag :: UnboxedTypeTag -> Error +printUnboxedTypeTag = shown + +renderDecompError :: DecompError -> Error +renderDecompError (BadBool n) = + lines + [ wrap "A boolean value had an unexpected constructor tag:", + indentN 2 . lit . fromString $ show n + ] +renderDecompError (BadUnboxed tt) = + lines + [ wrap "An apparent numeric type had an unrecognized packed tag:", + indentN 2 $ printUnboxedTypeTag tt + ] +renderDecompError (BadForeign rf) = + lines + [ wrap "A foreign value with no decompiled representation was encountered:", + indentN 2 $ prf rf + ] +renderDecompError (BadData rf) = + lines + [ wrap + "A data type with no decompiled representation was encountered:", + indentN 2 $ prf rf + ] +renderDecompError (BadPAp rf) = + lines + [ wrap "A partial function application could not be decompiled: ", + indentN 2 $ prf rf + ] +renderDecompError (UnkComb rf) = + lines + [ wrap "A reference to an unknown function was encountered: ", + indentN 2 $ prf rf + ] +renderDecompError (UnkLocal rf n) = + lines + [ "A reference to an unknown portion to a function was encountered: ", + indentN 2 $ "function: " <> prf rf, + indentN 2 $ "section: " <> lit (fromString $ show n) + ] +renderDecompError Cont = "A continuation value was encountered" +renderDecompError Exn = "An exception value was encountered" + +decompile :: + forall v. + (Var v) => + (Reference -> Maybe Reference) -> + (Word64 -> Word64 -> Maybe (Term v ())) -> + Val -> + DecompResult v +decompile backref topTerms = \case + CharVal c -> pure (char () c) + NatVal n -> pure (nat () n) + IntVal i -> pure (int () (fromIntegral i)) + DoubleVal f -> pure (float () f) + Val i (UnboxedTypeTag tt) -> + err (BadUnboxed tt) . nat () $ fromIntegral $ i + Val _u clos -> case clos of + DataC rf (maskTags -> ct) [] + | rf == booleanRef -> tag2bool ct + (DataC rf _ [b]) + | rf == anyRef -> + app () (builtin () "Any.Any") <$> decompile backref topTerms b + (DataC rf (maskTags -> ct) vs) -> + apps' (con rf ct) <$> traverse (decompile backref topTerms) vs + (PApV (CIx rf rt k) _ vs) + | rf == Builtin "jumpCont" -> + err Cont $ bug "" + | Builtin nm <- rf -> + apps' (builtin () nm) <$> traverse (decompile backref topTerms) vs + | Just t <- topTerms rt k -> + Term.etaReduceEtaVars . substitute t + <$> traverse (decompile backref topTerms) vs + | k > 0, + Just _ <- topTerms rt 0 -> + err (UnkLocal rf k) $ bug "" + | otherwise -> err (UnkComb rf) $ ref () rf + (PAp (CIx rf _ _) _ _) -> + err (BadPAp rf) $ bug "" + BlackHole -> err Exn $ bug "" + (Captured {}) -> err Cont $ bug "" + (Foreign f) -> + decompileForeign backref topTerms f + +tag2bool :: (Var v) => Word64 -> DecompResult v +tag2bool 0 = pure (boolean () False) +tag2bool 1 = pure (boolean () True) +tag2bool n = err (BadBool n) $ con booleanRef n + +substitute :: (Var v) => Term v () -> [Term v ()] -> Term v () +substitute = align [] + where + align vts (LamNamed' v bd) (t : ts) = align ((v, t) : vts) bd ts + align vts tm [] = substs vts tm + -- this should not happen + align vts tm ts = apps' (substs vts tm) ts + +decompileForeign :: + (Var v) => + (Reference -> Maybe Reference) -> + (Word64 -> Word64 -> Maybe (Term v ())) -> + Foreign -> + DecompResult v +decompileForeign backref topTerms f + | Just t <- maybeUnwrapBuiltin f = pure $ text () (Text.toText t) + | Just b <- maybeUnwrapBuiltin f = pure $ decompileBytes b + | Just h <- maybeUnwrapBuiltin f = pure $ decompileHashAlgorithm h + | Just l <- maybeUnwrapForeign termLinkRef f = + pure . termLink () $ case l of + Ref r -> maybe l Ref $ backref r + _ -> l + | Just l <- maybeUnwrapForeign typeLinkRef f = + pure $ typeLink () l + | Just (a :: Array Val) <- maybeUnwrapForeign iarrayRef f = + app () (ref () iarrayFromListRef) . list () + <$> traverse (decompile backref topTerms) (toList a) + | Just (a :: ByteArray) <- maybeUnwrapForeign ibytearrayRef f = + pure $ + app + () + (ref () ibarrayFromBytesRef) + (decompileBytes . By.fromWord8s $ byteArrayToList a) + | Just s <- unwrapSeq f = + list' () <$> traverse (decompile backref topTerms) s +decompileForeign _ _ (Wrap r _) = + err (BadForeign r) $ bug text + where + text + | Builtin name <- r = "<" <> name <> ">" + | otherwise = "" + +decompileBytes :: (Var v) => By.Bytes -> Term v () +decompileBytes = + app () (builtin () $ fromString "Bytes.fromList") + . list () + . fmap (nat () . fromIntegral) + . By.toWord8s + +decompileHashAlgorithm :: (Var v) => HashAlgorithm -> Term v () +decompileHashAlgorithm (HashAlgorithm r _) = ref () r + +unwrapSeq :: Foreign -> Maybe USeq +unwrapSeq = maybeUnwrapForeign listRef diff --git a/unison-runtime/src/Unison/Runtime/Exception.hs b/unison-runtime/src/Unison/Runtime/Exception.hs new file mode 100644 index 0000000000..2e79c163bd --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Exception.hs @@ -0,0 +1,34 @@ +module Unison.Runtime.Exception + ( RuntimeExn (..), + die, + dieP, + exn, + ) +where + +import Control.Exception +import Data.String (fromString) +import Data.Text +import GHC.Stack +import Unison.Reference (Reference) +import Unison.Runtime.Stack +import Unison.Util.Pretty as P + +data RuntimeExn + = PE CallStack (P.Pretty P.ColorText) + | BU [(Reference, Int)] Text Val + deriving (Show) + +instance Exception RuntimeExn + +die :: (HasCallStack) => String -> IO a +die = throwIO . PE callStack . P.lit . fromString +{-# INLINE die #-} + +dieP :: (HasCallStack) => P.Pretty P.ColorText -> IO a +dieP = throwIO . PE callStack +{-# INLINE dieP #-} + +exn :: (HasCallStack) => String -> a +exn = throw . PE callStack . P.lit . fromString +{-# INLINE exn #-} diff --git a/parser-typechecker/src/Unison/Runtime/Foreign.hs b/unison-runtime/src/Unison/Runtime/Foreign.hs similarity index 96% rename from parser-typechecker/src/Unison/Runtime/Foreign.hs rename to unison-runtime/src/Unison/Runtime/Foreign.hs index c9cd12fafb..831fb46d5d 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign.hs @@ -22,8 +22,8 @@ where import Control.Concurrent (MVar, ThreadId) import Control.Concurrent.STM (TVar) import Crypto.Hash qualified as Hash +import Data.Atomics qualified as Atomic import Data.IORef (IORef) -import Data.Primitive (ByteArray, MutableArray, MutableByteArray) import Data.Tagged (Tagged (..)) import Data.X509 qualified as X509 import Network.Socket (Socket) @@ -34,8 +34,8 @@ import System.IO (Handle) import System.Process (ProcessHandle) import Unison.Reference (Reference) import Unison.Referent (Referent) -import Unison.Runtime.ANF (SuperGroup, Value) -import Unison.Symbol (Symbol) +import Unison.Runtime.ANF (Code, Value) +import Unison.Runtime.Array import Unison.Type qualified as Ty import Unison.Util.Bytes (Bytes) import Unison.Util.Text (Text) @@ -130,8 +130,8 @@ charClassCmp :: CharPattern -> CharPattern -> Ordering charClassCmp = compare {-# NOINLINE charClassCmp #-} -codeEq :: SuperGroup Symbol -> SuperGroup Symbol -> Bool -codeEq sg1 sg2 = sg1 == sg2 +codeEq :: Code -> Code -> Bool +codeEq co1 co2 = co1 == co2 {-# NOINLINE codeEq #-} tylEq :: Reference -> Reference -> Bool @@ -256,13 +256,14 @@ instance BuiltinForeign FilePath where foreignRef = Tagged Ty.filePathRef instance BuiltinForeign TLS.Context where foreignRef = Tagged Ty.tlsRef -instance BuiltinForeign (SuperGroup Symbol) where - foreignRef = Tagged Ty.codeRef +instance BuiltinForeign Code where foreignRef = Tagged Ty.codeRef instance BuiltinForeign Value where foreignRef = Tagged Ty.valueRef instance BuiltinForeign TimeSpec where foreignRef = Tagged Ty.timeSpecRef +instance BuiltinForeign (Atomic.Ticket a) where foreignRef = Tagged Ty.ticketRef + data HashAlgorithm where -- Reference is a reference to the hash algorithm HashAlgorithm :: (Hash.HashAlgorithm a) => Reference -> a -> HashAlgorithm diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs new file mode 100644 index 0000000000..f4404ccfb7 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -0,0 +1,1801 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +module Unison.Runtime.Foreign.Function (foreignCall) where + +import Control.Concurrent (ThreadId) +import Control.Concurrent as SYS + ( killThread, + threadDelay, + ) +import Control.Concurrent.MVar as SYS +import Control.Concurrent.STM (TVar) +import Control.Concurrent.STM qualified as STM +import Control.DeepSeq (NFData) +import Control.Exception +import Control.Exception.Safe qualified as Exception +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Primitive qualified as PA +import Crypto.Error (CryptoError (..), CryptoFailable (..)) +import Crypto.Hash qualified as Hash +import Crypto.MAC.HMAC qualified as HMAC +import Crypto.PubKey.Ed25519 qualified as Ed25519 +import Crypto.PubKey.RSA.PKCS15 qualified as RSA +import Crypto.Random (getRandomBytes) +import Data.Atomics (Ticket) +import Data.Bits (shiftL, shiftR, (.|.)) +import Data.ByteArray qualified as BA +import Data.ByteString (hGet, hGetSome, hPut) +import Data.ByteString.Lazy qualified as L +import Data.Default (def) +import Data.Digest.Murmur64 (asWord64, hash64) +import Data.IORef (IORef) +import Data.IP (IP) +import Data.PEM (PEM, pemContent, pemParseLBS) +import Data.Sequence qualified as Sq +import Data.Text qualified +import Data.Text.IO qualified as Text.IO +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Time.Clock.POSIX as SYS + ( getPOSIXTime, + posixSecondsToUTCTime, + utcTimeToPOSIXSeconds, + ) +import Data.Time.LocalTime (TimeZone (..), getTimeZone) +import Data.X509 qualified as X +import Data.X509.CertificateStore qualified as X +import Data.X509.Memory qualified as X +import GHC.Conc qualified as STM +import GHC.IO (IO (IO)) +import GHC.IO.Exception (IOErrorType (..), IOException (..)) +import Network.Simple.TCP as SYS + ( HostPreference (..), + bindSock, + closeSock, + connectSock, + listenSock, + recv, + send, + ) +import Network.Socket (Socket) +import Network.Socket as SYS + ( PortNumber, + Socket, + accept, + socketPort, + ) +import Network.TLS as TLS +import Network.TLS.Extra.Cipher as Cipher +import Network.UDP (UDPSocket) +import Network.UDP as UDP + ( ClientSockAddr, + ListenSocket, + clientSocket, + close, + recv, + recvFrom, + send, + sendTo, + serverSocket, + stop, + ) +import System.Clock (Clock (..), getTime, nsec, sec) +import System.Directory as SYS + ( createDirectoryIfMissing, + doesDirectoryExist, + doesPathExist, + getCurrentDirectory, + getDirectoryContents, + getFileSize, + getModificationTime, + getTemporaryDirectory, + removeDirectoryRecursive, + removeFile, + renameDirectory, + renameFile, + setCurrentDirectory, + ) +import System.Environment as SYS + ( getArgs, + getEnv, + ) +import System.Exit as SYS (ExitCode (..)) +import System.FilePath (isPathSeparator) +import System.IO (BufferMode (..), Handle, IOMode, SeekMode) +import System.IO as SYS + ( IOMode (..), + hClose, + hGetBuffering, + hGetChar, + hGetEcho, + hIsEOF, + hIsOpen, + hIsSeekable, + hReady, + hSeek, + hSetBuffering, + hSetEcho, + hTell, + openFile, + stderr, + stdin, + stdout, + ) +import System.IO.Temp (createTempDirectory) +import System.Process as SYS + ( getProcessExitCode, + proc, + runInteractiveProcess, + terminateProcess, + waitForProcess, + withCreateProcess, + ) +import System.X509 qualified as X +import Unison.Builtin.Decls qualified as Ty +import Unison.Prelude hiding (Text, some) +import Unison.Reference +import Unison.Referent (Referent, pattern Ref) +import Unison.Runtime.ANF (Code, PackedTag (..), Value, internalBug) +import Unison.Runtime.ANF qualified as ANF +import Unison.Runtime.ANF.Rehash (checkGroupHashes) +import Unison.Runtime.ANF.Serialize qualified as ANF +import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Builtin +import Unison.Runtime.Crypto.Rsa qualified as Rsa +import Unison.Runtime.Exception +import Unison.Runtime.Foreign hiding (Failure) +import Unison.Runtime.Foreign qualified as F +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..)) +import Unison.Runtime.MCode +import Unison.Runtime.Stack +import Unison.Symbol +import Unison.Type + ( iarrayRef, + ibytearrayRef, + marrayRef, + mbytearrayRef, + mvarRef, + promiseRef, + refRef, + ticketRef, + tvarRef, + typeLinkRef, + ) +import Unison.Type qualified as Ty +import Unison.Util.Bytes (Bytes) +import Unison.Util.Bytes qualified as Bytes +import Unison.Util.RefPromise + ( Promise, + newPromise, + readPromise, + tryReadPromise, + writePromise, + ) +import Unison.Util.Text (Text, pack, unpack) +import Unison.Util.Text qualified as Util.Text +import Unison.Util.Text.Pattern qualified as TPat +import UnliftIO qualified + +-- foreignCall is explicitly NOINLINE'd because it's a _huge_ chunk of code and negatively affects code caching. +-- Because we're not inlining it, we need a wrapper using an explicitly unboxed Stack so we don't block the +-- worker-wrapper optimizations in the main eval loop. +-- It looks dump to accept an unboxed stack and then immediately box it up, but GHC is sufficiently smart to +-- unbox all of 'foreignCallHelper' when we write it this way, but it's way less work to use the regular lifted stack +-- in its implementation. +{-# NOINLINE foreignCall #-} +foreignCall :: ForeignFunc -> Args -> XStack -> IOXStack +foreignCall !ff !args !xstk = + stackIOToIOX $ foreignCallHelper ff args (packXStack xstk) + +{-# INLINE foreignCallHelper #-} +foreignCallHelper :: ForeignFunc -> Args -> Stack -> IO Stack +foreignCallHelper = \case + IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> + let hostStr = Util.Text.toString host + portStr = Util.Text.toString port + in UDP.clientSocket hostStr portStr True + IO_UDP_UDPSocket_recv_impl_v1 -> mkForeignIOF $ \(sock :: UDPSocket) -> Bytes.fromArray <$> UDP.recv sock + IO_UDP_UDPSocket_send_impl_v1 -> mkForeignIOF $ + \(sock :: UDPSocket, bytes :: Bytes.Bytes) -> + UDP.send sock (Bytes.toArray bytes) + IO_UDP_UDPSocket_close_impl_v1 -> mkForeignIOF $ + \(sock :: UDPSocket) -> UDP.close sock + IO_UDP_ListenSocket_close_impl_v1 -> mkForeignIOF $ + \(sock :: ListenSocket) -> UDP.stop sock + IO_UDP_UDPSocket_toText_impl_v1 -> mkForeign $ + \(sock :: UDPSocket) -> pure $ show sock + IO_UDP_serverSocket_impl_v1 -> mkForeignIOF $ + \(ip :: Util.Text.Text, port :: Util.Text.Text) -> + let maybeIp = readMaybe $ Util.Text.toString ip :: Maybe IP + maybePort = readMaybe $ Util.Text.toString port :: Maybe PortNumber + in case (maybeIp, maybePort) of + (Nothing, _) -> fail "Invalid IP Address" + (_, Nothing) -> fail "Invalid Port Number" + (Just ip, Just pt) -> UDP.serverSocket (ip, pt) + IO_UDP_ListenSocket_toText_impl_v1 -> mkForeign $ + \(sock :: ListenSocket) -> pure $ show sock + IO_UDP_ListenSocket_recvFrom_impl_v1 -> + mkForeignIOF $ + fmap (first Bytes.fromArray) <$> UDP.recvFrom + IO_UDP_ClientSockAddr_toText_v1 -> mkForeign $ + \(sock :: ClientSockAddr) -> pure $ show sock + IO_UDP_ListenSocket_sendTo_impl_v1 -> mkForeignIOF $ + \(socket :: ListenSocket, bytes :: Bytes.Bytes, addr :: ClientSockAddr) -> + UDP.sendTo socket (Bytes.toArray bytes) addr + IO_openFile_impl_v3 -> mkForeignIOF $ \(fnameText :: Util.Text.Text, n :: Int) -> + let fname = Util.Text.toString fnameText + mode = case n of + 0 -> ReadMode + 1 -> WriteMode + 2 -> AppendMode + _ -> ReadWriteMode + in openFile fname mode + IO_closeFile_impl_v3 -> mkForeignIOF hClose + IO_isFileEOF_impl_v3 -> mkForeignIOF hIsEOF + IO_isFileOpen_impl_v3 -> mkForeignIOF hIsOpen + IO_getEcho_impl_v1 -> mkForeignIOF hGetEcho + IO_ready_impl_v1 -> mkForeignIOF hReady + IO_getChar_impl_v1 -> mkForeignIOF hGetChar + IO_isSeekable_impl_v3 -> mkForeignIOF hIsSeekable + IO_seekHandle_impl_v3 -> mkForeignIOF $ + \(h, sm, n) -> hSeek h sm (fromIntegral (n :: Int)) + IO_handlePosition_impl_v3 -> + -- TODO: truncating integer + mkForeignIOF $ + \h -> fromInteger @Word64 <$> hTell h + IO_getBuffering_impl_v3 -> mkForeignIOF hGetBuffering + IO_setBuffering_impl_v3 -> + mkForeignIOF $ + uncurry hSetBuffering + IO_setEcho_impl_v1 -> mkForeignIOF $ uncurry hSetEcho + IO_getLine_impl_v1 -> + mkForeignIOF $ + fmap Util.Text.fromText . Text.IO.hGetLine + IO_getBytes_impl_v3 -> mkForeignIOF $ + \(h, n) -> Bytes.fromArray <$> hGet h n + IO_getSomeBytes_impl_v1 -> mkForeignIOF $ + \(h, n) -> Bytes.fromArray <$> hGetSome h n + IO_putBytes_impl_v3 -> mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) + IO_systemTime_impl_v3 -> mkForeignIOF $ + \() -> getPOSIXTime + IO_systemTimeMicroseconds_v1 -> mkForeign $ + \() -> fmap (1e6 *) getPOSIXTime + Clock_internals_monotonic_v1 -> mkForeignIOF $ + \() -> getTime Monotonic + Clock_internals_realtime_v1 -> mkForeignIOF $ + \() -> getTime Realtime + Clock_internals_processCPUTime_v1 -> mkForeignIOF $ + \() -> getTime ProcessCPUTime + Clock_internals_threadCPUTime_v1 -> mkForeignIOF $ + \() -> getTime ThreadCPUTime + Clock_internals_sec_v1 -> mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) + Clock_internals_nsec_v1 -> mkForeign (\n -> pure (fromIntegral $ nsec n :: Word64)) + Clock_internals_systemTimeZone_v1 -> + mkForeign + ( \secs -> do + TimeZone offset summer name <- getTimeZone (posixSecondsToUTCTime (fromIntegral (secs :: Int))) + pure (offset :: Int, summer, name) + ) + IO_getTempDirectory_impl_v3 -> + mkForeignIOF $ + \() -> chop <$> getTemporaryDirectory + IO_createTempDirectory_impl_v3 -> mkForeignIOF $ \prefix -> do + temp <- getTemporaryDirectory + chop <$> createTempDirectory temp prefix + IO_getCurrentDirectory_impl_v3 -> mkForeignIOF $ + \() -> getCurrentDirectory + IO_setCurrentDirectory_impl_v3 -> mkForeignIOF setCurrentDirectory + IO_fileExists_impl_v3 -> mkForeignIOF doesPathExist + IO_getEnv_impl_v1 -> mkForeignIOF getEnv + IO_getArgs_impl_v1 -> mkForeignIOF $ + \() -> fmap Util.Text.pack <$> SYS.getArgs + IO_isDirectory_impl_v3 -> mkForeignIOF doesDirectoryExist + IO_createDirectory_impl_v3 -> + mkForeignIOF $ + createDirectoryIfMissing True + IO_removeDirectory_impl_v3 -> mkForeignIOF removeDirectoryRecursive + IO_renameDirectory_impl_v3 -> + mkForeignIOF $ + uncurry renameDirectory + IO_directoryContents_impl_v3 -> + mkForeignIOF $ + (fmap Util.Text.pack <$>) . getDirectoryContents + IO_removeFile_impl_v3 -> mkForeignIOF removeFile + IO_renameFile_impl_v3 -> + mkForeignIOF $ + uncurry renameFile + IO_getFileTimestamp_impl_v3 -> + mkForeignIOF $ + fmap utcTimeToPOSIXSeconds . getModificationTime + IO_getFileSize_impl_v3 -> + -- TODO: truncating integer + mkForeignIOF $ + \fp -> fromInteger @Word64 <$> getFileSize fp + IO_serverSocket_impl_v3 -> + mkForeignIOF $ + \( mhst :: Maybe Util.Text.Text, + port + ) -> + fst <$> SYS.bindSock (hostPreference mhst) port + Socket_toText -> mkForeign $ + \(sock :: Socket) -> pure $ show sock + Handle_toText -> mkForeign $ + \(hand :: Handle) -> pure $ show hand + ThreadId_toText -> mkForeign $ + \(threadId :: ThreadId) -> pure $ show threadId + IO_socketPort_impl_v3 -> mkForeignIOF $ + \(handle :: Socket) -> do + n <- SYS.socketPort handle + return (fromIntegral n :: Word64) + IO_listen_impl_v3 -> mkForeignIOF $ + \sk -> SYS.listenSock sk 2048 + IO_clientSocket_impl_v3 -> + mkForeignIOF $ + fmap fst . uncurry SYS.connectSock + IO_closeSocket_impl_v3 -> mkForeignIOF SYS.closeSock + IO_socketAccept_impl_v3 -> + mkForeignIOF $ + fmap fst . SYS.accept + IO_socketSend_impl_v3 -> mkForeignIOF $ + \(sk, bs) -> SYS.send sk (Bytes.toArray bs) + IO_socketReceive_impl_v3 -> mkForeignIOF $ + \(hs, n) -> + maybe mempty Bytes.fromArray <$> SYS.recv hs n + IO_kill_impl_v3 -> mkForeignIOF killThread + IO_delay_impl_v3 -> mkForeignIOF customDelay + IO_stdHandle -> mkForeign $ + \(n :: Int) -> case n of + 0 -> pure SYS.stdin + 1 -> pure SYS.stdout + 2 -> pure SYS.stderr + _ -> die "IO.stdHandle: invalid input." + IO_process_call -> mkForeign $ + \(exe, map Util.Text.unpack -> args) -> + withCreateProcess (proc exe args) $ \_ _ _ p -> + exitDecode <$> waitForProcess p + IO_process_start -> mkForeign $ \(exe, map Util.Text.unpack -> args) -> + runInteractiveProcess exe args Nothing Nothing + IO_process_kill -> mkForeign $ terminateProcess + IO_process_wait -> mkForeign $ + \ph -> exitDecode <$> waitForProcess ph + IO_process_exitCode -> + mkForeign $ + fmap (fmap exitDecode) . getProcessExitCode + MVar_new -> mkForeign $ + \(c :: Val) -> newMVar c + MVar_newEmpty_v2 -> mkForeign $ + \() -> newEmptyMVar @Val + MVar_take_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> takeMVar mv + MVar_tryTake -> mkForeign $ + \(mv :: MVar Val) -> tryTakeMVar mv + MVar_put_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> putMVar mv x + MVar_tryPut_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> tryPutMVar mv x + MVar_swap_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> swapMVar mv x + MVar_isEmpty -> mkForeign $ + \(mv :: MVar Val) -> isEmptyMVar mv + MVar_read_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> readMVar mv + MVar_tryRead_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> tryReadMVar mv + Char_toText -> mkForeign $ + \(ch :: Char) -> pure (Util.Text.singleton ch) + Text_repeat -> mkForeign $ + \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) + Text_reverse -> + mkForeign $ + pure . Util.Text.reverse + Text_toUppercase -> + mkForeign $ + pure . Util.Text.toUppercase + Text_toLowercase -> + mkForeign $ + pure . Util.Text.toLowercase + Text_toUtf8 -> + mkForeign $ + pure . Util.Text.toUtf8 + Text_fromUtf8_impl_v3 -> + mkForeign $ + pure . mapLeft (\t -> F.Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 + Tls_ClientConfig_default -> mkForeign $ + \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> + fmap + ( \store -> + (defaultParamsClient (Util.Text.unpack hostName) (Bytes.toArray serverId)) + { TLS.clientSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, + TLS.clientShared = def {TLS.sharedCAStore = store} + } + ) + X.getSystemCertificateStore + Tls_ServerConfig_default -> + mkForeign $ + \(certs :: [X.SignedCertificate], key :: X.PrivKey) -> + pure $ + (def :: TLS.ServerParams) + { TLS.serverSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, + TLS.serverShared = def {TLS.sharedCredentials = Credentials [(X.CertificateChain certs, key)]} + } + Tls_ClientConfig_certificates_set -> + let updateClient :: X.CertificateStore -> TLS.ClientParams -> TLS.ClientParams + updateClient certs client = client {TLS.clientShared = ((clientShared client) {TLS.sharedCAStore = certs})} + in mkForeign $ + \(certs :: [X.SignedCertificate], params :: ClientParams) -> pure $ updateClient (X.makeCertificateStore certs) params + Tls_ServerConfig_certificates_set -> + let updateServer :: X.CertificateStore -> TLS.ServerParams -> TLS.ServerParams + updateServer certs client = client {TLS.serverShared = ((serverShared client) {TLS.sharedCAStore = certs})} + in mkForeign $ + \(certs :: [X.SignedCertificate], params :: ServerParams) -> pure $ updateServer (X.makeCertificateStore certs) params + TVar_new -> mkForeign $ + \(c :: Val) -> unsafeSTMToIO $ STM.newTVar c + TVar_read -> mkForeign $ + \(v :: STM.TVar Val) -> unsafeSTMToIO $ STM.readTVar v + TVar_write -> mkForeign $ + \(v :: STM.TVar Val, c :: Val) -> + unsafeSTMToIO $ STM.writeTVar v c + TVar_newIO -> mkForeign $ + \(c :: Val) -> STM.newTVarIO c + TVar_readIO -> mkForeign $ + \(v :: STM.TVar Val) -> STM.readTVarIO v + TVar_swap -> mkForeign $ + \(v, c :: Val) -> unsafeSTMToIO $ STM.swapTVar v c + STM_retry -> mkForeign $ + \() -> unsafeSTMToIO STM.retry :: IO Val + Promise_new -> mkForeign $ + \() -> newPromise @Val + Promise_read -> mkForeign $ + \(p :: Promise Val) -> readPromise p + Promise_tryRead -> mkForeign $ + \(p :: Promise Val) -> tryReadPromise p + Promise_write -> mkForeign $ + \(p :: Promise Val, a :: Val) -> writePromise p a + Tls_newClient_impl_v3 -> + mkForeignTls $ + \( config :: TLS.ClientParams, + socket :: SYS.Socket + ) -> TLS.contextNew socket config + Tls_newServer_impl_v3 -> + mkForeignTls $ + \( config :: TLS.ServerParams, + socket :: SYS.Socket + ) -> TLS.contextNew socket config + Tls_handshake_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> TLS.handshake tls + Tls_send_impl_v3 -> + mkForeignTls $ + \( tls :: TLS.Context, + bytes :: Bytes.Bytes + ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) + Tls_decodeCert_impl_v3 -> + let wrapFailure t = F.Failure Ty.tlsFailureRef (Util.Text.pack t) unitValue + decoded :: Bytes.Bytes -> Either String PEM + decoded bytes = case pemParseLBS $ Bytes.toLazyByteString bytes of + Right (pem : _) -> Right pem + Right [] -> Left "no PEM found" + Left l -> Left l + asCert :: PEM -> Either String X.SignedCertificate + asCert pem = X.decodeSignedCertificate $ pemContent pem + in mkForeignTlsE $ + \(bytes :: Bytes.Bytes) -> pure $ mapLeft wrapFailure $ (decoded >=> asCert) bytes + Tls_encodeCert -> mkForeign $ + \(cert :: X.SignedCertificate) -> pure $ Bytes.fromArray $ X.encodeSignedObject cert + Tls_decodePrivateKey -> mkForeign $ + \(bytes :: Bytes.Bytes) -> pure $ X.readKeyFileFromMemory $ L.toStrict $ Bytes.toLazyByteString bytes + Tls_encodePrivateKey -> mkForeign $ + \(privateKey :: X.PrivKey) -> pure $ Util.Text.toUtf8 $ Util.Text.pack $ show privateKey + Tls_receive_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> do + bs <- TLS.recvData tls + pure $ Bytes.fromArray bs + Tls_terminate_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> TLS.bye tls + Code_validateLinks -> mkForeign $ + \(lsgs0 :: [(Referent, ANF.Code)]) -> do + let f (msg, rs) = + F.Failure Ty.miscFailureRef (Util.Text.fromText msg) rs + pure . first f $ checkGroupHashes lsgs0 + Code_dependencies -> mkForeign $ + \(ANF.CodeRep sg _) -> + pure $ Wrap Ty.termLinkRef . Ref <$> ANF.groupTermLinks sg + Code_serialize -> mkForeign $ + \(co :: ANF.Code) -> + pure . Bytes.fromArray $ ANF.serializeCode builtinForeignNames co + Code_deserialize -> + mkForeign $ + pure . ANF.deserializeCode . Bytes.toArray + Code_display -> mkForeign $ + \(nm, (ANF.CodeRep sg _)) -> + pure $ ANF.prettyGroup @Symbol (Util.Text.unpack nm) sg "" + Value_dependencies -> + mkForeign $ + pure . fmap (Wrap Ty.termLinkRef . Ref) . ANF.valueTermLinks + Value_serialize -> + mkForeign $ + pure . Bytes.fromArray . ANF.serializeValue + Value_deserialize -> + mkForeign $ + pure . ANF.deserializeValue . Bytes.toArray + Crypto_HashAlgorithm_Sha3_512 -> mkHashAlgorithm "Sha3_512" Hash.SHA3_512 + Crypto_HashAlgorithm_Sha3_256 -> mkHashAlgorithm "Sha3_256" Hash.SHA3_256 + Crypto_HashAlgorithm_Sha2_512 -> mkHashAlgorithm "Sha2_512" Hash.SHA512 + Crypto_HashAlgorithm_Sha2_256 -> mkHashAlgorithm "Sha2_256" Hash.SHA256 + Crypto_HashAlgorithm_Sha1 -> mkHashAlgorithm "Sha1" Hash.SHA1 + Crypto_HashAlgorithm_Blake2b_512 -> mkHashAlgorithm "Blake2b_512" Hash.Blake2b_512 + Crypto_HashAlgorithm_Blake2b_256 -> mkHashAlgorithm "Blake2b_256" Hash.Blake2b_256 + Crypto_HashAlgorithm_Blake2s_256 -> mkHashAlgorithm "Blake2s_256" Hash.Blake2s_256 + Crypto_HashAlgorithm_Md5 -> mkHashAlgorithm "Md5" Hash.MD5 + Crypto_hashBytes -> mkForeign $ + \(HashAlgorithm _ alg, b :: Bytes.Bytes) -> + let ctx = Hash.hashInitWith alg + in pure . Bytes.fromArray . Hash.hashFinalize $ Hash.hashUpdates ctx (Bytes.byteStringChunks b) + Crypto_hmacBytes -> mkForeign $ + \(HashAlgorithm _ alg, key :: Bytes.Bytes, msg :: Bytes.Bytes) -> + let out = u alg $ HMAC.hmac (Bytes.toArray @BA.Bytes key) (Bytes.toArray @BA.Bytes msg) + u :: a -> HMAC.HMAC a -> HMAC.HMAC a + u _ h = h -- to help typechecker along + in pure $ Bytes.fromArray out + Crypto_hash -> mkForeign $ + \(HashAlgorithm _ alg, x) -> + let hashlazy :: + (Hash.HashAlgorithm a) => + a -> + L.ByteString -> + Hash.Digest a + hashlazy _ l = Hash.hashlazy l + in pure . Bytes.fromArray . hashlazy alg $ ANF.serializeValueForHash x + Crypto_hmac -> mkForeign $ + \(HashAlgorithm _ alg, key, x) -> + let hmac :: + (Hash.HashAlgorithm a) => a -> L.ByteString -> HMAC.HMAC a + hmac _ s = + HMAC.finalize + . HMAC.updates + (HMAC.initialize $ Bytes.toArray @BA.Bytes key) + $ L.toChunks s + in pure . Bytes.fromArray . hmac alg $ ANF.serializeValueForHash x + Crypto_Ed25519_sign_impl -> + mkForeign $ + pure . signEd25519Wrapper + Crypto_Ed25519_verify_impl -> + mkForeign $ + pure . verifyEd25519Wrapper + Crypto_Rsa_sign_impl -> + mkForeign $ + pure . signRsaWrapper + Crypto_Rsa_verify_impl -> + mkForeign $ + pure . verifyRsaWrapper + Universal_murmurHash -> + mkForeign $ + pure . asWord64 . hash64 . ANF.serializeValueForHash + IO_randomBytes -> mkForeign $ + \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n + Bytes_zlib_compress -> mkForeign $ pure . Bytes.zlibCompress + Bytes_gzip_compress -> mkForeign $ pure . Bytes.gzipCompress + Bytes_zlib_decompress -> mkForeign $ \bs -> + catchAll (pure (Bytes.zlibDecompress bs)) + Bytes_gzip_decompress -> mkForeign $ \bs -> + catchAll (pure (Bytes.gzipDecompress bs)) + Bytes_toBase16 -> mkForeign $ pure . Bytes.toBase16 + Bytes_toBase32 -> mkForeign $ pure . Bytes.toBase32 + Bytes_toBase64 -> mkForeign $ pure . Bytes.toBase64 + Bytes_toBase64UrlUnpadded -> mkForeign $ pure . Bytes.toBase64UrlUnpadded + Bytes_fromBase16 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase16 + Bytes_fromBase32 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase32 + Bytes_fromBase64 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase64 + Bytes_fromBase64UrlUnpadded -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded + Bytes_decodeNat64be -> mkForeign $ pure . Bytes.decodeNat64be + Bytes_decodeNat64le -> mkForeign $ pure . Bytes.decodeNat64le + Bytes_decodeNat32be -> mkForeign $ pure . Bytes.decodeNat32be + Bytes_decodeNat32le -> mkForeign $ pure . Bytes.decodeNat32le + Bytes_decodeNat16be -> mkForeign $ pure . Bytes.decodeNat16be + Bytes_decodeNat16le -> mkForeign $ pure . Bytes.decodeNat16le + Bytes_encodeNat64be -> mkForeign $ pure . Bytes.encodeNat64be + Bytes_encodeNat64le -> mkForeign $ pure . Bytes.encodeNat64le + Bytes_encodeNat32be -> mkForeign $ pure . Bytes.encodeNat32be + Bytes_encodeNat32le -> mkForeign $ pure . Bytes.encodeNat32le + Bytes_encodeNat16be -> mkForeign $ pure . Bytes.encodeNat16be + Bytes_encodeNat16le -> mkForeign $ pure . Bytes.encodeNat16le + MutableArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "MutableArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ + checkBounds name (PA.sizeofMutableArray src) (soff + l - 1) $ + Right + <$> PA.copyMutableArray @IO @Val + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + MutableByteArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "MutableByteArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ + checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l) 0 $ + Right + <$> PA.copyMutableByteArray @IO + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + ImmutableArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "ImmutableArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ + checkBounds name (PA.sizeofArray src) (soff + l - 1) $ + Right + <$> PA.copyArray @IO @Val + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + ImmutableArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofArray @Val + MutableArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Val + ImmutableByteArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofByteArray + MutableByteArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld + ImmutableByteArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "ImmutableByteArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ + checkBoundsPrim name (PA.sizeofByteArray src) (soff + l) 0 $ + Right + <$> PA.copyByteArray @IO + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + MutableArray_read -> + mkForeign $ + checkedRead "MutableArray.read" + MutableByteArray_read8 -> + mkForeign $ + checkedRead8 "MutableByteArray.read8" + MutableByteArray_read16be -> + mkForeign $ + checkedRead16 "MutableByteArray.read16be" + MutableByteArray_read24be -> + mkForeign $ + checkedRead24 "MutableByteArray.read24be" + MutableByteArray_read32be -> + mkForeign $ + checkedRead32 "MutableByteArray.read32be" + MutableByteArray_read40be -> + mkForeign $ + checkedRead40 "MutableByteArray.read40be" + MutableByteArray_read64be -> + mkForeign $ + checkedRead64 "MutableByteArray.read64be" + MutableArray_write -> + mkForeign $ + checkedWrite "MutableArray.write" + MutableByteArray_write8 -> + mkForeign $ + checkedWrite8 "MutableByteArray.write8" + MutableByteArray_write16be -> + mkForeign $ + checkedWrite16 "MutableByteArray.write16be" + MutableByteArray_write32be -> + mkForeign $ + checkedWrite32 "MutableByteArray.write32be" + MutableByteArray_write64be -> + mkForeign $ + checkedWrite64 "MutableByteArray.write64be" + ImmutableArray_read -> + mkForeign $ + checkedIndex "ImmutableArray.read" + ImmutableByteArray_read8 -> + mkForeign $ + checkedIndex8 "ImmutableByteArray.read8" + ImmutableByteArray_read16be -> + mkForeign $ + checkedIndex16 "ImmutableByteArray.read16be" + ImmutableByteArray_read24be -> + mkForeign $ + checkedIndex24 "ImmutableByteArray.read24be" + ImmutableByteArray_read32be -> + mkForeign $ + checkedIndex32 "ImmutableByteArray.read32be" + ImmutableByteArray_read40be -> + mkForeign $ + checkedIndex40 "ImmutableByteArray.read40be" + ImmutableByteArray_read64be -> + mkForeign $ + checkedIndex64 "ImmutableByteArray.read64be" + MutableByteArray_freeze_force -> + mkForeign $ + PA.unsafeFreezeByteArray + MutableArray_freeze_force -> + mkForeign $ + PA.unsafeFreezeArray @IO @Val + MutableByteArray_freeze -> mkForeign $ + \(src, off, len) -> + if len == 0 + then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 + else + checkBoundsPrim + "MutableByteArray.freeze" + (PA.sizeofMutableByteArray src) + (off + len) + 0 + $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) + MutableArray_freeze -> mkForeign $ + \(src :: PA.MutableArray PA.RealWorld Val, off, len) -> + if len == 0 + then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 emptyVal + else + checkBounds + "MutableArray.freeze" + (PA.sizeofMutableArray src) + (off + len - 1) + $ Right <$> PA.freezeArray src (fromIntegral off) (fromIntegral len) + MutableByteArray_length -> + mkForeign $ + pure . PA.sizeofMutableByteArray @PA.RealWorld + ImmutableByteArray_length -> + mkForeign $ + pure . PA.sizeofByteArray + IO_array -> mkForeign $ + \n -> PA.newArray n emptyVal + IO_arrayOf -> mkForeign $ + \(v :: Val, n) -> PA.newArray n v + IO_bytearray -> mkForeign $ PA.newByteArray + IO_bytearrayOf -> mkForeign $ + \(init, sz) -> do + arr <- PA.newByteArray sz + PA.fillByteArray arr 0 sz init + pure arr + Scope_array -> mkForeign $ + \n -> PA.newArray n emptyVal + Scope_arrayOf -> mkForeign $ + \(v :: Val, n) -> PA.newArray n v + Scope_bytearray -> mkForeign $ PA.newByteArray + Scope_bytearrayOf -> mkForeign $ + \(init, sz) -> do + arr <- PA.newByteArray sz + PA.fillByteArray arr 0 sz init + pure arr + Text_patterns_literal -> mkForeign $ + \txt -> evaluate . TPat.cpattern $ TPat.Literal txt + Text_patterns_digit -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharRange '0' '9')) in \() -> pure v + Text_patterns_letter -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Letter)) in \() -> pure v + Text_patterns_space -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Whitespace)) in \() -> pure v + Text_patterns_punctuation -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Punctuation)) in \() -> pure v + Text_patterns_anyChar -> + mkForeign $ + let v = TPat.cpattern (TPat.Char TPat.Any) in \() -> pure v + Text_patterns_eof -> + mkForeign $ + let v = TPat.cpattern TPat.Eof in \() -> pure v + Text_patterns_charRange -> mkForeign $ + \(beg, end) -> evaluate . TPat.cpattern . TPat.Char $ TPat.CharRange beg end + Text_patterns_notCharRange -> mkForeign $ + \(beg, end) -> evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharRange beg end + Text_patterns_charIn -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.charIn: non-character closure" + evaluate . TPat.cpattern . TPat.Char $ TPat.CharSet cs + Text_patterns_notCharIn -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.notCharIn: non-character closure" + evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs + Pattern_many -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many False p + Pattern_many_corrected -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many True p + Pattern_capture -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p + Pattern_captureAs -> mkForeign $ + \(t, (TPat.CP p _)) -> evaluate . TPat.cpattern $ TPat.CaptureAs t p + Pattern_join -> mkForeign $ \ps -> + evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps + Pattern_or -> mkForeign $ + \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r + Pattern_replicate -> mkForeign $ + \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> + let m = fromIntegral m0; n = fromIntegral n0 + in evaluate . TPat.cpattern $ TPat.Replicate m n p + Pattern_run -> mkForeign $ + \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input + Pattern_isMatch -> mkForeign $ + \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input + Char_Class_any -> mkForeign $ \() -> pure TPat.Any + Char_Class_not -> mkForeign $ pure . TPat.Not + Char_Class_and -> mkForeign $ \(a, b) -> pure $ TPat.Intersect a b + Char_Class_or -> mkForeign $ \(a, b) -> pure $ TPat.Union a b + Char_Class_range -> mkForeign $ \(a, b) -> pure $ TPat.CharRange a b + Char_Class_anyOf -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.charIn: non-character closure" + evaluate $ TPat.CharSet cs + Char_Class_alphanumeric -> mkForeign $ \() -> pure (TPat.CharClass TPat.AlphaNum) + Char_Class_upper -> mkForeign $ \() -> pure (TPat.CharClass TPat.Upper) + Char_Class_lower -> mkForeign $ \() -> pure (TPat.CharClass TPat.Lower) + Char_Class_whitespace -> mkForeign $ \() -> pure (TPat.CharClass TPat.Whitespace) + Char_Class_control -> mkForeign $ \() -> pure (TPat.CharClass TPat.Control) + Char_Class_printable -> mkForeign $ \() -> pure (TPat.CharClass TPat.Printable) + Char_Class_mark -> mkForeign $ \() -> pure (TPat.CharClass TPat.MarkChar) + Char_Class_number -> mkForeign $ \() -> pure (TPat.CharClass TPat.Number) + Char_Class_punctuation -> mkForeign $ \() -> pure (TPat.CharClass TPat.Punctuation) + Char_Class_symbol -> mkForeign $ \() -> pure (TPat.CharClass TPat.Symbol) + Char_Class_separator -> mkForeign $ \() -> pure (TPat.CharClass TPat.Separator) + Char_Class_letter -> mkForeign $ \() -> pure (TPat.CharClass TPat.Letter) + Char_Class_is -> mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c + Text_patterns_char -> mkForeign $ \c -> + let v = TPat.cpattern (TPat.Char c) in pure v + where + chop = reverse . dropWhile isPathSeparator . reverse + + hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference + hostPreference Nothing = SYS.HostAny + hostPreference (Just host) = SYS.Host $ Util.Text.unpack host + + mx :: Word64 + mx = fromIntegral (maxBound :: Int) + + customDelay :: Word64 -> IO () + customDelay n + | n < mx = threadDelay (fromIntegral n) + | otherwise = threadDelay maxBound >> customDelay (n - mx) + + exitDecode ExitSuccess = 0 + exitDecode (ExitFailure n) = n + + catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Util.Text.Text a) + catchAll e = do + e <- Exception.tryAnyDeep e + pure $ case e of + Left se -> Left (Util.Text.pack (show se)) + Right a -> Right a + +{-# INLINE mkHashAlgorithm #-} +mkHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> Args -> Stack -> IO Stack +mkHashAlgorithm txt alg = + let algoRef = Builtin ("crypto.HashAlgorithm." <> txt) + in mkForeign $ \() -> pure (HashAlgorithm algoRef alg) + +{-# INLINE mkForeign #-} +mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO Stack +mkForeign !f !args !stk = do + args <- decodeArgs args stk + res <- f args + writeForeign stk res + where + decodeArgs :: (ForeignConvention x) => Args -> Stack -> IO x + decodeArgs !args !stk = + readForeign (argsToLists args) stk >>= \case + ([], a) -> pure a + _ -> + error + "mkForeign: too many arguments for foreign function" + +{-# INLINE mkForeignIOF #-} +mkForeignIOF :: + (ForeignConvention a, ForeignConvention r) => + (a -> IO r) -> + Args -> + Stack -> + IO Stack +mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) + where + tryIOE :: IO a -> IO (Either (F.Failure Val) a) + tryIOE = fmap handleIOE . UnliftIO.try + handleIOE :: Either IOException a -> Either (F.Failure Val) a + handleIOE (Left e) = Left $ F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue + handleIOE (Right a) = Right a + +{-# INLINE mkForeignTls #-} +mkForeignTls :: + forall a r. + (ForeignConvention a, ForeignConvention r) => + (a -> IO r) -> + Args -> + Stack -> + IO Stack +mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) + where + tryIO1 :: IO r -> IO (Either TLS.TLSException r) + tryIO1 = UnliftIO.try + tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r)) + tryIO2 = UnliftIO.try + flatten :: Either IOException (Either TLS.TLSException r) -> Either ((F.Failure Val)) r + flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Right a)) = Right a + +{-# INLINE mkForeignTlsE #-} +mkForeignTlsE :: + forall a r. + (ForeignConvention a, ForeignConvention r) => + (a -> IO (Either Failure r)) -> + Args -> + Stack -> + IO Stack +mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) + where + tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r)) + tryIO1 = UnliftIO.try + tryIO2 :: IO (Either TLS.TLSException (Either Failure r)) -> IO (Either IOException (Either TLS.TLSException (Either Failure r))) + tryIO2 = UnliftIO.try + flatten :: Either IOException (Either TLS.TLSException (Either Failure r)) -> Either Failure r + flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Right (Left e))) = Left e + flatten (Right (Right (Right a))) = Right a + +{-# INLINE unsafeSTMToIO #-} +unsafeSTMToIO :: STM.STM a -> IO a +unsafeSTMToIO (STM.STM m) = IO m + +signEd25519Wrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes +signEd25519Wrapper (secret0, public0, msg0) = case validated of + CryptoFailed err -> + Left (F.Failure Ty.cryptoFailureRef (errMsg err) unitValue) + CryptoPassed (secret, public) -> + Right . Bytes.fromArray $ Ed25519.sign secret public msg + where + msg = Bytes.toArray msg0 :: ByteString + validated = + (,) + <$> Ed25519.secretKey (Bytes.toArray secret0 :: ByteString) + <*> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) + + errMsg CryptoError_PublicKeySizeInvalid = + "ed25519: Public key size invalid" + errMsg CryptoError_SecretKeySizeInvalid = + "ed25519: Secret key size invalid" + errMsg CryptoError_SecretKeyStructureInvalid = + "ed25519: Secret key structure invalid" + errMsg _ = "ed25519: unexpected error" + +verifyEd25519Wrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool +verifyEd25519Wrapper (public0, msg0, sig0) = case validated of + CryptoFailed err -> + Left $ F.Failure Ty.cryptoFailureRef (errMsg err) unitValue + CryptoPassed (public, sig) -> + Right $ Ed25519.verify public msg sig + where + msg = Bytes.toArray msg0 :: ByteString + validated = + (,) + <$> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) + <*> Ed25519.signature (Bytes.toArray sig0 :: ByteString) + + errMsg CryptoError_PublicKeySizeInvalid = + "ed25519: Public key size invalid" + errMsg CryptoError_SecretKeySizeInvalid = + "ed25519: Secret key size invalid" + errMsg CryptoError_SecretKeyStructureInvalid = + "ed25519: Secret key structure invalid" + errMsg _ = "ed25519: unexpected error" + +signRsaWrapper :: + (Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes +signRsaWrapper (secret0, msg0) = case validated of + Left err -> + Left (F.Failure Ty.cryptoFailureRef err unitValue) + Right secret -> + case RSA.sign Nothing (Just Hash.SHA256) secret msg of + Left err -> Left (F.Failure Ty.cryptoFailureRef (Rsa.rsaErrorToText err) unitValue) + Right signature -> Right $ Bytes.fromByteString signature + where + msg = Bytes.toArray msg0 :: ByteString + validated = Rsa.parseRsaPrivateKey (Bytes.toArray secret0 :: ByteString) + +verifyRsaWrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool +verifyRsaWrapper (public0, msg0, sig0) = case validated of + Left err -> + Left $ F.Failure Ty.cryptoFailureRef err unitValue + Right public -> + Right $ RSA.verify (Just Hash.SHA256) public msg sig + where + msg = Bytes.toArray msg0 :: ByteString + sig = Bytes.toArray sig0 :: ByteString + validated = Rsa.parseRsaPublicKey (Bytes.toArray public0 :: ByteString) + +type Failure = F.Failure Val + +checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) +checkBounds name l w act + | w < fromIntegral l = act + | otherwise = pure $ Left err + where + msg = name <> ": array index out of bounds" + err = F.Failure Ty.arrayFailureRef msg (natValue w) + +-- Performs a bounds check on a byte array. Strategy is as follows: +-- +-- isz = signed array size-in-bytes +-- off = unsigned byte offset into the array +-- esz = unsigned number of bytes to be read +-- +-- 1. Turn the signed size-in-bytes of the array unsigned +-- 2. Add the offset to the to-be-read number to get the maximum size needed +-- 3. Check that the actual array size is at least as big as the needed size +-- 4. Check that the offset is less than the size +-- +-- Step 4 ensures that step 3 has not overflowed. Since an actual array size can +-- only be 63 bits (since it is signed), the only way for 3 to overflow is if +-- the offset is larger than a possible array size, since it would need to be +-- 2^64-k, where k is the small (<=8) number of bytes to be read. +checkBoundsPrim :: + Text -> Int -> Word64 -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) +checkBoundsPrim name isz off esz act + | w > bsz || off > bsz = pure $ Left err + | otherwise = act + where + msg = name <> ": array index out of bounds" + err = F.Failure Ty.arrayFailureRef msg (natValue off) + + bsz = fromIntegral isz + w = off + esz + +type RW = PA.PrimState IO + +checkedRead :: + Text -> (PA.MutableArray RW Val, Word64) -> IO (Either Failure Val) +checkedRead name (arr, w) = + checkBounds + name + (PA.sizeofMutableArray arr) + w + (Right <$> PA.readArray arr (fromIntegral w)) + +checkedWrite :: + Text -> (PA.MutableArray RW Val, Word64, Val) -> IO (Either Failure ()) +checkedWrite name (arr, w, v) = + checkBounds + name + (PA.sizeofMutableArray arr) + w + (Right <$> PA.writeArray arr (fromIntegral w) v) + +checkedIndex :: + Text -> (PA.Array Val, Word64) -> IO (Either Failure Val) +checkedIndex name (arr, w) = + checkBounds + name + (PA.sizeofArray arr) + w + (Right <$> PA.indexArrayM arr (fromIntegral w)) + +checkedRead8 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead8 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ + (Right . fromIntegral) <$> PA.readByteArray @Word8 arr j + where + j = fromIntegral i + +checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead16 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ + mk16 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + where + j = fromIntegral i + +checkedRead24 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead24 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 3 $ + mk24 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + where + j = fromIntegral i + +checkedRead32 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead32 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ + mk32 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + where + j = fromIntegral i + +checkedRead40 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead40 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 6 $ + mk40 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + <*> PA.readByteArray @Word8 arr (j + 4) + where + j = fromIntegral i + +checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead64 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ + mk64 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + <*> PA.readByteArray @Word8 arr (j + 4) + <*> PA.readByteArray @Word8 arr (j + 5) + <*> PA.readByteArray @Word8 arr (j + 6) + <*> PA.readByteArray @Word8 arr (j + 7) + where + j = fromIntegral i + +mk16 :: Word8 -> Word8 -> Either Failure Word64 +mk16 b0 b1 = Right $ (fromIntegral b0 `shiftL` 8) .|. (fromIntegral b1) + +mk24 :: Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk24 b0 b1 b2 = + Right $ + (fromIntegral b0 `shiftL` 16) + .|. (fromIntegral b1 `shiftL` 8) + .|. (fromIntegral b2) + +mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk32 b0 b1 b2 b3 = + Right $ + (fromIntegral b0 `shiftL` 24) + .|. (fromIntegral b1 `shiftL` 16) + .|. (fromIntegral b2 `shiftL` 8) + .|. (fromIntegral b3) + +mk40 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk40 b0 b1 b2 b3 b4 = + Right $ + (fromIntegral b0 `shiftL` 32) + .|. (fromIntegral b1 `shiftL` 24) + .|. (fromIntegral b2 `shiftL` 16) + .|. (fromIntegral b3 `shiftL` 8) + .|. (fromIntegral b4) + +mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk64 b0 b1 b2 b3 b4 b5 b6 b7 = + Right $ + (fromIntegral b0 `shiftL` 56) + .|. (fromIntegral b1 `shiftL` 48) + .|. (fromIntegral b2 `shiftL` 40) + .|. (fromIntegral b3 `shiftL` 32) + .|. (fromIntegral b4 `shiftL` 24) + .|. (fromIntegral b5 `shiftL` 16) + .|. (fromIntegral b6 `shiftL` 8) + .|. (fromIntegral b7) + +checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite8 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ do + PA.writeByteArray arr j (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite16 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite16 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite32 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite32 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 24 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 16 :: Word8) + PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 3) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite64 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite64 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 56 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 48 :: Word8) + PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 40 :: Word8) + PA.writeByteArray arr (j + 3) (fromIntegral $ v `shiftR` 32 :: Word8) + PA.writeByteArray arr (j + 4) (fromIntegral $ v `shiftR` 24 :: Word8) + PA.writeByteArray arr (j + 5) (fromIntegral $ v `shiftR` 16 :: Word8) + PA.writeByteArray arr (j + 6) (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 7) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +-- index single byte +checkedIndex8 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex8 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 1 . pure $ + let j = fromIntegral i + in Right . fromIntegral $ PA.indexByteArray @Word8 arr j + +-- index 16 big-endian +checkedIndex16 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex16 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 2 . pure $ + let j = fromIntegral i + in mk16 (PA.indexByteArray arr j) (PA.indexByteArray arr (j + 1)) + +-- index 32 big-endian +checkedIndex24 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex24 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 3 . pure $ + let j = fromIntegral i + in mk24 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + +-- index 32 big-endian +checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex32 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 4 . pure $ + let j = fromIntegral i + in mk32 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + +-- index 40 big-endian +checkedIndex40 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex40 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 5 . pure $ + let j = fromIntegral i + in mk40 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + (PA.indexByteArray arr (j + 4)) + +-- index 64 big-endian +checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex64 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 8 . pure $ + let j = fromIntegral i + in mk64 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + (PA.indexByteArray arr (j + 4)) + (PA.indexByteArray arr (j + 5)) + (PA.indexByteArray arr (j + 6)) + (PA.indexByteArray arr (j + 7)) + +class ForeignConvention a where + readForeign :: + [Int] -> Stack -> IO ([Int], a) + writeForeign :: + Stack -> a -> IO Stack + +instance ForeignConvention Int where + readForeign (i : args) !stk = (args,) <$> peekOffI stk i + readForeign [] !_ = foreignCCError "Int" + writeForeign !stk !i = do + stk <- bump stk + stk <$ pokeI stk i + +instance ForeignConvention Word64 where + readForeign (i : args) !stk = (args,) <$> peekOffN stk i + readForeign [] !_ = foreignCCError "Word64" + writeForeign !stk !n = do + stk <- bump stk + stk <$ pokeN stk n + +-- We don't have a clear mapping from these types to Unison types, most are just mapped to Nats. + +instance ForeignConvention Word8 where + readForeign = readForeignAs (fromIntegral :: Word64 -> Word8) + writeForeign = writeForeignAs (fromIntegral :: Word8 -> Word64) + +instance ForeignConvention Word16 where + readForeign = readForeignAs (fromIntegral :: Word64 -> Word16) + writeForeign = writeForeignAs (fromIntegral :: Word16 -> Word64) + +instance ForeignConvention Word32 where + readForeign = readForeignAs (fromIntegral :: Word64 -> Word32) + writeForeign = writeForeignAs (fromIntegral :: Word32 -> Word64) + +instance ForeignConvention Char where + readForeign (i : args) !stk = (args,) <$> peekOffC stk i + readForeign [] !_ = foreignCCError "Char" + writeForeign !stk !ch = do + stk <- bump stk + stk <$ pokeC stk ch + +instance ForeignConvention Val where + readForeign (i : args) !stk = (args,) <$> peekOff stk i + readForeign [] !_ = foreignCCError "Val" + writeForeign !stk !v = do + stk <- bump stk + stk <$ (poke stk =<< evaluate v) + +-- In reality this fixes the type to be 'RClosure', but allows us to defer +-- the typechecker a bit and avoid a bunch of annoying type annotations. +instance ForeignConvention Closure where + readForeign (i : args) !stk = (args,) <$> bpeekOff stk i + readForeign [] !_ = foreignCCError "Closure" + writeForeign !stk !c = do + stk <- bump stk + stk <$ (bpoke stk =<< evaluate c) + +instance ForeignConvention Text where + readForeign = readForeignBuiltin + writeForeign = writeForeignBuiltin + +instance ForeignConvention Unison.Util.Bytes.Bytes where + readForeign = readForeignBuiltin + writeForeign = writeForeignBuiltin + +instance ForeignConvention Socket where + readForeign = readForeignBuiltin + writeForeign = writeForeignBuiltin + +instance ForeignConvention UDPSocket where + readForeign = readForeignBuiltin + writeForeign = writeForeignBuiltin + +instance ForeignConvention ThreadId where + readForeign = readForeignBuiltin + writeForeign = writeForeignBuiltin + +instance ForeignConvention Handle where + readForeign = readForeignBuiltin + writeForeign = writeForeignBuiltin + +instance ForeignConvention POSIXTime where + readForeign = readForeignAs (fromIntegral :: Int -> POSIXTime) + writeForeign = writeForeignAs (round :: POSIXTime -> Int) + +instance (ForeignConvention a) => ForeignConvention (Maybe a) where + readForeign (i : args) !stk = + upeekOff stk i >>= \case + 0 -> pure (args, Nothing) + 1 -> fmap Just <$> readForeign args stk + _ -> foreignCCError "Maybe" + readForeign [] !_ = foreignCCError "Maybe" + + writeForeign !stk Nothing = do + stk <- bump stk + stk <$ pokeTag stk 0 + writeForeign !stk (Just x) = do + stk <- writeForeign stk x + stk <- bump stk + stk <$ pokeTag stk 1 + +instance + (ForeignConvention a, ForeignConvention b) => + ForeignConvention (Either a b) + where + readForeign (i : args) !stk = + peekTagOff stk i >>= \case + 0 -> readForeignAs Left args stk + 1 -> readForeignAs Right args stk + _ -> foreignCCError "Either" + readForeign !_ !_ = foreignCCError "Either" + + writeForeign !stk !(Left a) = do + stk <- writeForeign stk a + stk <- bump stk + stk <$ pokeTag stk 0 + writeForeign !stk !(Right b) = do + stk <- writeForeign stk b + stk <- bump stk + stk <$ pokeTag stk 1 + +ioeDecode :: Int -> IOErrorType +ioeDecode 0 = AlreadyExists +ioeDecode 1 = NoSuchThing +ioeDecode 2 = ResourceBusy +ioeDecode 3 = ResourceExhausted +ioeDecode 4 = EOF +ioeDecode 5 = IllegalOperation +ioeDecode 6 = PermissionDenied +ioeDecode 7 = UserError +ioeDecode _ = internalBug "ioeDecode" + +ioeEncode :: IOErrorType -> Int +ioeEncode AlreadyExists = 0 +ioeEncode NoSuchThing = 1 +ioeEncode ResourceBusy = 2 +ioeEncode ResourceExhausted = 3 +ioeEncode EOF = 4 +ioeEncode IllegalOperation = 5 +ioeEncode PermissionDenied = 6 +ioeEncode UserError = 7 +ioeEncode _ = internalBug "ioeDecode" + +instance ForeignConvention IOException where + readForeign = readForeignAs (bld . ioeDecode) + where + bld t = IOError Nothing t "" "" Nothing Nothing + + writeForeign = writeForeignAs (ioeEncode . ioe_type) + +readForeignAs :: + (ForeignConvention a) => + (a -> b) -> + [Int] -> + Stack -> + IO ([Int], b) +readForeignAs !f !args !stk = fmap f <$> readForeign args stk + +writeForeignAs :: + (ForeignConvention b) => + (a -> b) -> + Stack -> + a -> + IO Stack +writeForeignAs !f !stk !x = writeForeign stk (f x) + +readForeignEnum :: + (Enum a) => + [Int] -> + Stack -> + IO ([Int], a) +readForeignEnum = readForeignAs toEnum + +writeForeignEnum :: + (Enum a) => + Stack -> + a -> + IO Stack +writeForeignEnum = writeForeignAs fromEnum + +readForeignBuiltin :: + (BuiltinForeign b) => + [Int] -> + Stack -> + IO ([Int], b) +readForeignBuiltin = readForeignAs (unwrapBuiltin . marshalToForeign) + +writeForeignBuiltin :: + (BuiltinForeign b) => + Stack -> + b -> + IO Stack +writeForeignBuiltin = writeForeignAs (Foreign . wrapBuiltin) + +writeTypeLink :: + Stack -> + Reference -> + IO Stack +writeTypeLink = writeForeignAs (Foreign . Wrap typeLinkRef) +{-# INLINE writeTypeLink #-} + +readTypelink :: + [Int] -> + Stack -> + IO ([Int], Reference) +readTypelink = readForeignAs (unwrapForeign . marshalToForeign) +{-# INLINE readTypelink #-} + +instance ForeignConvention Double where + readForeign (i : args) !stk = (args,) <$> peekOffD stk i + readForeign !_ !_ = foreignCCError "Double" + writeForeign !stk !d = + bump stk >>= \(!stk) -> do + pokeD stk d + pure stk + +instance ForeignConvention Bool where + readForeign (i : args) !stk = do + b <- peekOffBool stk i + pure (args, b) + readForeign !_ !_ = foreignCCError "Bool" + writeForeign !stk !b = do + stk <- bump stk + pokeBool stk b + pure stk + +instance ForeignConvention String where + readForeign = readForeignAs unpack + writeForeign = writeForeignAs pack + +instance ForeignConvention SeekMode where + readForeign = readForeignEnum + writeForeign = writeForeignEnum + +instance ForeignConvention IOMode where + readForeign = readForeignEnum + writeForeign = writeForeignEnum + +instance ForeignConvention () where + readForeign !args !_ = pure (args, ()) + writeForeign !stk !_ = pure stk + +instance + (ForeignConvention a, ForeignConvention b) => + ForeignConvention (a, b) + where + readForeign !args !stk = do + (args, a) <- readForeign args stk + (args, b) <- readForeign args stk + pure (args, (a, b)) + + writeForeign !stk (x, y) = do + stk <- writeForeign stk y + writeForeign stk x + +instance (ForeignConvention a) => ForeignConvention (F.Failure a) where + readForeign !args !stk = do + (args, typeref) <- readTypelink args stk + (args, message) <- readForeign args stk + (args, any) <- readForeign args stk + pure (args, F.Failure typeref message any) + + writeForeign !stk (F.Failure typeref message any) = do + stk <- writeForeign stk any + stk <- writeForeign stk message + writeTypeLink stk typeref + +instance + ( ForeignConvention a, + ForeignConvention b, + ForeignConvention c + ) => + ForeignConvention (a, b, c) + where + readForeign !args !stk = do + (args, a) <- readForeign args stk + (args, b) <- readForeign args stk + (args, c) <- readForeign args stk + pure (args, (a, b, c)) + + writeForeign !stk (a, b, c) = do + stk <- writeForeign stk c + stk <- writeForeign stk b + writeForeign stk a + +instance + ( ForeignConvention a, + ForeignConvention b, + ForeignConvention c, + ForeignConvention d + ) => + ForeignConvention (a, b, c, d) + where + readForeign !args !stk = do + (args, a) <- readForeign args stk + (args, b) <- readForeign args stk + (args, c) <- readForeign args stk + (args, d) <- readForeign args stk + pure (args, (a, b, c, d)) + + writeForeign !stk (a, b, c, d) = do + stk <- writeForeign stk d + stk <- writeForeign stk c + stk <- writeForeign stk b + writeForeign stk a + +instance + ( ForeignConvention a, + ForeignConvention b, + ForeignConvention c, + ForeignConvention d, + ForeignConvention e + ) => + ForeignConvention (a, b, c, d, e) + where + readForeign !args !stk = do + (args, a) <- readForeign args stk + (args, b) <- readForeign args stk + (args, c) <- readForeign args stk + (args, d) <- readForeign args stk + (args, e) <- readForeign args stk + pure (args, (a, b, c, d, e)) + + writeForeign !stk (a, b, c, d, e) = do + stk <- writeForeign stk e + stk <- writeForeign stk d + stk <- writeForeign stk c + stk <- writeForeign stk b + writeForeign stk a + +no'buf, line'buf, block'buf, sblock'buf :: Word64 +no'buf = fromIntegral Ty.bufferModeNoBufferingId +line'buf = fromIntegral Ty.bufferModeLineBufferingId +block'buf = fromIntegral Ty.bufferModeBlockBufferingId +sblock'buf = fromIntegral Ty.bufferModeSizedBlockBufferingId + +instance ForeignConvention BufferMode where + readForeign (i : args) !stk = + peekOffN stk i >>= \case + t + | t == no'buf -> pure (args, NoBuffering) + | t == line'buf -> pure (args, LineBuffering) + | t == block'buf -> pure (args, BlockBuffering Nothing) + | t == sblock'buf -> + fmap (BlockBuffering . Just) + <$> readForeign args stk + | otherwise -> + foreignCCError $ + "BufferMode (unknown tag: " <> show t <> ")" + readForeign !_ !_ = foreignCCError $ "BufferMode (empty stack)" + + writeForeign !stk !bm = + bump stk >>= \(stk) -> + case bm of + NoBuffering -> stk <$ pokeN stk no'buf + LineBuffering -> stk <$ pokeN stk line'buf + BlockBuffering Nothing -> stk <$ pokeN stk block'buf + BlockBuffering (Just n) -> do + pokeI stk n + stk <- bump stk + stk <$ pokeN stk sblock'buf + +-- In reality this fixes the type to be 'RClosure', but allows us to defer +-- the typechecker a bit and avoid a bunch of annoying type annotations. +instance {-# OVERLAPPING #-} ForeignConvention [Val] where + readForeign (i : args) !stk = + (args,) . toList <$> peekOffS stk i + readForeign !_ !_ = foreignCCError "[Val]" + writeForeign !stk !l = do + stk <- bump stk + stk <$ pokeS stk (Sq.fromList l) + +-- In reality this fixes the type to be 'RClosure', but allows us to defer +-- the typechecker a bit and avoid a bunch of annoying type annotations. +instance {-# OVERLAPPING #-} ForeignConvention [Closure] where + readForeign (i : args) !stk = + (args,) . fmap getBoxedVal . toList <$> peekOffS stk i + readForeign !_ !_ = foreignCCError "[Closure]" + writeForeign !stk !l = do + stk <- bump stk + stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l) + +instance ForeignConvention [Foreign] where + readForeign = readForeignAs (fmap marshalToForeign) + writeForeign = writeForeignAs (fmap Foreign) + +instance ForeignConvention (MVar Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap mvarRef) + +instance ForeignConvention (TVar Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap tvarRef) + +instance ForeignConvention (IORef Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap refRef) + +instance ForeignConvention (Ticket Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap ticketRef) + +instance ForeignConvention (Promise Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap promiseRef) + +instance ForeignConvention Code where + readForeign = readForeignBuiltin + writeForeign = writeForeignBuiltin + +instance ForeignConvention Value where + readForeign = readForeignBuiltin + writeForeign = writeForeignBuiltin + +instance ForeignConvention Foreign where + readForeign = readForeignAs marshalToForeign + writeForeign = writeForeignAs Foreign + +instance ForeignConvention (PA.MutableArray s Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap marrayRef) + +instance ForeignConvention (PA.MutableByteArray s) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap mbytearrayRef) + +instance ForeignConvention (PA.Array Val) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap iarrayRef) + +instance ForeignConvention PA.ByteArray where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap ibytearrayRef) + +instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where + readForeign = readForeignBuiltin + writeForeign = writeForeignBuiltin + +fromUnisonPair :: (BuiltinForeign a, BuiltinForeign b) => Closure -> (a, b) +fromUnisonPair (DataC _ _ [BoxedVal x, BoxedVal (DataC _ _ [BoxedVal y, BoxedVal _unit])]) = + (unwrapForeignClosure x, unwrapForeignClosure y) +fromUnisonPair _ = error "fromUnisonPair: invalid closure" + +toUnisonPair :: + (BuiltinForeign a, BuiltinForeign b) => (a, b) -> Closure +toUnisonPair (x, y) = + DataC + Ty.pairRef + (PackedTag 0) + [BoxedVal $ wr x, BoxedVal $ DataC Ty.pairRef (PackedTag 0) [BoxedVal $ wr y, BoxedVal $ un]] + where + un = DataC Ty.unitRef (PackedTag 0) [] + wr z = Foreign $ wrapBuiltin z + +unwrapForeignClosure :: Closure -> a +unwrapForeignClosure = unwrapForeign . marshalToForeign + +instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignConvention [(a, b)] where + readForeign (i : args) !stk = + (args,) + . fmap (fromUnisonPair . getBoxedVal) + . toList + <$> peekOffS stk i + readForeign !_ !_ = foreignCCError "[(a,b)]" + + writeForeign !stk !l = do + stk <- bump stk + stk <$ pokeS stk (boxedVal . toUnisonPair <$> Sq.fromList l) + +instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention [b] where + readForeign (i : args) !stk = + (args,) + . fmap (unwrapForeignClosure . getBoxedVal) + . toList + <$> peekOffS stk i + readForeign !_ !_ = foreignCCError "[b]" + writeForeign !stk !l = do + stk <- bump stk + stk <$ pokeS stk (boxedVal . Foreign . wrapBuiltin <$> Sq.fromList l) + +foreignCCError :: String -> IO a +foreignCCError nm = + die $ "mismatched foreign calling convention for `" ++ nm ++ "`" diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs new file mode 100644 index 0000000000..97796223e9 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs @@ -0,0 +1,506 @@ +module Unison.Runtime.Foreign.Function.Type + ( ForeignFunc (..), + foreignFuncBuiltinName, + ) +where + +import Data.Text (Text) + +-- | Enum representing every foreign call. +data ForeignFunc + = IO_UDP_clientSocket_impl_v1 + | IO_UDP_UDPSocket_recv_impl_v1 + | IO_UDP_UDPSocket_send_impl_v1 + | IO_UDP_UDPSocket_close_impl_v1 + | IO_UDP_ListenSocket_close_impl_v1 + | IO_UDP_UDPSocket_toText_impl_v1 + | IO_UDP_serverSocket_impl_v1 + | IO_UDP_ListenSocket_toText_impl_v1 + | IO_UDP_ListenSocket_recvFrom_impl_v1 + | IO_UDP_ClientSockAddr_toText_v1 + | IO_UDP_ListenSocket_sendTo_impl_v1 + | IO_openFile_impl_v3 + | IO_closeFile_impl_v3 + | IO_isFileEOF_impl_v3 + | IO_isFileOpen_impl_v3 + | IO_getEcho_impl_v1 + | IO_ready_impl_v1 + | IO_getChar_impl_v1 + | IO_isSeekable_impl_v3 + | IO_seekHandle_impl_v3 + | IO_handlePosition_impl_v3 + | IO_getBuffering_impl_v3 + | IO_setBuffering_impl_v3 + | IO_setEcho_impl_v1 + | IO_getLine_impl_v1 + | IO_getBytes_impl_v3 + | IO_getSomeBytes_impl_v1 + | IO_putBytes_impl_v3 + | IO_systemTime_impl_v3 + | IO_systemTimeMicroseconds_v1 + | Clock_internals_monotonic_v1 + | Clock_internals_realtime_v1 + | Clock_internals_processCPUTime_v1 + | Clock_internals_threadCPUTime_v1 + | Clock_internals_sec_v1 + | Clock_internals_nsec_v1 + | Clock_internals_systemTimeZone_v1 + | IO_getTempDirectory_impl_v3 + | IO_createTempDirectory_impl_v3 + | IO_getCurrentDirectory_impl_v3 + | IO_setCurrentDirectory_impl_v3 + | IO_fileExists_impl_v3 + | IO_getEnv_impl_v1 + | IO_getArgs_impl_v1 + | IO_isDirectory_impl_v3 + | IO_createDirectory_impl_v3 + | IO_removeDirectory_impl_v3 + | IO_renameDirectory_impl_v3 + | IO_directoryContents_impl_v3 + | IO_removeFile_impl_v3 + | IO_renameFile_impl_v3 + | IO_getFileTimestamp_impl_v3 + | IO_getFileSize_impl_v3 + | IO_serverSocket_impl_v3 + | Socket_toText + | Handle_toText + | ThreadId_toText + | IO_socketPort_impl_v3 + | IO_listen_impl_v3 + | IO_clientSocket_impl_v3 + | IO_closeSocket_impl_v3 + | IO_socketAccept_impl_v3 + | IO_socketSend_impl_v3 + | IO_socketReceive_impl_v3 + | IO_kill_impl_v3 + | IO_delay_impl_v3 + | IO_stdHandle + | IO_process_call + | IO_process_start + | IO_process_kill + | IO_process_wait + | IO_process_exitCode + | MVar_new + | MVar_newEmpty_v2 + | MVar_take_impl_v3 + | MVar_tryTake + | MVar_put_impl_v3 + | MVar_tryPut_impl_v3 + | MVar_swap_impl_v3 + | MVar_isEmpty + | MVar_read_impl_v3 + | MVar_tryRead_impl_v3 + | Char_toText + | Text_repeat + | Text_reverse + | Text_toUppercase + | Text_toLowercase + | Text_toUtf8 + | Text_fromUtf8_impl_v3 + | Tls_ClientConfig_default + | Tls_ServerConfig_default + | Tls_ClientConfig_certificates_set + | Tls_ServerConfig_certificates_set + | TVar_new + | TVar_read + | TVar_write + | TVar_newIO + | TVar_readIO + | TVar_swap + | STM_retry + | Promise_new + | Promise_read + | Promise_tryRead + | Promise_write + | Tls_newClient_impl_v3 + | Tls_newServer_impl_v3 + | Tls_handshake_impl_v3 + | Tls_send_impl_v3 + | Tls_decodeCert_impl_v3 + | Tls_encodeCert + | Tls_decodePrivateKey + | Tls_encodePrivateKey + | Tls_receive_impl_v3 + | Tls_terminate_impl_v3 + | Code_validateLinks + | Code_dependencies + | Code_serialize + | Code_deserialize + | Code_display + | Value_dependencies + | Value_serialize + | Value_deserialize + | Crypto_HashAlgorithm_Sha3_512 + | Crypto_HashAlgorithm_Sha3_256 + | Crypto_HashAlgorithm_Sha2_512 + | Crypto_HashAlgorithm_Sha2_256 + | Crypto_HashAlgorithm_Sha1 + | Crypto_HashAlgorithm_Blake2b_512 + | Crypto_HashAlgorithm_Blake2b_256 + | Crypto_HashAlgorithm_Blake2s_256 + | Crypto_HashAlgorithm_Md5 + | Crypto_hashBytes + | Crypto_hmacBytes + | Crypto_hash + | Crypto_hmac + | Crypto_Ed25519_sign_impl + | Crypto_Ed25519_verify_impl + | Crypto_Rsa_sign_impl + | Crypto_Rsa_verify_impl + | Universal_murmurHash + | IO_randomBytes + | Bytes_zlib_compress + | Bytes_gzip_compress + | Bytes_zlib_decompress + | Bytes_gzip_decompress + | Bytes_toBase16 + | Bytes_toBase32 + | Bytes_toBase64 + | Bytes_toBase64UrlUnpadded + | Bytes_fromBase16 + | Bytes_fromBase32 + | Bytes_fromBase64 + | Bytes_fromBase64UrlUnpadded + | Bytes_decodeNat64be + | Bytes_decodeNat64le + | Bytes_decodeNat32be + | Bytes_decodeNat32le + | Bytes_decodeNat16be + | Bytes_decodeNat16le + | Bytes_encodeNat64be + | Bytes_encodeNat64le + | Bytes_encodeNat32be + | Bytes_encodeNat32le + | Bytes_encodeNat16be + | Bytes_encodeNat16le + | MutableArray_copyTo_force + | MutableByteArray_copyTo_force + | ImmutableArray_copyTo_force + | ImmutableArray_size + | MutableArray_size + | ImmutableByteArray_size + | MutableByteArray_size + | ImmutableByteArray_copyTo_force + | MutableArray_read + | MutableByteArray_read8 + | MutableByteArray_read16be + | MutableByteArray_read24be + | MutableByteArray_read32be + | MutableByteArray_read40be + | MutableByteArray_read64be + | MutableArray_write + | MutableByteArray_write8 + | MutableByteArray_write16be + | MutableByteArray_write32be + | MutableByteArray_write64be + | ImmutableArray_read + | ImmutableByteArray_read8 + | ImmutableByteArray_read16be + | ImmutableByteArray_read24be + | ImmutableByteArray_read32be + | ImmutableByteArray_read40be + | ImmutableByteArray_read64be + | MutableByteArray_freeze_force + | MutableArray_freeze_force + | MutableByteArray_freeze + | MutableArray_freeze + | MutableByteArray_length + | ImmutableByteArray_length + | IO_array + | IO_arrayOf + | IO_bytearray + | IO_bytearrayOf + | Scope_array + | Scope_arrayOf + | Scope_bytearray + | Scope_bytearrayOf + | Text_patterns_literal + | Text_patterns_digit + | Text_patterns_letter + | Text_patterns_space + | Text_patterns_punctuation + | Text_patterns_anyChar + | Text_patterns_eof + | Text_patterns_charRange + | Text_patterns_notCharRange + | Text_patterns_charIn + | Text_patterns_notCharIn + | Pattern_many + | Pattern_many_corrected + | Pattern_capture + | Pattern_captureAs + | Pattern_join + | Pattern_or + | Pattern_replicate + | Pattern_run + | Pattern_isMatch + | Char_Class_any + | Char_Class_not + | Char_Class_and + | Char_Class_or + | Char_Class_range + | Char_Class_anyOf + | Char_Class_alphanumeric + | Char_Class_upper + | Char_Class_lower + | Char_Class_whitespace + | Char_Class_control + | Char_Class_printable + | Char_Class_mark + | Char_Class_number + | Char_Class_punctuation + | Char_Class_symbol + | Char_Class_separator + | Char_Class_letter + | Char_Class_is + | Text_patterns_char + deriving (Show, Eq, Ord, Enum, Bounded) + +foreignFuncBuiltinName :: ForeignFunc -> Text +foreignFuncBuiltinName = \case + IO_UDP_clientSocket_impl_v1 -> "IO.UDP.clientSocket.impl.v1" + IO_UDP_UDPSocket_recv_impl_v1 -> "IO.UDP.UDPSocket.recv.impl.v1" + IO_UDP_UDPSocket_send_impl_v1 -> "IO.UDP.UDPSocket.send.impl.v1" + IO_UDP_UDPSocket_close_impl_v1 -> "IO.UDP.UDPSocket.close.impl.v1" + IO_UDP_ListenSocket_close_impl_v1 -> "IO.UDP.ListenSocket.close.impl.v1" + IO_UDP_UDPSocket_toText_impl_v1 -> "IO.UDP.UDPSocket.toText.impl.v1" + IO_UDP_serverSocket_impl_v1 -> "IO.UDP.serverSocket.impl.v1" + IO_UDP_ListenSocket_toText_impl_v1 -> "IO.UDP.ListenSocket.toText.impl.v1" + IO_UDP_ListenSocket_recvFrom_impl_v1 -> "IO.UDP.ListenSocket.recvFrom.impl.v1" + IO_UDP_ClientSockAddr_toText_v1 -> "IO.UDP.ClientSockAddr.toText.v1" + IO_UDP_ListenSocket_sendTo_impl_v1 -> "IO.UDP.ListenSocket.sendTo.impl.v1" + IO_openFile_impl_v3 -> "IO.openFile.impl.v3" + IO_closeFile_impl_v3 -> "IO.closeFile.impl.v3" + IO_isFileEOF_impl_v3 -> "IO.isFileEOF.impl.v3" + IO_isFileOpen_impl_v3 -> "IO.isFileOpen.impl.v3" + IO_getEcho_impl_v1 -> "IO.getEcho.impl.v1" + IO_ready_impl_v1 -> "IO.ready.impl.v1" + IO_getChar_impl_v1 -> "IO.getChar.impl.v1" + IO_isSeekable_impl_v3 -> "IO.isSeekable.impl.v3" + IO_seekHandle_impl_v3 -> "IO.seekHandle.impl.v3" + IO_handlePosition_impl_v3 -> "IO.handlePosition.impl.v3" + IO_getBuffering_impl_v3 -> "IO.getBuffering.impl.v3" + IO_setBuffering_impl_v3 -> "IO.setBuffering.impl.v3" + IO_setEcho_impl_v1 -> "IO.setEcho.impl.v1" + IO_getLine_impl_v1 -> "IO.getLine.impl.v1" + IO_getBytes_impl_v3 -> "IO.getBytes.impl.v3" + IO_getSomeBytes_impl_v1 -> "IO.getSomeBytes.impl.v1" + IO_putBytes_impl_v3 -> "IO.putBytes.impl.v3" + IO_systemTime_impl_v3 -> "IO.systemTime.impl.v3" + IO_systemTimeMicroseconds_v1 -> "IO.systemTimeMicroseconds.v1" + Clock_internals_monotonic_v1 -> "Clock.internals.monotonic.v1" + Clock_internals_realtime_v1 -> "Clock.internals.realtime.v1" + Clock_internals_processCPUTime_v1 -> "Clock.internals.processCPUTime.v1" + Clock_internals_threadCPUTime_v1 -> "Clock.internals.threadCPUTime.v1" + Clock_internals_sec_v1 -> "Clock.internals.sec.v1" + Clock_internals_nsec_v1 -> "Clock.internals.nsec.v1" + Clock_internals_systemTimeZone_v1 -> "Clock.internals.systemTimeZone.v1" + IO_getTempDirectory_impl_v3 -> "IO.getTempDirectory.impl.v3" + IO_createTempDirectory_impl_v3 -> "IO.createTempDirectory.impl.v3" + IO_getCurrentDirectory_impl_v3 -> "IO.getCurrentDirectory.impl.v3" + IO_setCurrentDirectory_impl_v3 -> "IO.setCurrentDirectory.impl.v3" + IO_fileExists_impl_v3 -> "IO.fileExists.impl.v3" + IO_getEnv_impl_v1 -> "IO.getEnv.impl.v1" + IO_getArgs_impl_v1 -> "IO.getArgs.impl.v1" + IO_isDirectory_impl_v3 -> "IO.isDirectory.impl.v3" + IO_createDirectory_impl_v3 -> "IO.createDirectory.impl.v3" + IO_removeDirectory_impl_v3 -> "IO.removeDirectory.impl.v3" + IO_renameDirectory_impl_v3 -> "IO.renameDirectory.impl.v3" + IO_directoryContents_impl_v3 -> "IO.directoryContents.impl.v3" + IO_removeFile_impl_v3 -> "IO.removeFile.impl.v3" + IO_renameFile_impl_v3 -> "IO.renameFile.impl.v3" + IO_getFileTimestamp_impl_v3 -> "IO.getFileTimestamp.impl.v3" + IO_getFileSize_impl_v3 -> "IO.getFileSize.impl.v3" + IO_serverSocket_impl_v3 -> "IO.serverSocket.impl.v3" + Socket_toText -> "Socket.toText" + Handle_toText -> "Handle.toText" + ThreadId_toText -> "ThreadId.toText" + IO_socketPort_impl_v3 -> "IO.socketPort.impl.v3" + IO_listen_impl_v3 -> "IO.listen.impl.v3" + IO_clientSocket_impl_v3 -> "IO.clientSocket.impl.v3" + IO_closeSocket_impl_v3 -> "IO.closeSocket.impl.v3" + IO_socketAccept_impl_v3 -> "IO.socketAccept.impl.v3" + IO_socketSend_impl_v3 -> "IO.socketSend.impl.v3" + IO_socketReceive_impl_v3 -> "IO.socketReceive.impl.v3" + IO_kill_impl_v3 -> "IO.kill.impl.v3" + IO_delay_impl_v3 -> "IO.delay.impl.v3" + IO_stdHandle -> "IO.stdHandle" + IO_process_call -> "IO.process.call" + IO_process_start -> "IO.process.start" + IO_process_kill -> "IO.process.kill" + IO_process_wait -> "IO.process.wait" + IO_process_exitCode -> "IO.process.exitCode" + MVar_new -> "MVar.new" + MVar_newEmpty_v2 -> "MVar.newEmpty.v2" + MVar_take_impl_v3 -> "MVar.take.impl.v3" + MVar_tryTake -> "MVar.tryTake" + MVar_put_impl_v3 -> "MVar.put.impl.v3" + MVar_tryPut_impl_v3 -> "MVar.tryPut.impl.v3" + MVar_swap_impl_v3 -> "MVar.swap.impl.v3" + MVar_isEmpty -> "MVar.isEmpty" + MVar_read_impl_v3 -> "MVar.read.impl.v3" + MVar_tryRead_impl_v3 -> "MVar.tryRead.impl.v3" + Char_toText -> "Char.toText" + Text_repeat -> "Text.repeat" + Text_reverse -> "Text.reverse" + Text_toUppercase -> "Text.toUppercase" + Text_toLowercase -> "Text.toLowercase" + Text_toUtf8 -> "Text.toUtf8" + Text_fromUtf8_impl_v3 -> "Text.fromUtf8.impl.v3" + Tls_ClientConfig_default -> "Tls.ClientConfig.default" + Tls_ServerConfig_default -> "Tls.ServerConfig.default" + Tls_ClientConfig_certificates_set -> "Tls.ClientConfig.certificates.set" + Tls_ServerConfig_certificates_set -> "Tls.ServerConfig.certificates.set" + TVar_new -> "TVar.new" + TVar_read -> "TVar.read" + TVar_write -> "TVar.write" + TVar_newIO -> "TVar.newIO" + TVar_readIO -> "TVar.readIO" + TVar_swap -> "TVar.swap" + STM_retry -> "STM.retry" + Promise_new -> "Promise.new" + Promise_read -> "Promise.read" + Promise_tryRead -> "Promise.tryRead" + Promise_write -> "Promise.write" + Tls_newClient_impl_v3 -> "Tls.newClient.impl.v3" + Tls_newServer_impl_v3 -> "Tls.newServer.impl.v3" + Tls_handshake_impl_v3 -> "Tls.handshake.impl.v3" + Tls_send_impl_v3 -> "Tls.send.impl.v3" + Tls_decodeCert_impl_v3 -> "Tls.decodeCert.impl.v3" + Tls_encodeCert -> "Tls.encodeCert" + Tls_decodePrivateKey -> "Tls.decodePrivateKey" + Tls_encodePrivateKey -> "Tls.encodePrivateKey" + Tls_receive_impl_v3 -> "Tls.receive.impl.v3" + Tls_terminate_impl_v3 -> "Tls.terminate.impl.v3" + Code_validateLinks -> "Code.validateLinks" + Code_dependencies -> "Code.dependencies" + Code_serialize -> "Code.serialize" + Code_deserialize -> "Code.deserialize" + Code_display -> "Code.display" + Value_dependencies -> "Value.dependencies" + Value_serialize -> "Value.serialize" + Value_deserialize -> "Value.deserialize" + Crypto_HashAlgorithm_Sha3_512 -> "crypto.HashAlgorithm.Sha3_512" + Crypto_HashAlgorithm_Sha3_256 -> "crypto.HashAlgorithm.Sha3_256" + Crypto_HashAlgorithm_Sha2_512 -> "crypto.HashAlgorithm.Sha2_512" + Crypto_HashAlgorithm_Sha2_256 -> "crypto.HashAlgorithm.Sha2_256" + Crypto_HashAlgorithm_Sha1 -> "crypto.HashAlgorithm.Sha1" + Crypto_HashAlgorithm_Blake2b_512 -> "crypto.HashAlgorithm.Blake2b_512" + Crypto_HashAlgorithm_Blake2b_256 -> "crypto.HashAlgorithm.Blake2b_256" + Crypto_HashAlgorithm_Blake2s_256 -> "crypto.HashAlgorithm.Blake2s_256" + Crypto_HashAlgorithm_Md5 -> "crypto.HashAlgorithm.Md5" + Crypto_hashBytes -> "crypto.hashBytes" + Crypto_hmacBytes -> "crypto.hmacBytes" + Crypto_hash -> "crypto.hash" + Crypto_hmac -> "crypto.hmac" + Crypto_Ed25519_sign_impl -> "crypto.Ed25519.sign.impl" + Crypto_Ed25519_verify_impl -> "crypto.Ed25519.verify.impl" + Crypto_Rsa_sign_impl -> "crypto.Rsa.sign.impl" + Crypto_Rsa_verify_impl -> "crypto.Rsa.verify.impl" + Universal_murmurHash -> "Universal.murmurHash" + IO_randomBytes -> "IO.randomBytes" + Bytes_zlib_compress -> "Bytes.zlib.compress" + Bytes_gzip_compress -> "Bytes.gzip.compress" + Bytes_zlib_decompress -> "Bytes.zlib.decompress" + Bytes_gzip_decompress -> "Bytes.gzip.decompress" + Bytes_toBase16 -> "Bytes.toBase16" + Bytes_toBase32 -> "Bytes.toBase32" + Bytes_toBase64 -> "Bytes.toBase64" + Bytes_toBase64UrlUnpadded -> "Bytes.toBase64UrlUnpadded" + Bytes_fromBase16 -> "Bytes.fromBase16" + Bytes_fromBase32 -> "Bytes.fromBase32" + Bytes_fromBase64 -> "Bytes.fromBase64" + Bytes_fromBase64UrlUnpadded -> "Bytes.fromBase64UrlUnpadded" + Bytes_decodeNat64be -> "Bytes.decodeNat64be" + Bytes_decodeNat64le -> "Bytes.decodeNat64le" + Bytes_decodeNat32be -> "Bytes.decodeNat32be" + Bytes_decodeNat32le -> "Bytes.decodeNat32le" + Bytes_decodeNat16be -> "Bytes.decodeNat16be" + Bytes_decodeNat16le -> "Bytes.decodeNat16le" + Bytes_encodeNat64be -> "Bytes.encodeNat64be" + Bytes_encodeNat64le -> "Bytes.encodeNat64le" + Bytes_encodeNat32be -> "Bytes.encodeNat32be" + Bytes_encodeNat32le -> "Bytes.encodeNat32le" + Bytes_encodeNat16be -> "Bytes.encodeNat16be" + Bytes_encodeNat16le -> "Bytes.encodeNat16le" + MutableArray_copyTo_force -> "MutableArray.copyTo!" + MutableByteArray_copyTo_force -> "MutableByteArray.copyTo!" + ImmutableArray_copyTo_force -> "ImmutableArray.copyTo!" + ImmutableArray_size -> "ImmutableArray.size" + MutableArray_size -> "MutableArray.size" + ImmutableByteArray_size -> "ImmutableByteArray.size" + MutableByteArray_size -> "MutableByteArray.size" + ImmutableByteArray_copyTo_force -> "ImmutableByteArray.copyTo!" + MutableArray_read -> "MutableArray.read" + MutableByteArray_read8 -> "MutableByteArray.read8" + MutableByteArray_read16be -> "MutableByteArray.read16be" + MutableByteArray_read24be -> "MutableByteArray.read24be" + MutableByteArray_read32be -> "MutableByteArray.read32be" + MutableByteArray_read40be -> "MutableByteArray.read40be" + MutableByteArray_read64be -> "MutableByteArray.read64be" + MutableArray_write -> "MutableArray.write" + MutableByteArray_write8 -> "MutableByteArray.write8" + MutableByteArray_write16be -> "MutableByteArray.write16be" + MutableByteArray_write32be -> "MutableByteArray.write32be" + MutableByteArray_write64be -> "MutableByteArray.write64be" + ImmutableArray_read -> "ImmutableArray.read" + ImmutableByteArray_read8 -> "ImmutableByteArray.read8" + ImmutableByteArray_read16be -> "ImmutableByteArray.read16be" + ImmutableByteArray_read24be -> "ImmutableByteArray.read24be" + ImmutableByteArray_read32be -> "ImmutableByteArray.read32be" + ImmutableByteArray_read40be -> "ImmutableByteArray.read40be" + ImmutableByteArray_read64be -> "ImmutableByteArray.read64be" + MutableByteArray_freeze_force -> "MutableByteArray.freeze!" + MutableArray_freeze_force -> "MutableArray.freeze!" + MutableByteArray_freeze -> "MutableByteArray.freeze" + MutableArray_freeze -> "MutableArray.freeze" + MutableByteArray_length -> "MutableByteArray.length" + ImmutableByteArray_length -> "ImmutableByteArray.length" + IO_array -> "IO.array" + IO_arrayOf -> "IO.arrayOf" + IO_bytearray -> "IO.bytearray" + IO_bytearrayOf -> "IO.bytearrayOf" + Scope_array -> "Scope.array" + Scope_arrayOf -> "Scope.arrayOf" + Scope_bytearray -> "Scope.bytearray" + Scope_bytearrayOf -> "Scope.bytearrayOf" + Text_patterns_literal -> "Text.patterns.literal" + Text_patterns_digit -> "Text.patterns.digit" + Text_patterns_letter -> "Text.patterns.letter" + Text_patterns_space -> "Text.patterns.space" + Text_patterns_punctuation -> "Text.patterns.punctuation" + Text_patterns_anyChar -> "Text.patterns.anyChar" + Text_patterns_eof -> "Text.patterns.eof" + Text_patterns_charRange -> "Text.patterns.charRange" + Text_patterns_notCharRange -> "Text.patterns.notCharRange" + Text_patterns_charIn -> "Text.patterns.charIn" + Text_patterns_notCharIn -> "Text.patterns.notCharIn" + Pattern_many -> "Pattern.many" + Pattern_many_corrected -> "Pattern.many.corrected" + Pattern_capture -> "Pattern.capture" + Pattern_captureAs -> "Pattern.captureAs" + Pattern_join -> "Pattern.join" + Pattern_or -> "Pattern.or" + Pattern_replicate -> "Pattern.replicate" + Pattern_run -> "Pattern.run" + Pattern_isMatch -> "Pattern.isMatch" + Char_Class_any -> "Char.Class.any" + Char_Class_not -> "Char.Class.not" + Char_Class_and -> "Char.Class.and" + Char_Class_or -> "Char.Class.or" + Char_Class_range -> "Char.Class.range" + Char_Class_anyOf -> "Char.Class.anyOf" + Char_Class_alphanumeric -> "Char.Class.alphanumeric" + Char_Class_upper -> "Char.Class.upper" + Char_Class_lower -> "Char.Class.lower" + Char_Class_whitespace -> "Char.Class.whitespace" + Char_Class_control -> "Char.Class.control" + Char_Class_printable -> "Char.Class.printable" + Char_Class_mark -> "Char.Class.mark" + Char_Class_number -> "Char.Class.number" + Char_Class_punctuation -> "Char.Class.punctuation" + Char_Class_symbol -> "Char.Class.symbol" + Char_Class_separator -> "Char.Class.separator" + Char_Class_letter -> "Char.Class.letter" + Char_Class_is -> "Char.Class.is" + Text_patterns_char -> "Text.patterns.char" diff --git a/parser-typechecker/src/Unison/Runtime/IOSource.hs b/unison-runtime/src/Unison/Runtime/IOSource.hs similarity index 99% rename from parser-typechecker/src/Unison/Runtime/IOSource.hs rename to unison-runtime/src/Unison/Runtime/IOSource.hs index 4848851f89..f690671fc5 100644 --- a/parser-typechecker/src/Unison/Runtime/IOSource.hs +++ b/unison-runtime/src/Unison/Runtime/IOSource.hs @@ -41,7 +41,9 @@ parsingEnv = Parser.ParsingEnv { uniqueNames = mempty, uniqueTypeGuid = \_ -> pure Nothing, - names = Builtin.names + names = Builtin.names, + maybeNamespace = Nothing, + localNamespacePrefixedTypesAndConstructors = mempty } typecheckingEnv :: Typechecker.Env Symbol Ann diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/unison-runtime/src/Unison/Runtime/Interface.hs similarity index 78% rename from parser-typechecker/src/Unison/Runtime/Interface.hs rename to unison-runtime/src/Unison/Runtime/Interface.hs index 3b74b59e88..dfa54e01e4 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/unison-runtime/src/Unison/Runtime/Interface.hs @@ -6,6 +6,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} module Unison.Runtime.Interface ( startRuntime, @@ -13,18 +14,25 @@ module Unison.Runtime.Interface startNativeRuntime, standalone, runStandalone, - StoredCache, + StoredCache + ( -- Exported for tests + SCache + ), decodeStandalone, RuntimeHost (..), Runtime (..), + + -- * Exported for tests + getStoredCache, + putStoredCache, ) where import Control.Concurrent.STM as STM import Control.Exception (throwIO) import Control.Monad +import Control.Monad.State import Data.Binary.Get (runGetOrFail) --- import Data.Bits (shiftL) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL import Data.Bytes.Get (MonadGet, getWord8, runGetS) @@ -46,6 +54,7 @@ import Data.Set as Set ) import Data.Set qualified as Set import Data.Text as Text (isPrefixOf, pack, unpack) +import Data.Void (absurd) import GHC.IO.Exception (IOErrorType (NoSuchThing, OtherError, PermissionDenied), IOException (ioe_description, ioe_type)) import GHC.Stack (callStack) import Network.Simple.TCP (Socket, acceptFork, listen, recv, send) @@ -69,10 +78,11 @@ import System.Process waitForProcess, withCreateProcess, ) +import Unison.ABT qualified as ABT import Unison.Builtin.Decls qualified as RF import Unison.Codebase.CodeLookup (CodeLookup (..)) import Unison.Codebase.MainTerm (builtinIOTestTypes, builtinMain) -import Unison.Codebase.Runtime (Error, Runtime (..)) +import Unison.Codebase.Runtime (CompileOpts (..), Error, Runtime (..)) import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) import Unison.ConstructorReference qualified as RF import Unison.DataDeclaration (Decl, declFields, declTypeDependencies) @@ -98,19 +108,23 @@ import Unison.Runtime.Decompile import Unison.Runtime.Exception import Unison.Runtime.MCode ( Args (..), - Combs, - Instr (..), + CombIx (..), + GInstr (..), + GSection (..), + RCombs, RefNums (..), - Section (..), - combDeps, + absurdCombs, combTypes, emitComb, emptyRNs, + resolveCombs, + sanitizeCombsOfForeignFuncs, ) import Unison.Runtime.MCode.Serialize import Unison.Runtime.Machine ( ActiveThreads, CCache (..), + Combs, Tracer (..), apply0, baseCCache, @@ -118,11 +132,13 @@ import Unison.Runtime.Machine cacheAdd0, eval0, expandSandbox, + preEvalTopLevelConstants, refLookup, refNumTm, refNumsTm, refNumsTy, reifyValue, + resolveSection, ) import Unison.Runtime.Pattern import Unison.Runtime.Serialize as SER @@ -132,28 +148,45 @@ import Unison.Syntax.HashQualified qualified as HQ (toText) import Unison.Syntax.NamePrinter (prettyHashQualified) import Unison.Syntax.TermPrinter import Unison.Term qualified as Tm +import Unison.Type qualified as Type import Unison.Util.EnumContainers as EC +import Unison.Util.Monoid (foldMapM) import Unison.Util.Pretty as P +import Unison.Util.Recursion qualified as Rec import UnliftIO qualified import UnliftIO.Concurrent qualified as UnliftIO type Term v = Tm.Term v () -data Remapping = Remap - { remap :: Map.Map Reference Reference, - backmap :: Map.Map Reference Reference +type Type v = Type.Type v () + +-- Note that these annotations are suggestions at best, since in many places codebase refs, intermediate refs, and +-- floated refs are all intermingled. +type CodebaseReference = Reference + +-- Note that these annotations are suggestions at best, since in many places codebase refs, intermediate refs, and +-- floated refs are all intermingled. +type IntermediateReference = Reference + +-- Note that these annotations are suggestions at best, since in many places codebase refs, intermediate refs, and +-- floated refs are all intermingled. +type FloatedReference = Reference + +data Remapping from to = Remap + { remap :: Map.Map from to, + backmap :: Map.Map to from } -instance Semigroup Remapping where +instance (Ord from, Ord to) => Semigroup (Remapping from to) where Remap r1 b1 <> Remap r2 b2 = Remap (r1 <> r2) (b1 <> b2) -instance Monoid Remapping where +instance (Ord from, Ord to) => Monoid (Remapping from to) where mempty = Remap mempty mempty data EvalCtx = ECtx { dspec :: DataSpec, - floatRemap :: Remapping, - intermedRemap :: Remapping, + floatRemap :: Remapping CodebaseReference FloatedReference, + intermedRemap :: Remapping FloatedReference IntermediateReference, decompTm :: Map.Map Reference (Map.Map Word64 (Term Symbol)), ccache :: CCache } @@ -195,23 +228,26 @@ allocType ctx r cons = pure $ ctx {dspec = Map.insert r cons $ dspec ctx} recursiveDeclDeps :: - Set RF.LabeledDependency -> CodeLookup Symbol IO () -> Decl Symbol () -> -- (type deps, term deps) - IO (Set Reference, Set Reference) -recursiveDeclDeps seen0 cl d = do - rec <- for (toList newDeps) $ \case - RF.DerivedId i -> - getTypeDeclaration cl i >>= \case - Just d -> recursiveDeclDeps seen cl d - Nothing -> pure mempty - _ -> pure mempty - pure $ (deps, mempty) <> fold rec + StateT (Set RF.LabeledDependency) IO (Set Reference, Set Reference) +recursiveDeclDeps cl d = do + seen0 <- get + let seen = seen0 <> Set.map RF.typeRef deps + put seen + let newDeps = Set.filter (\r -> notMember (RF.typeRef r) seen0) deps + rec <- + (toList newDeps) & foldMapM \r -> do + case r of + RF.DerivedId i -> + lift (getTypeDeclaration cl i) >>= \case + Just d -> recursiveDeclDeps cl d + Nothing -> pure mempty + _ -> pure mempty + pure $ (deps, mempty) <> rec where deps = declTypeDependencies d - newDeps = Set.filter (\r -> notMember (RF.typeRef r) seen0) deps - seen = seen0 <> Set.map RF.typeRef deps categorize :: RF.LabeledDependency -> (Set Reference, Set Reference) categorize = @@ -221,37 +257,39 @@ categorize = RF.TermReference ref -> (mempty, Set.singleton ref) recursiveTermDeps :: - Set RF.LabeledDependency -> CodeLookup Symbol IO () -> Term Symbol -> -- (type deps, term deps) - IO (Set Reference, Set Reference) -recursiveTermDeps seen0 cl tm = do - rec <- for (toList (deps \\ seen0)) $ \case - RF.ConReference (RF.ConstructorReference (RF.DerivedId refId) _conId) _conType -> handleTypeReferenceId refId - RF.TypeReference (RF.DerivedId refId) -> handleTypeReferenceId refId - RF.TermReference r -> recursiveRefDeps seen cl r - _ -> pure mempty - pure $ foldMap categorize deps <> fold rec + StateT (Set RF.LabeledDependency) IO (Set Reference, Set Reference) +recursiveTermDeps cl tm = do + seen0 <- get + let seen = seen0 <> deps + put seen + rec <- + (toList (deps \\ seen0)) & foldMapM \r -> + case r of + RF.ConReference (RF.ConstructorReference (RF.DerivedId refId) _conId) _conType -> handleTypeReferenceId refId + RF.TypeReference (RF.DerivedId refId) -> handleTypeReferenceId refId + RF.TermReference r -> recursiveRefDeps cl r + _ -> pure mempty + pure $ foldMap categorize deps <> rec where - handleTypeReferenceId :: RF.Id -> IO (Set Reference, Set Reference) + handleTypeReferenceId :: RF.Id -> StateT (Set RF.LabeledDependency) IO (Set Reference, Set Reference) handleTypeReferenceId refId = - getTypeDeclaration cl refId >>= \case - Just d -> recursiveDeclDeps seen cl d + lift (getTypeDeclaration cl refId) >>= \case + Just d -> recursiveDeclDeps cl d Nothing -> pure mempty deps = Tm.labeledDependencies tm - seen = seen0 <> deps recursiveRefDeps :: - Set RF.LabeledDependency -> CodeLookup Symbol IO () -> Reference -> - IO (Set Reference, Set Reference) -recursiveRefDeps seen cl (RF.DerivedId i) = - getTerm cl i >>= \case - Just tm -> recursiveTermDeps seen cl tm + StateT (Set RF.LabeledDependency) IO (Set Reference, Set Reference) +recursiveRefDeps cl (RF.DerivedId i) = + lift (getTerm cl i) >>= \case + Just tm -> recursiveTermDeps cl tm Nothing -> pure mempty -recursiveRefDeps _ _ _ = pure mempty +recursiveRefDeps _ _ = pure mempty recursiveIRefDeps :: Map.Map Reference (SuperGroup Symbol) -> @@ -289,8 +327,8 @@ collectDeps :: Term Symbol -> IO ([(Reference, Either [Int] [Int])], [Reference]) collectDeps cl tm = do - (tys, tms) <- recursiveTermDeps mempty cl tm - (,toList tms) <$> traverse getDecl (toList tys) + (tys, tms) <- evalStateT (recursiveTermDeps cl tm) mempty + (,toList tms) <$> (traverse getDecl (toList tys)) where getDecl ty@(RF.DerivedId i) = (ty,) . maybe (Right []) declFields @@ -313,7 +351,7 @@ backrefAdd :: backrefAdd m ctx@ECtx {decompTm} = ctx {decompTm = m <> decompTm} -remapAdd :: Map.Map Reference Reference -> Remapping -> Remapping +remapAdd :: (Ord from, Ord to) => Map.Map from to -> Remapping from to -> Remapping from to remapAdd m Remap {remap, backmap} = Remap {remap = m <> remap, backmap = tm <> backmap} where @@ -327,31 +365,31 @@ intermedRemapAdd :: Map.Map Reference Reference -> EvalCtx -> EvalCtx intermedRemapAdd m ctx@ECtx {intermedRemap} = ctx {intermedRemap = remapAdd m intermedRemap} -baseToIntermed :: EvalCtx -> Reference -> Maybe Reference +baseToIntermed :: EvalCtx -> CodebaseReference -> Maybe IntermediateReference baseToIntermed ctx r = do r <- Map.lookup r . remap $ floatRemap ctx Map.lookup r . remap $ intermedRemap ctx -- Runs references through the forward maps to get intermediate -- references. Works on both base and floated references. -toIntermed :: EvalCtx -> Reference -> Reference +toIntermed :: EvalCtx -> Reference -> IntermediateReference toIntermed ctx r | r <- Map.findWithDefault r r . remap $ floatRemap ctx, Just r <- Map.lookup r . remap $ intermedRemap ctx = r toIntermed _ r = r -floatToIntermed :: EvalCtx -> Reference -> Maybe Reference +floatToIntermed :: EvalCtx -> FloatedReference -> Maybe IntermediateReference floatToIntermed ctx r = Map.lookup r . remap $ intermedRemap ctx -intermedToBase :: EvalCtx -> Reference -> Maybe Reference +intermedToBase :: EvalCtx -> IntermediateReference -> Maybe CodebaseReference intermedToBase ctx r = do r <- Map.lookup r . backmap $ intermedRemap ctx Map.lookup r . backmap $ floatRemap ctx -- Runs references through the backmaps with defaults at all steps. -backmapRef :: EvalCtx -> Reference -> Reference +backmapRef :: EvalCtx -> Reference -> CodebaseReference backmapRef ctx r0 = r2 where r1 = Map.findWithDefault r0 r0 . backmap $ intermedRemap ctx @@ -417,7 +455,7 @@ loadDeps :: EvalCtx -> [(Reference, Either [Int] [Int])] -> [Reference] -> - IO (EvalCtx, [(Reference, SuperGroup Symbol)]) + IO (EvalCtx, [(Reference, Code)]) loadDeps cl ppe ctx tyrs tmrs = do let cc = ccache ctx sand <- readTVarIO (sandbox cc) @@ -429,22 +467,52 @@ loadDeps cl ppe ctx tyrs tmrs = do _ -> False ctx <- foldM (uncurry . allocType) ctx $ Prelude.filter p tyrs let tyAdd = Set.fromList $ fst <$> tyrs - out@(_, rgrp) <- loadCode cl ppe ctx tmrs - out <$ cacheAdd0 tyAdd rgrp (expandSandbox sand rgrp) cc + (ctx', rgrp) <- loadCode cl ppe ctx tmrs + crgrp <- traverse (checkCacheability cl ctx') rgrp + (ctx', crgrp) <$ cacheAdd0 tyAdd crgrp (expandSandbox sand rgrp) cc -compileValue :: Reference -> [(Reference, SuperGroup Symbol)] -> Value +checkCacheability :: + CodeLookup Symbol IO () -> + EvalCtx -> + (IntermediateReference, SuperGroup Symbol) -> + IO (IntermediateReference, Code) +checkCacheability cl ctx (r, sg) = + getTermType codebaseRef >>= \case + -- A term's result is cacheable iff it has no arrows in its type, + -- this is sufficient since top-level definitions can't have effects without a delay. + Just typ + | not (Rec.cata hasArrows typ) -> + pure (r, CodeRep sg Cacheable) + _ -> pure (r, CodeRep sg Uncacheable) + where + codebaseRef = backmapRef ctx r + getTermType :: CodebaseReference -> IO (Maybe (Type Symbol)) + getTermType = \case + (RF.DerivedId i) -> + getTypeOfTerm cl i >>= \case + Just t -> pure $ Just t + Nothing -> pure Nothing + RF.Builtin {} -> pure $ Nothing + hasArrows :: Type.TypeF v a Bool -> Bool + hasArrows abt = case ABT.out' abt of + (ABT.Tm f) -> case f of + Type.Arrow _ _ -> True + other -> or other + t -> or t + +compileValue :: Reference -> [(Reference, Code)] -> Value compileValue base = flip pair (rf base) . ANF.BLit . List . Seq.fromList . fmap cpair where rf = ANF.BLit . TmLink . RF.Ref - cons x y = Data RF.pairRef 0 [] [x, y] - tt = Data RF.unitRef 0 [] [] + cons x y = Data RF.pairRef 0 [x, y] + tt = Data RF.unitRef 0 [] code sg = ANF.BLit (Code sg) pair x y = cons x (cons y tt) cpair (r, sg) = pair (rf r) (code sg) decompileCtx :: - EnumMap Word64 Reference -> EvalCtx -> Closure -> DecompResult Symbol + EnumMap Word64 Reference -> EvalCtx -> Val -> DecompResult Symbol decompileCtx crs ctx = decompile ib $ backReferenceTm crs fr ir dt where ib = intermedToBase ctx @@ -497,7 +565,7 @@ interpEval activeThreads cleanupThreads ctxVar cl ppe tm = evalInContext ppe ctx activeThreads initw `UnliftIO.finally` cleanupThreads -ensureExists :: HasCallStack => CreateProcess -> (CmdSpec -> Either (Int, String, String) IOException -> Pretty ColorText) -> IO () +ensureExists :: (HasCallStack) => CreateProcess -> (CmdSpec -> Either (Int, String, String) IOException -> Pretty ColorText) -> IO () ensureExists cmd err = ccall >>= \case Nothing -> pure () @@ -509,13 +577,13 @@ ensureExists cmd err = (ExitFailure exitCode, stdout, stderr) -> pure (Just (Left (exitCode, stdout, stderr))) ccall = call `UnliftIO.catch` \(e :: IOException) -> pure . Just $ Right e -ensureRuntimeExists :: HasCallStack => FilePath -> IO () +ensureRuntimeExists :: (HasCallStack) => FilePath -> IO () ensureRuntimeExists executable = ensureExists cmd runtimeErrMsg where cmd = proc executable ["--help"] -ensureRacoExists :: HasCallStack => IO () +ensureRacoExists :: (HasCallStack) => IO () ensureRacoExists = ensureExists (shell "raco help") racoErrMsg prettyCmdSpec :: CmdSpec -> Pretty ColorText @@ -624,38 +692,41 @@ racoErrMsg c = \case nativeCompile :: FilePath -> IORef EvalCtx -> + CompileOpts -> CodeLookup Symbol IO () -> PrettyPrintEnv -> Reference -> FilePath -> IO (Maybe Error) -nativeCompile executable ctxVar cl ppe base path = tryM $ do +nativeCompile executable ctxVar copts cl ppe base path = tryM $ do ctx <- readIORef ctxVar (tyrs, tmrs) <- collectRefDeps cl base (ctx, codes) <- loadDeps cl ppe ctx tyrs tmrs Just ibase <- pure $ baseToIntermed ctx base - nativeCompileCodes executable codes ibase path + nativeCompileCodes copts executable codes ibase path interpCompile :: Text -> IORef EvalCtx -> + CompileOpts -> CodeLookup Symbol IO () -> PrettyPrintEnv -> Reference -> FilePath -> IO (Maybe Error) -interpCompile version ctxVar cl ppe rf path = tryM $ do +interpCompile version ctxVar _copts cl ppe rf path = tryM $ do ctx <- readIORef ctxVar (tyrs, tmrs) <- collectRefDeps cl rf (ctx, _) <- loadDeps cl ppe ctx tyrs tmrs let cc = ccache ctx lk m = flip Map.lookup m =<< baseToIntermed ctx rf Just w <- lk <$> readTVarIO (refTm cc) + let combIx = CIx rf w 0 sto <- standalone cc w BL.writeFile path . runPutL $ do serialize $ version serialize $ RF.showShort 8 rf - putNat w + putCombIx combIx putStoredCache sto backrefLifted :: @@ -765,34 +836,36 @@ prepareEvaluation :: PrettyPrintEnv -> Term Symbol -> EvalCtx -> - IO (EvalCtx, [(Reference, SuperGroup Symbol)], Reference) + IO (EvalCtx, [(Reference, Code)], Reference) prepareEvaluation ppe tm ctx = do - missing <- cacheAdd rgrp (ccache ctx') + missing <- cacheAdd rcode (ccache ctx') when (not . null $ missing) . fail $ reportBug "E029347" $ "Error in prepareEvaluation, cache is missing: " <> show missing - pure (backrefAdd rbkr ctx', rgrp, rmn) + pure (backrefAdd rbkr ctx', rcode, rmn) where + uncacheable g = CodeRep g Uncacheable (rmn0, frem, rgrp0, rbkr) = intermediateTerm ppe ctx tm int b r | b || Map.member r rgrp0 = r | otherwise = toIntermed ctx r (ctx', rrefs, rgrp) = performRehash - ((fmap . overGroupLinks) int rgrp0) + ((fmap . overGroupLinks) int $ rgrp0) (floatRemapAdd frem ctx) + rcode = second uncacheable <$> rgrp rmn = case Map.lookup rmn0 rrefs of Just r -> r Nothing -> error "prepareEvaluation: could not remap main ref" -watchHook :: IORef Closure -> Stack 'UN -> Stack 'BX -> IO () -watchHook r _ bstk = peek bstk >>= writeIORef r +watchHook :: IORef Val -> XStack -> IO () +watchHook r xstk = peek (packXStack xstk) >>= writeIORef r backReferenceTm :: EnumMap Word64 Reference -> - Remapping -> - Remapping -> - Map.Map Reference (Map.Map Word64 (Term Symbol)) -> + Remapping IntermediateReference CodebaseReference -> + Remapping FloatedReference IntermediateReference -> + Map.Map CodebaseReference (Map.Map Word64 (Term Symbol)) -> Word64 -> Word64 -> Maybe (Term Symbol) @@ -863,7 +936,7 @@ nativeEvalInContext :: EvalCtx -> Socket -> PortNumber -> - [(Reference, SuperGroup Symbol)] -> + [(Reference, Code)] -> Reference -> IO (Either Error ([Error], Term Symbol)) nativeEvalInContext executable ppe ctx serv port codes base = do @@ -913,12 +986,13 @@ nativeEvalInContext executable ppe ctx serv port codes base = do `UnliftIO.catch` ucrError nativeCompileCodes :: + CompileOpts -> FilePath -> - [(Reference, SuperGroup Symbol)] -> + [(Reference, Code)] -> Reference -> FilePath -> IO () -nativeCompileCodes executable codes base path = do +nativeCompileCodes copts executable codes base path = do ensureRuntimeExists executable ensureRacoExists genDir <- getXdgDirectory XdgCache "unisonlanguage/racket-tmp" @@ -936,7 +1010,11 @@ nativeCompileCodes executable codes base path = do throwIO $ PE callStack (runtimeErrMsg (cmdspec p) (Right e)) racoError (e :: IOException) = throwIO $ PE callStack (racoErrMsg (makeRacoCmd RawCommand) (Right e)) - p = ucrCompileProc executable ["-G", srcPath] + dargs = ["-G", srcPath] + pargs + | profile copts = "--profile" : dargs + | otherwise = dargs + p = ucrCompileProc executable pargs makeRacoCmd :: (FilePath -> [String] -> a) -> a makeRacoCmd f = f "raco" ["exe", "-o", path, srcPath] withCreateProcess p callout @@ -951,7 +1029,7 @@ evalInContext :: Word64 -> IO (Either Error ([Error], Term Symbol)) evalInContext ppe ctx activeThreads w = do - r <- newIORef BlackHole + r <- newIORef (boxedVal BlackHole) crs <- readTVarIO (combRefs $ ccache ctx) let hook = watchHook r decom = decompileCtx crs ctx @@ -963,14 +1041,14 @@ evalInContext ppe ctx activeThreads w = do where tr = first (backmapRef ctx) <$> tr0 - debugText fancy c = case decom c of + debugText fancy val = case decom val of (errs, dv) | null errs -> SimpleTrace . debugTextFormat fancy $ pretty ppe dv | otherwise -> MsgTrace (debugTextFormat fancy $ tabulateErrors errs) - (show c) + (show val) (debugTextFormat fancy $ pretty ppe dv) result <- @@ -981,15 +1059,13 @@ evalInContext ppe ctx activeThreads w = do pure $ finish result executeMainComb :: - Word64 -> + CombIx -> CCache -> IO (Either (Pretty ColorText) ()) executeMainComb init cc = do + rSection <- resolveSection cc $ Ins (Pack RF.unitRef (PackedTag 0) ZArgs) $ Call True init init (VArg1 0) result <- - UnliftIO.try - . eval0 cc Nothing - . Ins (Pack RF.unitRef 0 ZArgs) - $ Call True init (BArg1 0) + UnliftIO.try . eval0 cc Nothing $ rSection case result of Left err -> Left <$> formatErr err Right () -> pure (Right ()) @@ -1111,7 +1187,7 @@ catchInternalErrors sub = sub `UnliftIO.catch` hCE `UnliftIO.catch` hRE decodeStandalone :: BL.ByteString -> - Either String (Text, Text, Word64, StoredCache) + Either String (Text, Text, CombIx, StoredCache) decodeStandalone b = bimap thd thd $ runGetOrFail g b where thd (_, _, x) = x @@ -1119,7 +1195,7 @@ decodeStandalone b = bimap thd thd $ runGetOrFail g b (,,,) <$> deserialize <*> deserialize - <*> getNat + <*> getCombIx <*> getStoredCache -- | Whether the runtime is hosted within a persistent session or as a one-off process. @@ -1178,14 +1254,17 @@ tryM = hRE (PE _ e) = pure $ Just e hRE (BU _ _ _) = pure $ Just "impossible" -runStandalone :: StoredCache -> Word64 -> IO (Either (Pretty ColorText) ()) -runStandalone sc init = - restoreCache sc >>= executeMainComb init +runStandalone :: Bool -> StoredCache -> CombIx -> IO (Either (Pretty ColorText) ()) +runStandalone sandboxed sc init = + restoreCache sandboxed sc >>= executeMainComb init +-- | A version of the Code Cache designed to be serialized to disk as +-- standalone bytecode. data StoredCache = SCache (EnumMap Word64 Combs) (EnumMap Word64 Reference) + (EnumSet Word64) (EnumMap Word64 Reference) Word64 Word64 @@ -1193,12 +1272,13 @@ data StoredCache (Map Reference Word64) (Map Reference Word64) (Map Reference (Set Reference)) - deriving (Show) + deriving (Show, Eq) putStoredCache :: (MonadPut m) => StoredCache -> m () -putStoredCache (SCache cs crs trs ftm fty int rtm rty sbs) = do - putEnumMap putNat (putEnumMap putNat putComb) cs +putStoredCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do + putEnumMap putNat (putEnumMap putNat (putComb absurd)) cs putEnumMap putNat putReference crs + putEnumSet putNat cacheableCombs putEnumMap putNat putReference trs putNat ftm putNat fty @@ -1212,6 +1292,7 @@ getStoredCache = SCache <$> getEnumMap getNat (getEnumMap getNat getComb) <*> getEnumMap getNat getReference + <*> getEnumSet getNat <*> getEnumMap getNat getReference <*> getNat <*> getNat @@ -1237,18 +1318,34 @@ tabulateErrors errs = : P.wrap "The following errors occured while decompiling:" : (listErrors errs) -restoreCache :: StoredCache -> IO CCache -restoreCache (SCache cs crs trs ftm fty int rtm rty sbs) = - CCache builtinForeigns False debugText - <$> newTVarIO (cs <> combs) - <*> newTVarIO (crs <> builtinTermBackref) - <*> newTVarIO (trs <> builtinTypeBackref) - <*> newTVarIO ftm - <*> newTVarIO fty - <*> newTVarIO int - <*> newTVarIO (rtm <> builtinTermNumbering) - <*> newTVarIO (rty <> builtinTypeNumbering) - <*> newTVarIO (sbs <> baseSandboxInfo) +restoreCache :: Bool -> StoredCache -> IO CCache +restoreCache sandboxed (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do + cc <- + CCache sandboxed debugText + <$> newTVarIO srcCombs + <*> newTVarIO combs + <*> newTVarIO (crs <> builtinTermBackref) + <*> newTVarIO cacheableCombs + <*> newTVarIO (trs <> builtinTypeBackref) + <*> newTVarIO ftm + <*> newTVarIO fty + <*> newTVarIO int + <*> newTVarIO (rtm <> builtinTermNumbering) + <*> newTVarIO (rty <> builtinTypeNumbering) + <*> newTVarIO (sbs <> baseSandboxInfo) + let (unresolvedCacheableCombs, unresolvedNonCacheableCombs) = + srcCombs + & sanitizeCombsOfForeignFuncs sandboxed sandboxedForeignFuncs + & absurdCombs + & EC.mapToList + & foldMap + ( \(k, v) -> + if k `member` cacheableCombs + then (EC.mapSingleton k v, mempty) + else (mempty, EC.mapSingleton k v) + ) + preEvalTopLevelConstants unresolvedCacheableCombs unresolvedNonCacheableCombs cc + pure cc where decom = decompile @@ -1265,27 +1362,35 @@ restoreCache (SCache cs crs trs ftm fty int rtm rty sbs) = (debugTextFormat fancy $ pretty PPE.empty dv) rns = emptyRNs {dnum = refLookup "ty" builtinTypeNumbering} rf k = builtinTermBackref ! k + srcCombs :: EnumMap Word64 Combs + srcCombs = + let builtinCombs = mapWithKey (\k v -> emitComb @Symbol rns (rf k) k mempty (0, v)) numberedTermLookup + in builtinCombs <> cs + combs :: EnumMap Word64 (RCombs Val) combs = - mapWithKey - (\k v -> emitComb @Symbol rns (rf k) k mempty (0, v)) - numberedTermLookup + srcCombs + & sanitizeCombsOfForeignFuncs sandboxed sandboxedForeignFuncs + & absurdCombs + & resolveCombs Nothing traceNeeded :: - Word64 -> - EnumMap Word64 Combs -> - IO (EnumMap Word64 Combs) -traceNeeded init src = fmap (`withoutKeys` ks) $ go mempty init + Reference -> + Map Reference (SuperGroup Symbol) -> + IO (Map Reference (SuperGroup Symbol)) +traceNeeded init src = go mempty init where - ks = keysSet numberedTermLookup - go acc w - | hasKey w acc = pure acc - | Just co <- EC.lookup w src = - foldlM go (mapInsert w co acc) (foldMap combDeps co) - | otherwise = die $ "traceNeeded: unknown combinator: " ++ show w + go acc nx + | RF.isBuiltin nx = pure acc + | Map.member nx acc = pure acc + | Just co <- Map.lookup nx src = + foldlM go (Map.insert nx co acc) (groupTermLinks co) + | otherwise = + die $ "traceNeeded: unknown combinator: " ++ show nx buildSCache :: - EnumMap Word64 Combs -> EnumMap Word64 Reference -> + EnumMap Word64 Combs -> + EnumSet Word64 -> EnumMap Word64 Reference -> Word64 -> Word64 -> @@ -1294,26 +1399,39 @@ buildSCache :: Map Reference Word64 -> Map Reference (Set Reference) -> StoredCache -buildSCache cs crsrc trsrc ftm fty intsrc rtmsrc rtysrc sndbx = +buildSCache crsrc cssrc cacheableCombs trsrc ftm fty int rtmsrc rtysrc sndbx = SCache cs crs + cacheableCombs trs ftm fty - (restrictTmR intsrc) - (restrictTmR rtmsrc) + int + rtm (restrictTyR rtysrc) (restrictTmR sndbx) where - combKeys = keysSet cs + termRefs = Map.keysSet int + + -- Retain just the Reference->Word mappings for needed code + rtm :: Map Reference Word64 + rtm = restrictTmR rtmsrc + + -- Retain numbers that correspond to the above termRefs + combKeys :: EnumSet Word64 + combKeys = foldMap setSingleton rtm + crs = restrictTmW crsrc - termRefs = foldMap Set.singleton crs + + cs :: EnumMap Word64 Combs + cs = restrictTmW cssrc typeKeys = setFromList $ (foldMap . foldMap) combTypes cs trs = restrictTyW trsrc typeRefs = foldMap Set.singleton trs + restrictTmW :: EnumMap Word64 a -> EnumMap Word64 a restrictTmW m = restrictKeys m combKeys restrictTmR :: Map Reference a -> Map Reference a restrictTmR m = Map.restrictKeys m termRefs @@ -1322,14 +1440,18 @@ buildSCache cs crsrc trsrc ftm fty intsrc rtmsrc rtysrc sndbx = restrictTyR m = Map.restrictKeys m typeRefs standalone :: CCache -> Word64 -> IO StoredCache -standalone cc init = - buildSCache - <$> (readTVarIO (combs cc) >>= traceNeeded init) - <*> readTVarIO (combRefs cc) - <*> readTVarIO (tagRefs cc) - <*> readTVarIO (freshTm cc) - <*> readTVarIO (freshTy cc) - <*> readTVarIO (intermed cc) - <*> readTVarIO (refTm cc) - <*> readTVarIO (refTy cc) - <*> readTVarIO (sandbox cc) +standalone cc init = readTVarIO (combRefs cc) >>= \crs -> + case EC.lookup init crs of + Just rinit -> + buildSCache crs + <$> readTVarIO (srcCombs cc) + <*> readTVarIO (cacheableCombs cc) + <*> readTVarIO (tagRefs cc) + <*> readTVarIO (freshTm cc) + <*> readTVarIO (freshTy cc) + <*> (readTVarIO (intermed cc) >>= traceNeeded rinit) + <*> readTVarIO (refTm cc) + <*> readTVarIO (refTy cc) + <*> readTVarIO (sandbox cc) + Nothing -> + die $ "standalone: unknown combinator: " ++ show init diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs new file mode 100644 index 0000000000..bc40170db8 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -0,0 +1,1862 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Runtime.MCode + ( Args' (..), + Args (..), + RefNums (..), + MLit (..), + GInstr (..), + Instr, + RInstr, + GSection (.., MatchT, MatchW), + RSection, + Section, + GComb (.., Lam), + GCombInfo (..), + Comb, + RComb (..), + RCombInfo, + GCombs, + RCombs, + CombIx (..), + GRef (..), + RRef, + Ref, + UPrim1 (..), + UPrim2 (..), + BPrim1 (..), + BPrim2 (..), + GBranch (..), + Branch, + RBranch, + emitCombs, + emitComb, + resolveCombs, + sanitizeCombsOfForeignFuncs, + absurdCombs, + emptyRNs, + argsToLists, + countArgs, + combRef, + combDeps, + combTypes, + prettyCombs, + prettyComb, + ) +where + +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor, bimap, first) +import Data.Bitraversable (Bitraversable (..), bifoldMapDefault, bimapDefault) +import Data.Bits (shiftL, shiftR, (.|.)) +import Data.Coerce +import Data.Functor ((<&>)) +import Data.Map.Strict qualified as M +import Data.Primitive.PrimArray +import Data.Primitive.PrimArray qualified as PA +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Void (Void, absurd) +import Data.Word (Word16, Word64) +import GHC.Stack (HasCallStack) +import Unison.ABT.Normalized (pattern TAbss) +import Unison.Reference (Reference, showShort) +import Unison.Referent (Referent) +import Unison.Runtime.ANF + ( ANormal, + Branched (..), + CTag, + Direction (..), + Func (..), + Mem (..), + PackedTag (..), + SuperGroup (..), + SuperNormal (..), + internalBug, + packTags, + pattern TApp, + pattern TBLit, + pattern TFOp, + pattern TFrc, + pattern THnd, + pattern TLets, + pattern TLit, + pattern TMatch, + pattern TName, + pattern TPrm, + pattern TShift, + pattern TVar, + ) +import Unison.Runtime.ANF qualified as ANF +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..), foreignFuncBuiltinName) +import Unison.Util.EnumContainers as EC +import Unison.Util.Text (Text) +import Unison.Var (Var) + +-- This outlines some of the ideas/features in this core +-- language, and how they may be used to implement features of +-- the surface language. + +----------------------- +-- Delimited control -- +----------------------- + +-- There is native support for delimited control operations in +-- the core language. This means we can: +-- 1. delimit a block of code with an integer tagged prompt, +-- which corresponds to pushing a frame onto the +-- continuation with said tag +-- 2. capture a portion of the continuation up to a particular +-- tag frame and turn it into a value, which _removes_ the +-- tag frame from the continuation in the process +-- 3. push such a captured value back onto the continuation + +-- TBD: Since the captured continuations in _delimited_ control +-- are (in this case impure) functions, it may make sense to make +-- the representation of functions support these captured +-- continuations directly. + +-- The obvious use case of this feature is effects and handlers. +-- Delimiting a block with a prompt is part of installing a +-- handler for said block at least naively. The other part is +-- establishing the code that should be executed for each +-- operation to be handled. + +-- It's important (I believe) in #2 that the prompt be removed +-- from the continuation by a control effect. The captured +-- continuation not being automatically delimited corresponds to +-- a shallow handler's obligation to re-establish the handling of +-- a re-invoked computation if it wishes to do so. The delimiter +-- being removed from the capturing code's continuation +-- corresponds to a handler being allowed to yield effects from +-- the same siganture that it is handling. + +-- In special cases, it should be possible to omit use of control +-- effects in handlers. At the least, if a handler case resumes +-- the computation in tail position, it should be unnecessary to +-- capture the continuation at all. If all cases act this way, we +-- don't need a delimiter, because we will never capture. + +-- TBD: it may make more sense to have prompt pushing be part of +-- some other construct, due to A-normal forms of the code. + +----------------------------- +-- Unboxed sum-of-products -- +----------------------------- + +-- It is not usually stated this way, but one of the core +-- features of the STG machine is that functions/closures can +-- return unboxed sum-of-products types. This is actually the way +-- _all_ data types work in STG. The discriminee of a case +-- statement must eventually return by pushing several values +-- onto the stack (the product part) and specifying which branch +-- to return to (the sum part). + +-- The way heap allocated data is produced is that an +-- intermediate frame may be in the continuation that grabs this +-- information from the local storage and puts it into the heap. +-- If this frame were omitted, only the unboxed component would +-- be left. Also, in STG, the heap allocated data is just a means +-- of reconstructing its unboxed analogue. Evaluating a heap +-- allocated data type value just results in pushing its stored +-- fields back on the stack, and immediately returning the tag. + +-- The portion of this with the heap allocation frame omitted +-- seems to be a natural match for the case analysis portion of +-- handlers. A naive implementation of an effect algebra is as +-- the data type of the polynomial functor generated by the +-- signature, and handling corresponds to case analysis. However, +-- in a real implementation, we don't want a heap allocated +-- representation of this algebra, because its purpose is control +-- flow. Each operation will be handled once as it occurs, and we +-- won't save work by remembering some reified representation of +-- which operations were used. + +-- Since handlers in unison are written as functions, it seems to +-- make sense to define a calling convention for unboxed +-- sum-of-products as arguments. Variable numbers of stack +-- positions could be pushed for such arguments, with tags +-- specifying which case is being provided. + +-- TBD: sum arguments to a function correspond to a product of +-- functions, so it's possible that the calling convention for +-- these functions should be similar to returning to a case, +-- where we push arguments and then select which of several +-- pieces of code to jump to. This view also seems relevant to +-- the optimized implementation of certain forms of handler, +-- where we want effects to just directly select some code to +-- execute based on state that has been threaded to that point. + +-- One thing to note: it probably does not make sense to +-- completely divide returns into unboxed returns and allocation +-- frames. The reason this works in STG is laziness. Naming a +-- computation with `let` does not do any evaluation, but it does +-- allocate space for its (boxed) result. The only thing that +-- _does_ demand evaluation is case analysis. So, if a value with +-- sum type is being evaluated, we know it must be about to be +-- unpacked, and it makes little sense to pack it on the stack, +-- though we can build a closure version of it in the writeback +-- location established by `let`. + +-- By contrast, in unison a `let` of a sum type evaluates it +-- immediately, even if no one is analyzing it. So we might waste +-- work rearranging the stack with the unpacked contents when we +-- only needed the closure version to begin with. Instead, we +-- gain the ability to make the unpacking operation use no stack, +-- because we know what we are unpacking must be a value. Turning +-- boxed function calls into unboxed versions thus seems like a +-- situational optimization, rather than a universal calling +-- convention. + +------------------------------- +-- Delimited Dynamic Binding -- +------------------------------- + +-- There is a final component to the implementation of ability +-- handlers in this runtime system, and that is dynamically +-- scoped variables associated to each prompt. Each prompt +-- corresponds to an ability signature, and `reset` to a handler +-- for said signature, but we need storage space for the code +-- installed by said handler. It is possible to implement +-- dynamically scoped variables entirely with delimited +-- continuations, but it is more efficient to keep track of the +-- storage directly when manipulating the continuations. + +-- The dynamic scoping---and how it interacts with +-- continuations---corresponds to the nested structure of +-- handlers. Installing a handler establishes a variable scope, +-- shadowing outer scopes for the same prompt. Shifting, however, +-- can exit these scopes dynamically. So, for instance, if we +-- have a structure like: + +-- reset 0 $ ... +-- reset 1 $ ... +-- reset 0 $ ... +-- shift 1 + +-- We have nested scopes 0>1>0, with the second 0 shadowing the +-- first. However, when we shift to 1, the inner 0 scope is +-- captured into the continuation, and uses of the 0 ability in +-- will be handled by the outer handler until it is shadowed +-- again (and the captured continuation will re-establish the +-- shadowing). + +-- Mutation of the variables is possible, but mutation only +-- affects the current scope. Essentially, the dynamic scoping is +-- of mutable references, and when scope changes, we switch +-- between different references, and the mutation of each +-- reference does not affect the others. The purpose of the +-- mutation is to enable more efficient implementation of +-- certain recursive, 'deep' handlers, since those can operate +-- more like stateful code than control operators. + +data Sandboxed = Tracked | Untracked + deriving (Show, Eq, Ord) + +data Args' + = Arg1 !Int + | Arg2 !Int !Int + | -- frame index of each argument to the function + ArgN {-# UNPACK #-} !(PrimArray Int) + | ArgR !Int !Int + deriving (Show) + +data Args + = ZArgs + | VArg1 !Int + | VArg2 !Int !Int + | VArgR !Int !Int + | VArgN {-# UNPACK #-} !(PrimArray Int) + | VArgV !Int + deriving (Show, Eq, Ord) + +argsToLists :: Args -> [Int] +argsToLists = \case + ZArgs -> [] + VArg1 i -> [i] + VArg2 i j -> [i, j] + VArgR i l -> take l [i ..] + VArgN us -> primArrayToList us + VArgV _ -> internalBug "argsToLists: DArgV" +{-# INLINEABLE argsToLists #-} + +countArgs :: Args -> Int +countArgs ZArgs = 0 +countArgs (VArg1 {}) = 1 +countArgs (VArg2 {}) = 2 +countArgs (VArgR _ l) = l +countArgs (VArgN us) = sizeofPrimArray us +countArgs (VArgV {}) = internalBug "countArgs: DArgV" +{-# INLINEABLE countArgs #-} + +data UPrim1 + = -- integral + DECI -- decrement + | DECN + | INCI -- increment + | INCN + | NEGI -- negate + | SGNI -- signum + | LZRO -- leadingZeroes + | TZRO -- trailingZeroes + | COMN -- complement + | COMI -- complement + | POPC -- popCount + -- floating + | ABSF -- abs + | EXPF -- exp + | LOGF -- log + | SQRT -- sqrt + | COSF -- cos + | ACOS -- acos + | COSH -- cosh + | ACSH -- acosh + | SINF -- sin + | ASIN -- asin + | SINH -- sinh + | ASNH -- asinh + | TANF -- tan + | ATAN -- atan + | TANH -- tanh + | ATNH -- atanh + | ITOF -- intToFloat + | NTOF -- natToFloat + | CEIL -- ceiling + | FLOR -- floor + | TRNF -- truncate + | RNDF -- round + | TRNC -- truncate + -- Bools + | NOTB -- not + deriving (Show, Eq, Ord, Enum, Bounded) + +data UPrim2 + = -- integral + ADDI -- + + | ADDN + | SUBI -- - + | SUBN + | MULI + | MULN + | DIVI -- / + | DIVN + | MODI -- mod + | MODN + | SHLI -- shiftl + | SHLN + | SHRI -- shiftr + | SHRN + | POWI -- pow + | POWN + | EQLI -- == + | EQLN + | NEQI -- != + | NEQN + | LEQI -- <= + | LEQN + | LESI -- < + | LESN + | ANDN -- and + | ANDI + | IORN -- or + | IORI + | XORN -- xor + | XORI + | -- floating + EQLF -- == + | NEQF -- != + | LEQF -- <= + | LESF -- < + | ADDF -- + + | SUBF -- - + | MULF + | DIVF -- / + | ATN2 -- atan2 + | POWF -- pow + | LOGB -- logBase + | MAXF -- max + | MINF -- min + | CAST -- unboxed runtime type cast (int to nat, etc.) + | DRPN -- dropn + -- Bools + | ANDB -- and + | IORB -- or + deriving (Show, Eq, Ord, Enum, Bounded) + +data BPrim1 + = -- text + SIZT -- size + | USNC -- unsnoc + | UCNS -- uncons + | ITOT -- intToText + | NTOT -- natToText + | FTOT -- floatToText + | TTOI -- textToInt + | TTON -- textToNat + | TTOF -- textToFloat + | PAKT -- pack + | UPKT -- unpack + -- sequence + | VWLS -- viewl + | VWRS -- viewr + | SIZS -- size + | PAKB -- pack + | UPKB -- unpack + | SIZB -- size + | FLTB -- flatten + -- code + | MISS -- isMissing + | CACH -- cache + | LKUP -- lookup + | LOAD -- load + | CVLD -- validate + | VALU -- value + | TLTT -- Term.Link.toText + -- debug + | DBTX -- debug text + | SDBL -- sandbox link list + | -- Refs + REFN -- Ref.new + | REFR -- Ref.read + | RRFC + | TIKR + deriving (Show, Eq, Ord, Enum, Bounded) + +data BPrim2 + = -- universal + EQLU -- == + | CMPU -- compare + | LEQU -- <= + | LESU -- < + -- text + | DRPT -- drop + | CATT -- append + | TAKT -- take + | IXOT -- indexof + | EQLT -- == + | LEQT -- <= + | LEST -- < + -- sequence + | DRPS -- drop + | CATS -- append + | TAKS -- take + | CONS -- cons + | SNOC -- snoc + | IDXS -- index + | SPLL -- splitLeft + | SPLR -- splitRight + -- bytes + | TAKB -- take + | DRPB -- drop + | IDXB -- index + | CATB -- append + | IXOB -- indexof + -- general + | THRO -- throw + | TRCE -- trace + -- code + | SDBX -- sandbox + | SDBV -- sandbox Value + -- Refs + | REFW -- Ref.write + deriving (Show, Eq, Ord, Enum, Bounded) + +data MLit + = MI !Int + | MN !Word64 + | MC !Char + | MD !Double + | MT !Text + | MM !Referent -- Term Link + | MY !Reference -- Type Link + deriving (Show, Eq, Ord) + +type Instr = GInstr CombIx + +type RInstr val = GInstr (RComb val) + +-- Instructions for manipulating the data stack in the main portion of +-- a block +data GInstr comb + = -- 1-argument unboxed primitive operations + UPrim1 + !UPrim1 -- primitive instruction + !Int -- index of prim argument + | -- 2-argument unboxed primitive operations + UPrim2 + !UPrim2 -- primitive instruction + !Int -- index of first prim argument + !Int -- index of second prim argument + | -- 1-argument primitive operations that may involve boxed values + BPrim1 + !BPrim1 + !Int + | -- 2-argument primitive operations that may involve boxed values + BPrim2 + !BPrim2 + !Int + !Int + | -- Use a check-and-set ticket to update a reference + -- (ref stack index, ticket stack index, new value stack index) + RefCAS !Int !Int !Int + | -- Call out to a Haskell function. + ForeignCall + !Bool -- catch exceptions + !ForeignFunc -- FFI call + !Args -- arguments + | -- Set the value of a dynamic reference + SetDyn + !Word64 -- the prompt tag of the reference + !Int -- the stack index of the closure to store + | -- Capture the continuation up to a given marker. + Capture !Word64 -- the prompt tag + | -- This is essentially the opposite of `Call`. Pack a given + -- statically known function into a closure with arguments. + -- No stack is necessary, because no nested evaluation happens, + -- so the instruction directly takes a follow-up. + Name !(GRef comb) !Args + | -- Dump some debugging information about the machine state to + -- the screen. + Info !String -- prefix for output + | -- Pack a data type value into a closure and place it + -- on the stack. + Pack + !Reference -- data type reference + !PackedTag -- tag + !Args -- arguments to pack + | -- Push a particular value onto the appropriate stack + Lit !MLit -- value to push onto the stack + | -- Print a value on the unboxed stack + Print !Int -- index of the primitive value to print + | -- Put a delimiter on the continuation + Reset !(EnumSet Word64) -- prompt ids + | -- Fork thread evaluating delayed computation on boxed stack + Fork !Int + | -- Atomic transaction evaluating delayed computation on boxed stack + Atomically !Int + | -- Build a sequence consisting of a variable number of arguments + Seq !Args + | -- Force a delayed expression, catching any runtime exceptions involved + TryForce !Int + | -- Attempted to use a builtin that was not allowed in the current sandboxing context. + SandboxingFailure !Text.Text -- The name of the builtin which failed was sandboxed. + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) + +type Section = GSection CombIx + +type RSection val = GSection (RComb val) + +data GSection comb + = -- Apply a function to arguments. This is the 'slow path', and + -- handles applying functions from arbitrary sources. This + -- requires checks to determine what exactly should happen. + App + !Bool -- skip argument check for known calling convention + !(GRef comb) -- function to call + !Args -- arguments + | -- This is the 'fast path', for when we statically know we're + -- making an exactly saturated call to a statically known + -- function. This allows skipping various checks that can cost + -- time in very tight loops. This also allows skipping the + -- stack check if we know that the current stack allowance is + -- sufficient for where we're jumping to. + Call + !Bool -- skip stack check + !CombIx + {- Lazy! Might be cyclic -} comb + !Args -- arguments + | -- Jump to a captured continuation value. + Jump + !Int -- index of captured continuation + !Args -- arguments to send to continuation + | -- Branch on the value in the unboxed data stack + Match + !Int -- index of unboxed item to match on + !(GBranch comb) -- branches + | -- Yield control to the current continuation, with arguments + Yield !Args -- values to yield + | -- Prefix an instruction onto a section + Ins !(GInstr comb) !(GSection comb) + | -- Sequence two sections. The second is pushed as a return + -- point for the results of the first. Stack modifications in + -- the first are lost on return to the second. + -- + -- The stored CombIx is a combinator that contains the second + -- section, which can be used to reconstruct structures that + -- throw away the section, like serializable continuation values. + -- Code generation will emit the section as its own combinator, + -- but also include it directly here. + Let + !(GSection comb) -- binding + !CombIx -- body section refrence + !Int -- stack safety + !(GSection comb) -- body code + | -- Throw an exception with the given message + Die String + | -- Immediately stop a thread of interpretation. This is more of + -- a debugging tool than a proper operation to target. + Exit + | -- Branch on a data type without dumping the tag onto the unboxed + -- stack. + DMatch + !(Maybe Reference) -- expected data type + !Int -- index of data item on boxed stack + !(GBranch comb) -- branches + | -- Branch on a numeric type without dumping it to the stack + NMatch + !(Maybe Reference) -- expected data type + !Int -- index of data item on boxed stack + !(GBranch comb) -- branches + | -- Branch on a request representation without dumping the tag + -- portion to the unboxed stack. + RMatch + !Int -- index of request item on the boxed stack + !(GSection comb) -- pure case + !(EnumMap Word64 (GBranch comb)) -- effect cases + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) + +data CombIx + = CIx + !Reference -- top reference + !Word64 -- top level + !Word64 -- section + deriving (Eq, Ord, Show) + +combRef :: CombIx -> Reference +combRef (CIx r _ _) = r + +-- dnum maps type references to their number in the runtime +-- cnum maps combinator references to their number +-- anum maps combinator references to their main arity +data RefNums = RN + { dnum :: Reference -> Word64, + cnum :: Reference -> Word64, + anum :: Reference -> Maybe Int + } + +emptyRNs :: RefNums +emptyRNs = RN mt mt (const Nothing) + where + mt _ = internalBug "RefNums: empty" + +type Comb = GComb Void CombIx + +-- Actual information for a proper combinator. The GComb type is no +-- longer strictly a 'combinator.' +data GCombInfo comb + = LamI + !Int -- Number of arguments + !Int -- Maximum needed frame size + !(GSection comb) -- Entry + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) + +data GComb val comb + = Comb {-# UNPACK #-} !(GCombInfo comb) + | -- A pre-evaluated comb, typically a pure top-level const + CachedVal !Word64 {- top level comb ix -} !val + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) + +pattern Lam :: + Int -> Int -> GSection comb -> GComb val comb +pattern Lam a f sect = Comb (LamI a f sect) + +-- it seems GHC can't figure this out itself +{-# COMPLETE CachedVal, Lam #-} + +instance Bifunctor GComb where + bimap = bimapDefault + +instance Bifoldable GComb where + bifoldMap = bifoldMapDefault + +instance Bitraversable GComb where + bitraverse f _ (CachedVal cix c) = CachedVal cix <$> f c + bitraverse _ f (Lam a fr s) = Lam a fr <$> traverse f s + +type RCombs val = GCombs val (RComb val) + +-- | The fixed point of a GComb where all references to a Comb are themselves Combs. +newtype RComb val = RComb {unRComb :: GComb val (RComb val)} + +type RCombInfo val = GCombInfo (RComb val) + +instance Show (RComb val) where + show _ = "" + +-- | Map of combinators, parameterized by comb reference type +type GCombs val comb = EnumMap Word64 (GComb val comb) + +-- | A reference to a combinator, parameterized by comb +type Ref = GRef CombIx + +type RRef val = GRef (RComb val) + +data GRef comb + = Stk !Int -- stack reference to a closure + | Env !CombIx {- Lazy! Might be cyclic -} comb + | Dyn !Word64 -- dynamic scope reference to a closure + deriving (Show, Functor, Foldable, Traversable) + +instance Eq (GRef comb) where + a == b = compare a b == EQ + +instance Ord (GRef comb) where + compare (Stk a) (Stk b) = compare a b + compare (Stk {}) _ = LT + compare _ (Stk {}) = GT + compare (Env a _) (Env b _) = compare a b + compare (Env {}) _ = LT + compare _ (Env {}) = GT + compare (Dyn a) (Dyn b) = compare a b + +type Branch = GBranch CombIx + +type RBranch val = GBranch (RComb val) + +data GBranch comb + = -- if tag == n then t else f + Test1 + !Word64 + !(GSection comb) + !(GSection comb) + | Test2 + !Word64 + !(GSection comb) -- if tag == m then ... + !Word64 + !(GSection comb) -- else if tag == n then ... + !(GSection comb) -- else ... + | TestW + !(GSection comb) + !(EnumMap Word64 (GSection comb)) + | TestT + !(GSection comb) + !(M.Map Text (GSection comb)) + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) + +branchToEnumMap :: GBranch comb -> Maybe ((GSection comb), EnumMap Word64 (GSection comb)) +branchToEnumMap = \case + (Test1 k t d) -> Just (d, EC.mapSingleton k t) + (Test2 k1 s1 k2 s2 d) -> Just (d, EC.mapFromList [(k1, s1), (k2, s2)]) + (TestW d m) -> Just (d, m) + _ -> Nothing + +-- Convenience patterns for matches used in the algorithms below. +pattern MatchW :: Int -> (GSection comb) -> EnumMap Word64 (GSection comb) -> (GSection comb) +pattern MatchW i d cs <- Match i (branchToEnumMap -> Just (d, cs)) + where + MatchW i d cs = Match i (mkBranch d cs) + +pattern MatchT :: Int -> (GSection comb) -> M.Map Text (GSection comb) -> (GSection comb) +pattern MatchT i d cs = Match i (TestT d cs) + +pattern NMatchW :: + Maybe Reference -> Int -> (GSection comb) -> EnumMap Word64 (GSection comb) -> (GSection comb) +pattern NMatchW r i d cs <- NMatch r i (branchToEnumMap -> Just (d, cs)) + where + NMatchW r i d cs = NMatch r i $ mkBranch d cs + +mkBranch :: (GSection comb) -> (EnumMap Word64 (GSection comb)) -> GBranch comb +mkBranch d m = case EC.mapToList m of + [(k, v)] -> Test1 k v d + [(k1, v1), (k2, v2)] -> Test2 k1 v1 k2 v2 d + _ -> TestW d m + +-- Representation of the variable context available in the current +-- frame. This tracks tags that have been dumped to the stack for +-- proper indexing. The `Block` constructor is used to mark when we +-- go into the first portion of a `Let`, to track the size of that +-- sub-frame. +data Ctx v + = ECtx + | Block (Ctx v) + | Tag (Ctx v) + | Var v Mem (Ctx v) + deriving (Show) + +-- Represents the context formed by the top-level let rec around a +-- set of definitions. Previous steps have normalized the term to +-- only contain a single recursive binding group. The variables in +-- this binding group are resolved to numbered combinators rather +-- than stack positions. +type RCtx v = M.Map v Word64 + +-- Add a sequence of variables and corresponding calling conventions +-- to the context. +ctx :: [v] -> [Mem] -> Ctx v +ctx vs cs = pushCtx (zip vs cs) ECtx + +-- Look up a variable in the context, getting its position on the +-- relevant stack and its calling convention if it is there. +ctxResolve :: (Var v) => Ctx v -> v -> Maybe (Int, Mem) +ctxResolve ctx v = walk 0 ctx + where + walk _ ECtx = Nothing + walk i (Block ctx) = walk i ctx + walk i (Tag ctx) = walk (i + 1) ctx + walk i (Var x m ctx) + | v == x = Just (i, m) + | otherwise = walk (i + 1) ctx + +-- Add a sequence of variables and calling conventions to the context. +pushCtx :: [(v, Mem)] -> Ctx v -> Ctx v +pushCtx new old = foldr (uncurry Var) old new + +-- Concatenate two contexts +catCtx :: Ctx v -> Ctx v -> Ctx v +catCtx ECtx r = r +catCtx (Tag l) r = Tag $ catCtx l r +catCtx (Block l) r = Block $ catCtx l r +catCtx (Var v m l) r = Var v m $ catCtx l r + +-- Split the context after a particular variable +breakAfter :: (Eq v) => (v -> Bool) -> Ctx v -> (Ctx v, Ctx v) +breakAfter _ ECtx = (ECtx, ECtx) +breakAfter p (Tag vs) = first Tag $ breakAfter p vs +breakAfter p (Block vs) = first Block $ breakAfter p vs +breakAfter p (Var v m vs) = (Var v m lvs, rvs) + where + (lvs, rvs) + | p v = (ECtx, vs) + | otherwise = breakAfter p vs + +-- Modify the context to contain the variables introduced by an +-- unboxed sum +sumCtx :: (Var v) => Ctx v -> v -> [(v, Mem)] -> Ctx v +sumCtx ctx v vcs + | (lctx, rctx) <- breakAfter (== v) ctx = + catCtx lctx $ pushCtx vcs rctx + +-- Look up a variable in the top let rec context +rctxResolve :: (Var v) => RCtx v -> v -> Maybe Word64 +rctxResolve ctx u = M.lookup u ctx + +-- Compile a top-level definition group to a collection of combinators. +-- The provided word refers to the numbering for the overall group, +-- and intra-group calls are numbered locally, with 0 specifying +-- the global entry point. +emitCombs :: + (Var v) => + RefNums -> + Reference -> + Word64 -> + SuperGroup v -> + EnumMap Word64 Comb +emitCombs rns grpr grpn (Rec grp ent) = + emitComb rns grpr grpn rec (0, ent) <> aux + where + (rvs, cmbs) = unzip grp + ixs = map (`shiftL` 16) [1 ..] + rec = M.fromList $ zip rvs ixs + aux = foldMap (emitComb rns grpr grpn rec) (zip ixs cmbs) + +-- | lazily replace all references to combinators with the combinators themselves, +-- tying the knot recursively when necessary. +resolveCombs :: + -- Existing in-scope combs that might be referenced + Maybe (EnumMap Word64 (RCombs val)) -> + -- Combinators which need their knots tied. + EnumMap Word64 (GCombs val CombIx) -> + EnumMap Word64 (RCombs val) +resolveCombs mayExisting combs = + -- Fixed point lookup; + -- We make sure not to force resolved Combs or we'll loop forever. + let ~resolved = + combs + <&> (fmap . fmap) \(CIx _ n i) -> + let cmbs = case mayExisting >>= EC.lookup n of + Just cmbs -> cmbs + Nothing -> + case EC.lookup n resolved of + Just cmbs -> cmbs + Nothing -> error $ "unknown combinator `" ++ show n ++ "`." + in case EC.lookup i cmbs of + Just cmb -> RComb cmb + Nothing -> + error $ + "unknown section `" + ++ show i + ++ "` of combinator `" + ++ show n + ++ "`." + in resolved + +absurdCombs :: EnumMap Word64 (EnumMap Word64 (GComb Void cix)) -> EnumMap Word64 (GCombs any cix) +absurdCombs = fmap . fmap . first $ absurd + +-- Type for aggregating the necessary stack frame size. First field is the +-- necessary size. The Applicative instance takes the +-- maximum, so that combining values from different branches +-- results in finding the maximum number of slots either side requires. +-- +-- TODO: Now that we have a single stack, most of this counting can probably be simplified. +data Counted a = C !Int a + deriving (Functor) + +instance Applicative Counted where + pure = C 0 + C s0 f <*> C s1 x = C (max s0 s1) (f x) + +newtype Emit a + = EM (Word64 -> (EC.EnumMap Word64 Comb, Counted a)) + deriving (Functor) + +runEmit :: Word64 -> Emit a -> EC.EnumMap Word64 Comb +runEmit w (EM e) = fst $ e w + +instance Applicative Emit where + pure = EM . pure . pure . pure + EM ef <*> EM ex = EM $ (liftA2 . liftA2) (<*>) ef ex + +counted :: Counted a -> Emit a +counted = EM . pure . pure + +onCount :: (Counted a -> Counted b) -> Emit a -> Emit b +onCount f (EM e) = EM $ fmap f <$> e + +letIndex :: Word16 -> Word64 -> Word64 +letIndex l c = c .|. fromIntegral l + +record :: Ctx v -> Word16 -> Emit Section -> Emit (Word64, Comb) +record ctx l (EM es) = EM $ \c -> + let (m, C sz s) = es c + na = countCtx0 0 ctx + n = letIndex l c + comb = Lam na sz s + in (EC.mapInsert n comb m, C sz (n, comb)) + +recordTop :: [v] -> Word16 -> Emit Section -> Emit () +recordTop vs l (EM e) = EM $ \c -> + let (m, C sz s) = e c + na = length vs + n = letIndex l c + in (EC.mapInsert n (Lam na sz s) m, C sz ()) + +-- Counts the stack space used by a context and annotates a value +-- with it. +countCtx :: Ctx v -> a -> Emit a +countCtx ctx = counted . C i + where + i = countCtx0 0 ctx + +countCtx0 :: Int -> Ctx v -> Int +countCtx0 !i (Var _ _ ctx) = countCtx0 (i + 1) ctx +countCtx0 i (Tag ctx) = countCtx0 (i + 1) ctx +countCtx0 i (Block ctx) = countCtx0 i ctx +countCtx0 i ECtx = i + +emitComb :: + (Var v) => + RefNums -> + Reference -> + Word64 -> + RCtx v -> + (Word64, SuperNormal v) -> + EC.EnumMap Word64 Comb +emitComb rns grpr grpn rec (n, Lambda ccs (TAbss vs bd)) = + runEmit n + . recordTop vs 0 + $ emitSection rns grpr grpn rec (ctx vs ccs) bd + +addCount :: Int -> Emit a -> Emit a +addCount i = onCount $ \(C sz x) -> C (sz + i) x + +-- Emit a machine code section from an ANF term +emitSection :: + (Var v) => + RefNums -> + Reference -> + Word64 -> + RCtx v -> + Ctx v -> + ANormal v -> + Emit Section +emitSection rns grpr grpn rec ctx (TLets d us ms bu bo) = + emitLet rns grpr grpn rec d (zip us ms) ctx bu $ + emitSection rns grpr grpn rec ectx bo + where + ectx = pushCtx (zip us ms) ctx +emitSection rns grpr grpn rec ctx (TName u (Left f) args bo) = + emitClosures grpr grpn rec ctx args $ \ctx as -> + let cix = (CIx f (cnum rns f) 0) + in Ins (Name (Env cix cix) as) + <$> emitSection rns grpr grpn rec (Var u BX ctx) bo +emitSection rns grpr grpn rec ctx (TName u (Right v) args bo) + | Just (i, BX) <- ctxResolve ctx v = + emitClosures grpr grpn rec ctx args $ \ctx as -> + Ins (Name (Stk i) as) + <$> emitSection rns grpr grpn rec (Var u BX ctx) bo + | Just n <- rctxResolve rec v = + emitClosures grpr grpn rec ctx args $ \ctx as -> + let cix = (CIx grpr grpn n) + in Ins (Name (Env cix cix) as) + <$> emitSection rns grpr grpn rec (Var u BX ctx) bo + | otherwise = emitSectionVErr v +emitSection _ grpr grpn rec ctx (TVar v) + | Just (i, _) <- ctxResolve ctx v = countCtx ctx . Yield $ VArg1 i + | Just j <- rctxResolve rec v = + let cix = (CIx grpr grpn j) + in countCtx ctx $ App False (Env cix cix) $ ZArgs + | otherwise = emitSectionVErr v +emitSection _ _ grpn _ ctx (TPrm p args) = + -- 3 is a conservative estimate of how many extra stack slots + -- a prim op will need for its results. + addCount 3 + . countCtx ctx + . Ins (emitPOp p $ emitArgs grpn ctx args) + . Yield + . VArgV + $ countBlock ctx +emitSection _ _ grpn _ ctx (TFOp p args) = + addCount 3 + . countCtx ctx + . Ins (emitFOp p $ emitArgs grpn ctx args) + . Yield + . VArgV + $ countBlock ctx +emitSection rns grpr grpn rec ctx (TApp f args) = + emitClosures grpr grpn rec ctx args $ \ctx as -> + countCtx ctx $ emitFunction rns grpr grpn rec ctx f as +emitSection _ _ _ _ ctx (TLit l) = + c . countCtx ctx . Ins (emitLit l) . Yield $ VArg1 0 + where + c + | ANF.T {} <- l = addCount 1 + | ANF.LM {} <- l = addCount 1 + | ANF.LY {} <- l = addCount 1 + | otherwise = addCount 1 +emitSection _ _ _ _ ctx (TBLit l) = + addCount 1 . countCtx ctx . Ins (emitLit l) . Yield $ VArg1 0 +emitSection rns grpr grpn rec ctx (TMatch v bs) + | Just (i, BX) <- ctxResolve ctx v, + MatchData r cs df <- bs = + DMatch (Just r) i + <$> emitDataMatching r rns grpr grpn rec ctx cs df + | Just (i, BX) <- ctxResolve ctx v, + MatchRequest hs0 df <- bs, + hs <- mapFromList $ first (dnum rns) <$> M.toList hs0 = + uncurry (RMatch i) + <$> emitRequestMatching rns grpr grpn rec ctx hs df + | Just (i, UN) <- ctxResolve ctx v, + MatchIntegral cs df <- bs = + emitLitMatching + MatchW + "missing integral case" + rns + grpr + grpn + rec + ctx + i + cs + df + | Just (i, BX) <- ctxResolve ctx v, + MatchNumeric r cs df <- bs = + emitLitMatching + (NMatchW (Just r)) + "missing integral case" + rns + grpr + grpn + rec + ctx + i + cs + df + | Just (i, BX) <- ctxResolve ctx v, + MatchText cs df <- bs = + emitLitMatching + MatchT + "missing text case" + rns + grpr + grpn + rec + ctx + i + cs + df + | Just (i, UN) <- ctxResolve ctx v, + MatchSum cs <- bs = + emitSumMatching rns grpr grpn rec ctx v i cs + | Just (_, cc) <- ctxResolve ctx v = + internalBug $ + "emitSection: mismatched calling convention for match: " + ++ matchCallingError cc bs + | otherwise = + internalBug $ + "emitSection: could not resolve match variable: " ++ show (ctx, v) +emitSection rns grpr grpn rec ctx (THnd rs h b) + | Just (i, BX) <- ctxResolve ctx h = + Ins (Reset (EC.setFromList ws)) + . flip (foldr (\r -> Ins (SetDyn r i))) ws + <$> emitSection rns grpr grpn rec ctx b + | otherwise = emitSectionVErr h + where + ws = dnum rns <$> rs +emitSection rns grpr grpn rec ctx (TShift r v e) = + Ins (Capture $ dnum rns r) + <$> emitSection rns grpr grpn rec (Var v BX ctx) e +emitSection _ _ _ _ ctx (TFrc v) + | Just (i, BX) <- ctxResolve ctx v = + countCtx ctx $ App False (Stk i) ZArgs + | Just _ <- ctxResolve ctx v = + internalBug $ + "emitSection: values to be forced must be boxed: " ++ show v + | otherwise = emitSectionVErr v +emitSection _ _ _ _ _ tm = + internalBug $ "emitSection: unhandled code: " ++ show tm + +-- Emit the code for a function call +emitFunction :: + (Var v) => + RefNums -> + Reference -> + Word64 -> -- self combinator number + RCtx v -> -- recursive binding group + Ctx v -> -- local context + Func v -> + Args -> + Section +emitFunction _ grpr grpn rec ctx (FVar v) as + | Just (i, BX) <- ctxResolve ctx v = + App False (Stk i) as + | Just j <- rctxResolve rec v = + let cix = CIx grpr grpn j + in App False (Env cix cix) as + | otherwise = emitSectionVErr v +emitFunction rns _grpr _ _ _ (FComb r) as + | Just k <- anum rns r, + countArgs as == k -- exactly saturated call + = + Call False cix cix as + | otherwise -- slow path + = + App False (Env cix cix) as + where + n = cnum rns r + cix = CIx r n 0 +emitFunction rns _grpr _ _ _ (FCon r t) as = + Ins (Pack r (packTags rt t) as) + . Yield + $ VArg1 0 + where + rt = toEnum . fromIntegral $ dnum rns r +emitFunction rns _grpr _ _ _ (FReq r e) as = + -- Currently implementing packed calling convention for abilities + -- TODO ct is 16 bits, but a is 48 bits. This will be a problem if we have + -- more than 2^16 types. + Ins (Pack r (packTags rt e) as) + . App True (Dyn a) + $ VArg1 0 + where + a = dnum rns r + rt = toEnum . fromIntegral $ a +emitFunction _ _grpr _ _ ctx (FCont k) as + | Just (i, BX) <- ctxResolve ctx k = Jump i as + | Nothing <- ctxResolve ctx k = emitFunctionVErr k + | otherwise = internalBug $ "emitFunction: continuations are boxed" +emitFunction _ _grpr _ _ _ (FPrim _) _ = + internalBug "emitFunction: impossible" + +countBlock :: Ctx v -> Int +countBlock = go 0 + where + go !i (Var _ _ ctx) = go (i + 1) ctx + go i (Tag ctx) = go (i + 1) ctx + go i _ = i + +matchCallingError :: Mem -> Branched v -> String +matchCallingError cc b = "(" ++ show cc ++ "," ++ brs ++ ")" + where + brs + | MatchData _ _ _ <- b = "MatchData" + | MatchEmpty <- b = "MatchEmpty" + | MatchIntegral _ _ <- b = "MatchIntegral" + | MatchNumeric _ _ _ <- b = "MatchNumeric" + | MatchRequest _ _ <- b = "MatchRequest" + | MatchSum _ <- b = "MatchSum" + | MatchText _ _ <- b = "MatchText" + +emitSectionVErr :: (Var v, HasCallStack) => v -> a +emitSectionVErr v = + internalBug $ + "emitSection: could not resolve function variable: " ++ show v + +emitFunctionVErr :: (Var v, HasCallStack) => v -> a +emitFunctionVErr v = + internalBug $ + "emitFunction: could not resolve function variable: " ++ show v + +-- Emit machine code for a let expression. Some expressions do not +-- require a machine code Let, which uses more complicated stack +-- manipulation. +emitLet :: + (Var v) => + RefNums -> + Reference -> + Word64 -> + RCtx v -> + Direction Word16 -> + [(v, Mem)] -> + Ctx v -> + ANormal v -> + Emit Section -> + Emit Section +emitLet _ _ _ _ _ _ _ (TLit l) = + fmap (Ins $ emitLit l) +emitLet _ _ _ _ _ _ _ (TBLit l) = + fmap (Ins $ emitLit l) +-- emitLet rns grp _ _ _ ctx (TApp (FComb r) args) +-- -- We should be able to tell if we are making a saturated call +-- -- or not here. We aren't carrying the information here yet, though. +-- | False -- not saturated +-- = fmap (Ins . Name (Env n 0) $ emitArgs grp ctx args) +-- where +-- n = cnum rns r +emitLet rns _ grpn _ _ _ ctx (TApp (FCon r n) args) = + fmap (Ins . Pack r (packTags rt n) $ emitArgs grpn ctx args) + where + rt = toEnum . fromIntegral $ dnum rns r +emitLet _ _ grpn _ _ _ ctx (TApp (FPrim p) args) = + fmap (Ins . either emitPOp emitFOp p $ emitArgs grpn ctx args) +emitLet rns grpr grpn rec d vcs ctx bnd + | Direct <- d = + internalBug $ "unsupported compound direct let: " ++ show bnd + | Indirect w <- d = + \esect -> + f + <$> emitSection rns grpr grpn rec (Block ctx) bnd + <*> record (pushCtx vcs ctx) w esect + where + f s (w, Lam _ f bd) = + let cix = (CIx grpr grpn w) + in Let s cix f bd + +-- Translate from ANF prim ops to machine code operations. The +-- machine code operations are divided with respect to more detailed +-- information about expected number and types of arguments. +emitPOp :: ANF.POp -> Args -> Instr +-- Integral +emitPOp ANF.ADDI = emitP2 ADDI +emitPOp ANF.ADDN = emitP2 ADDN +emitPOp ANF.SUBI = emitP2 SUBI +emitPOp ANF.SUBN = emitP2 SUBN +emitPOp ANF.DRPN = emitP2 DRPN +emitPOp ANF.MULI = emitP2 MULI +emitPOp ANF.MULN = emitP2 MULN +emitPOp ANF.DIVI = emitP2 DIVI +emitPOp ANF.DIVN = emitP2 DIVN +emitPOp ANF.MODI = emitP2 MODI -- TODO: think about how these behave +emitPOp ANF.MODN = emitP2 MODN -- TODO: think about how these behave +emitPOp ANF.POWI = emitP2 POWI +emitPOp ANF.POWN = emitP2 POWN +emitPOp ANF.SHLI = emitP2 SHLI +emitPOp ANF.SHLN = emitP2 SHLN -- Note: left shift behaves uniformly +emitPOp ANF.SHRI = emitP2 SHRI +emitPOp ANF.SHRN = emitP2 SHRN +emitPOp ANF.LEQI = emitP2 LEQI +emitPOp ANF.LESI = emitP2 LESI +emitPOp ANF.LEQN = emitP2 LEQN +emitPOp ANF.LESN = emitP2 LESN +emitPOp ANF.EQLI = emitP2 EQLI +emitPOp ANF.NEQI = emitP2 NEQI +emitPOp ANF.EQLN = emitP2 EQLN +emitPOp ANF.NEQN = emitP2 NEQN +emitPOp ANF.SGNI = emitP1 SGNI +emitPOp ANF.NEGI = emitP1 NEGI +emitPOp ANF.INCI = emitP1 INCI +emitPOp ANF.INCN = emitP1 INCN +emitPOp ANF.DECI = emitP1 DECI +emitPOp ANF.DECN = emitP1 DECN +emitPOp ANF.TRNC = emitP1 TRNC +emitPOp ANF.TZRO = emitP1 TZRO +emitPOp ANF.LZRO = emitP1 LZRO +emitPOp ANF.POPC = emitP1 POPC +emitPOp ANF.ANDN = emitP2 ANDN +emitPOp ANF.ANDI = emitP2 ANDI +emitPOp ANF.IORN = emitP2 IORN +emitPOp ANF.IORI = emitP2 IORI +emitPOp ANF.XORI = emitP2 XORI +emitPOp ANF.XORN = emitP2 XORN +emitPOp ANF.COMN = emitP1 COMN +emitPOp ANF.COMI = emitP1 COMI +-- Float +emitPOp ANF.ADDF = emitP2 ADDF +emitPOp ANF.SUBF = emitP2 SUBF +emitPOp ANF.MULF = emitP2 MULF +emitPOp ANF.DIVF = emitP2 DIVF +emitPOp ANF.LEQF = emitP2 LEQF +emitPOp ANF.LESF = emitP2 LESF +emitPOp ANF.EQLF = emitP2 EQLF +emitPOp ANF.NEQF = emitP2 NEQF +emitPOp ANF.MINF = emitP2 MINF +emitPOp ANF.MAXF = emitP2 MAXF +emitPOp ANF.POWF = emitP2 POWF +emitPOp ANF.EXPF = emitP1 EXPF +emitPOp ANF.ABSF = emitP1 ABSF +emitPOp ANF.SQRT = emitP1 SQRT +emitPOp ANF.LOGF = emitP1 LOGF +emitPOp ANF.LOGB = emitP2 LOGB +emitPOp ANF.CEIL = emitP1 CEIL +emitPOp ANF.FLOR = emitP1 FLOR +emitPOp ANF.TRNF = emitP1 TRNF +emitPOp ANF.RNDF = emitP1 RNDF +emitPOp ANF.COSF = emitP1 COSF +emitPOp ANF.SINF = emitP1 SINF +emitPOp ANF.TANF = emitP1 TANF +emitPOp ANF.COSH = emitP1 COSH +emitPOp ANF.SINH = emitP1 SINH +emitPOp ANF.TANH = emitP1 TANH +emitPOp ANF.ACOS = emitP1 ACOS +emitPOp ANF.ATAN = emitP1 ATAN +emitPOp ANF.ASIN = emitP1 ASIN +emitPOp ANF.ACSH = emitP1 ACSH +emitPOp ANF.ASNH = emitP1 ASNH +emitPOp ANF.ATNH = emitP1 ATNH +emitPOp ANF.ATN2 = emitP2 ATN2 +-- conversions +emitPOp ANF.ITOF = emitP1 ITOF +emitPOp ANF.NTOF = emitP1 NTOF +emitPOp ANF.ITOT = emitBP1 ITOT +emitPOp ANF.NTOT = emitBP1 NTOT +emitPOp ANF.FTOT = emitBP1 FTOT +emitPOp ANF.TTON = emitBP1 TTON +emitPOp ANF.TTOI = emitBP1 TTOI +emitPOp ANF.TTOF = emitBP1 TTOF +emitPOp ANF.CAST = emitP2 CAST +-- text +emitPOp ANF.CATT = emitBP2 CATT +emitPOp ANF.TAKT = emitBP2 TAKT +emitPOp ANF.DRPT = emitBP2 DRPT +emitPOp ANF.IXOT = emitBP2 IXOT +emitPOp ANF.SIZT = emitBP1 SIZT +emitPOp ANF.UCNS = emitBP1 UCNS +emitPOp ANF.USNC = emitBP1 USNC +emitPOp ANF.EQLT = emitBP2 EQLT +emitPOp ANF.LEQT = emitBP2 LEQT +emitPOp ANF.PAKT = emitBP1 PAKT +emitPOp ANF.UPKT = emitBP1 UPKT +-- sequence +emitPOp ANF.CATS = emitBP2 CATS +emitPOp ANF.TAKS = emitBP2 TAKS +emitPOp ANF.DRPS = emitBP2 DRPS +emitPOp ANF.SIZS = emitBP1 SIZS +emitPOp ANF.CONS = emitBP2 CONS +emitPOp ANF.SNOC = emitBP2 SNOC +emitPOp ANF.IDXS = emitBP2 IDXS +emitPOp ANF.VWLS = emitBP1 VWLS +emitPOp ANF.VWRS = emitBP1 VWRS +emitPOp ANF.SPLL = emitBP2 SPLL +emitPOp ANF.SPLR = emitBP2 SPLR +-- bytes +emitPOp ANF.PAKB = emitBP1 PAKB +emitPOp ANF.UPKB = emitBP1 UPKB +emitPOp ANF.TAKB = emitBP2 TAKB +emitPOp ANF.DRPB = emitBP2 DRPB +emitPOp ANF.IXOB = emitBP2 IXOB +emitPOp ANF.IDXB = emitBP2 IDXB +emitPOp ANF.SIZB = emitBP1 SIZB +emitPOp ANF.FLTB = emitBP1 FLTB +emitPOp ANF.CATB = emitBP2 CATB +-- universal comparison +emitPOp ANF.EQLU = emitBP2 EQLU +emitPOp ANF.LEQU = emitBP2 LEQU +emitPOp ANF.LESU = emitBP2 LESU +emitPOp ANF.CMPU = emitBP2 CMPU +-- code operations +emitPOp ANF.MISS = emitBP1 MISS +emitPOp ANF.CACH = emitBP1 CACH +emitPOp ANF.LKUP = emitBP1 LKUP +emitPOp ANF.TLTT = emitBP1 TLTT +emitPOp ANF.CVLD = emitBP1 CVLD +emitPOp ANF.LOAD = emitBP1 LOAD +emitPOp ANF.VALU = emitBP1 VALU +emitPOp ANF.SDBX = emitBP2 SDBX +emitPOp ANF.SDBL = emitBP1 SDBL +emitPOp ANF.SDBV = emitBP2 SDBV +-- error call +emitPOp ANF.EROR = emitBP2 THRO +emitPOp ANF.TRCE = emitBP2 TRCE +emitPOp ANF.DBTX = emitBP1 DBTX +-- Refs +emitPOp ANF.REFN = emitBP1 REFN +emitPOp ANF.REFR = emitBP1 REFR +emitPOp ANF.REFW = emitBP2 REFW +emitPOp ANF.RCAS = refCAS +emitPOp ANF.RRFC = emitBP1 RRFC +emitPOp ANF.TIKR = emitBP1 TIKR +-- non-prim translations +emitPOp ANF.BLDS = Seq +-- Bools +emitPOp ANF.NOTB = emitP1 NOTB +emitPOp ANF.ANDB = emitP2 ANDB +emitPOp ANF.IORB = emitP2 IORB +emitPOp ANF.FORK = \case + VArg1 i -> Fork i + _ -> internalBug "fork takes exactly one boxed argument" +emitPOp ANF.ATOM = \case + VArg1 i -> Atomically i + _ -> internalBug "atomically takes exactly one boxed argument" +emitPOp ANF.PRNT = \case + VArg1 i -> Print i + _ -> internalBug "print takes exactly one boxed argument" +emitPOp ANF.INFO = \case + ZArgs -> Info "debug" + _ -> internalBug "info takes no arguments" +emitPOp ANF.TFRC = \case + VArg1 i -> TryForce i + _ -> internalBug "tryEval takes exactly one boxed argument" + +-- handled in emitSection because Die is not an instruction + +-- Emit machine code for ANF IO operations. These are all translated +-- to 'foreing function' calls, but there is a special case for the +-- standard handle access function, because it does not yield an +-- explicit error. +emitFOp :: ForeignFunc -> Args -> Instr +emitFOp fop = ForeignCall True fop + +-- Helper functions for packing the variable argument representation +-- into the indexes stored in prim op instructions +emitP1 :: UPrim1 -> Args -> Instr +emitP1 p (VArg1 i) = UPrim1 p i +emitP1 p a = + internalBug $ + "wrong number of args for unary unboxed primop: " + ++ show (p, a) + +emitP2 :: UPrim2 -> Args -> Instr +emitP2 p (VArg2 i j) = UPrim2 p i j +emitP2 p a = + internalBug $ + "wrong number of args for binary unboxed primop: " + ++ show (p, a) + +emitBP1 :: BPrim1 -> Args -> Instr +emitBP1 p (VArg1 i) = BPrim1 p i +emitBP1 p a = + internalBug $ + "wrong number of args for unary boxed primop: " + ++ show (p, a) + +emitBP2 :: BPrim2 -> Args -> Instr +emitBP2 p (VArg2 i j) = BPrim2 p i j +emitBP2 p a = + internalBug $ + "wrong number of args for binary boxed primop: " + ++ show (p, a) + +refCAS :: Args -> Instr +refCAS (VArgN (primArrayToList -> [i, j, k])) = RefCAS i j k +refCAS a = + internalBug $ + "wrong number of args for refCAS: " + ++ show a + +emitDataMatching :: + (Var v) => + Reference -> + RefNums -> + Reference -> + Word64 -> + RCtx v -> + Ctx v -> + EnumMap CTag ([Mem], ANormal v) -> + Maybe (ANormal v) -> + Emit Branch +emitDataMatching r rns grpr grpn rec ctx cs df = + mkBranch <$> edf <*> traverse (emitCase rns grpr grpn rec ctx) (coerce cs) + where + -- Note: this is not really accurate. A default data case needs + -- stack space corresponding to the actual data that shows up there. + -- However, we currently don't use default cases for data. + edf + | Just co <- df = emitSection rns grpr grpn rec ctx co + | otherwise = countCtx ctx $ Die ("missing data case for hash " <> show r) + +-- Emits code corresponding to an unboxed sum match. +-- The match is against a tag on the stack, and cases introduce +-- variables to the middle of the context, because the fields were +-- already there, but it was unknown how many there were until +-- branching on the tag. +emitSumMatching :: + (Var v) => + RefNums -> + Reference -> + Word64 -> + RCtx v -> + Ctx v -> + v -> + Int -> + EnumMap Word64 ([Mem], ANormal v) -> + Emit Section +emitSumMatching rns grpr grpn rec ctx v i cs = + MatchW i edf <$> traverse (emitSumCase rns grpr grpn rec ctx v) cs + where + edf = Die "uncovered unboxed sum case" + +emitRequestMatching :: + (Var v) => + RefNums -> + Reference -> + Word64 -> + RCtx v -> + Ctx v -> + EnumMap Word64 (EnumMap CTag ([Mem], ANormal v)) -> + ANormal v -> + Emit (Section, EnumMap Word64 Branch) +emitRequestMatching rns grpr grpn rec ctx hs df = (,) <$> pur <*> tops + where + pur = emitCase rns grpr grpn rec ctx ([BX], df) + tops = traverse f (coerce hs) + f cs = mkBranch edf <$> traverse (emitCase rns grpr grpn rec ctx) cs + edf = Die "unhandled ability" + +emitLitMatching :: + (Var v) => + (Traversable f) => + (Int -> Section -> f Section -> Section) -> + String -> + RefNums -> + Reference -> + Word64 -> + RCtx v -> + Ctx v -> + Int -> + f (ANormal v) -> + Maybe (ANormal v) -> + Emit Section +emitLitMatching con err rns grpr grpn rec ctx i cs df = + con i <$> edf <*> traverse (emitCase rns grpr grpn rec ctx . ([],)) cs + where + edf + | Just co <- df = emitSection rns grpr grpn rec ctx co + | otherwise = countCtx ctx $ Die err + +emitCase :: + (Var v) => + RefNums -> + Reference -> + Word64 -> + RCtx v -> + Ctx v -> + ([Mem], ANormal v) -> + Emit Section +emitCase rns grpr grpn rec ctx (ccs, TAbss vs bo) = + emitSection rns grpr grpn rec (pushCtx (zip vs ccs) ctx) bo + +emitSumCase :: + (Var v) => + RefNums -> + Reference -> + Word64 -> + RCtx v -> + Ctx v -> + v -> + ([Mem], ANormal v) -> + Emit Section +emitSumCase rns grpr grpn rec ctx v (ccs, TAbss vs bo) = + emitSection rns grpr grpn rec (sumCtx ctx v $ zip vs ccs) bo + +litToMLit :: ANF.Lit -> MLit +litToMLit (ANF.I i) = MI (fromIntegral i) +litToMLit (ANF.N n) = MN n +litToMLit (ANF.C c) = MC c +litToMLit (ANF.F d) = MD d +litToMLit (ANF.T t) = MT t +litToMLit (ANF.LM r) = MM r +litToMLit (ANF.LY r) = MY r + +-- | Emit a literal as a machine literal of the correct boxed/unboxed format. +emitLit :: ANF.Lit -> Instr +emitLit = Lit . litToMLit + +-- Emits some fix-up code for calling functions. Some of the +-- variables in scope come from the top-level let rec, but these +-- are definitions, not values on the stack. These definitions cannot +-- be passed directly as function arguments, and must have a +-- corresponding stack entry allocated first. So, this function inserts +-- these allocations and passes the appropriate context into the +-- provided continuation. +emitClosures :: + (Var v) => + Reference -> + Word64 -> + RCtx v -> + Ctx v -> + [v] -> + (Ctx v -> Args -> Emit Section) -> + Emit Section +emitClosures grpr grpn rec ctx args k = + allocate ctx args $ \ctx -> k ctx $ emitArgs grpn ctx args + where + allocate ctx [] k = k ctx + allocate ctx (a : as) k + | Just _ <- ctxResolve ctx a = allocate ctx as k + | Just n <- rctxResolve rec a = + let cix = (CIx grpr grpn n) + in Ins (Name (Env cix cix) ZArgs) <$> allocate (Var a BX ctx) as k + | otherwise = + internalBug $ "emitClosures: unknown reference: " ++ show a ++ show grpr + +emitArgs :: (Var v) => Word64 -> Ctx v -> [v] -> Args +emitArgs grpn ctx args + | Just l <- traverse (ctxResolve ctx) args = demuxArgs l + | otherwise = + internalBug $ + "emitArgs[" + ++ show grpn + ++ "]: " + ++ "could not resolve argument variables: " + ++ show args + +-- Turns a list of stack positions and calling conventions into the +-- argument format expected in the machine code. +demuxArgs :: [(Int, Mem)] -> Args +demuxArgs = \case + [] -> ZArgs + [(i, _)] -> VArg1 i + [(i, _), (j, _)] -> VArg2 i j + args -> VArgN $ PA.primArrayFromList (fst <$> args) + +combDeps :: GComb val comb -> [Word64] +combDeps (Lam _ _ s) = sectionDeps s +combDeps (CachedVal {}) = [] + +combTypes :: GComb any comb -> [Word64] +combTypes (Lam _ _ s) = sectionTypes s +combTypes (CachedVal {}) = [] + +sectionDeps :: GSection comb -> [Word64] +sectionDeps (App _ (Env (CIx _ w _) _) _) = [w] +sectionDeps (Call _ (CIx _ w _) _ _) = [w] +sectionDeps (Match _ br) = branchDeps br +sectionDeps (DMatch _ _ br) = branchDeps br +sectionDeps (RMatch _ pu br) = + sectionDeps pu ++ foldMap branchDeps br +sectionDeps (NMatch _ _ br) = branchDeps br +sectionDeps (Ins i s) + | Name (Env (CIx _ w _) _) _ <- i = w : sectionDeps s + | otherwise = sectionDeps s +sectionDeps (Let s (CIx _ w _) _ b) = + w : sectionDeps s ++ sectionDeps b +sectionDeps _ = [] + +sectionTypes :: GSection comb -> [Word64] +sectionTypes (Ins i s) = instrTypes i ++ sectionTypes s +sectionTypes (Let s _ _ b) = sectionTypes s ++ sectionTypes b +sectionTypes (Match _ br) = branchTypes br +sectionTypes (DMatch _ _ br) = branchTypes br +sectionTypes (NMatch _ _ br) = branchTypes br +sectionTypes (RMatch _ pu br) = + sectionTypes pu ++ foldMap branchTypes br +sectionTypes _ = [] + +instrTypes :: GInstr comb -> [Word64] +instrTypes (Pack _ (PackedTag w) _) = [w `shiftR` 16] +instrTypes (Reset ws) = setToList ws +instrTypes (Capture w) = [w] +instrTypes (SetDyn w _) = [w] +instrTypes _ = [] + +branchDeps :: GBranch comb -> [Word64] +branchDeps (Test1 _ s1 d) = sectionDeps s1 ++ sectionDeps d +branchDeps (Test2 _ s1 _ s2 d) = + sectionDeps s1 ++ sectionDeps s2 ++ sectionDeps d +branchDeps (TestW d m) = + sectionDeps d ++ foldMap sectionDeps m +branchDeps (TestT d m) = + sectionDeps d ++ foldMap sectionDeps m + +branchTypes :: GBranch comb -> [Word64] +branchTypes (Test1 _ s1 d) = sectionTypes s1 ++ sectionTypes d +branchTypes (Test2 _ s1 _ s2 d) = + sectionTypes s1 ++ sectionTypes s2 ++ sectionTypes d +branchTypes (TestW d m) = + sectionTypes d ++ foldMap sectionTypes m +branchTypes (TestT d m) = + sectionTypes d ++ foldMap sectionTypes m + +indent :: Int -> ShowS +indent ind = showString (replicate (ind * 2) ' ') + +prettyCombs :: + Word64 -> + EnumMap Word64 Comb -> + ShowS +prettyCombs w es = + foldr + (\(i, c) r -> prettyComb w i c . showString "\n" . r) + id + (mapToList es) + +prettyComb :: (Show val, Show comb) => Word64 -> Word64 -> GComb val comb -> ShowS +prettyComb w i = \case + (Lam a _ s) -> + shows w + . showString ":" + . shows i + . showString ":" + . shows a + . showString "\n" + . prettySection 2 s + (CachedVal a b) -> + shows w + . showString ":" + . shows i + . showString ":" + . shows a + . showString "\n" + . shows b + +prettySection :: (Show comb) => Int -> GSection comb -> ShowS +prettySection ind sec = + indent ind . case sec of + App _ r as -> + showString "App " + . prettyGRef 12 r + . showString " " + . prettyArgs as + Call _ i _ as -> + showString "Call " . prettyCIx i . showString " " . prettyArgs as + Jump i as -> + showString "Jump " . shows i . showString " " . prettyArgs as + Match i bs -> + showString "Match " + . shows i + . showString "\n" + . prettyBranches (ind + 1) bs + Yield as -> showString "Yield " . prettyArgs as + Ins i nx -> + prettyIns i . showString "\n" . prettySection ind nx + Let s _ _ b -> + showString "Let\n" + . prettySection (ind + 2) s + . showString "\n" + . prettySection ind b + Die s -> showString $ "Die " ++ s + Exit -> showString "Exit" + DMatch _ i bs -> + showString "DMatch " + . shows i + . showString "\n" + . prettyBranches (ind + 1) bs + NMatch _ i bs -> + showString "NMatch " + . shows i + . showString "\n" + . prettyBranches (ind + 1) bs + RMatch i pu bs -> + showString "RMatch " + . shows i + . showString "\nPUR ->\n" + . prettySection (ind + 1) pu + . foldr (\p r -> rqc p . r) id (mapToList bs) + where + rqc (i, e) = + showString "\n" + . shows i + . showString " ->\n" + . prettyBranches (ind + 1) e + +prettyCIx :: CombIx -> ShowS +prettyCIx (CIx r _ n) = + prettyRef r . if n == 0 then id else showString "-" . shows n + +prettyRef :: Reference -> ShowS +prettyRef = showString . Text.unpack . showShort 10 + +prettyGRef :: Int -> GRef comb -> ShowS +prettyGRef p r = + showParen (p > 10) $ case r of + Stk i -> showString "Stk " . shows i + Dyn w -> showString "Dyn " . shows w + Env cix _ -> showString "Env " . prettyCIx cix + +prettyBranches :: (Show comb) => Int -> GBranch comb -> ShowS +prettyBranches ind bs = + case bs of + Test1 i e df -> pdf df . picase i e + Test2 i ei j ej df -> pdf df . picase i ei . picase j ej + TestW df m -> + pdf df . foldr (\(i, e) r -> picase i e . r) id (mapToList m) + TestT df m -> + pdf df . foldr (\(i, e) r -> ptcase i e . r) id (M.toList m) + where + pdf e = indent ind . showString "DFLT ->\n" . prettySection (ind + 1) e + ptcase t e = + showString "\n" + . indent ind + . shows t + . showString " ->\n" + . prettySection (ind + 1) e + picase i e = + showString "\n" + . indent ind + . shows i + . showString " ->\n" + . prettySection (ind + 1) e + +prettyIns :: (Show comb) => GInstr comb -> ShowS +prettyIns (Pack r i as) = + showString "Pack " + . prettyRef r + . (' ' :) + . shows i + . (' ' :) + . prettyArgs as +prettyIns (Lit l) = + showString "Lit " . showsPrec 11 l +prettyIns (Name r as) = + showString "Name " + . prettyGRef 12 r + . (' ' :) + . prettyArgs as +prettyIns i = shows i + +prettyArgs :: Args -> ShowS +prettyArgs ZArgs = showString "ZArgs" +prettyArgs v = showParen True $ shows v + +-- | If running in a sandboxed environment, replace all restricted foreign functions with an error. +sanitizeCombsOfForeignFuncs :: Bool -> (Set ForeignFunc) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) +sanitizeCombsOfForeignFuncs sanitize sandboxedForeigns m + | sanitize = (fmap . fmap) (sanitizeComb sandboxedForeigns) m + | otherwise = m + +sanitizeComb :: Set ForeignFunc -> GComb Void CombIx -> GComb Void CombIx +sanitizeComb sandboxedForeigns = \case + Lam a b s -> Lam a b (sanitizeSection sandboxedForeigns s) + +-- | Crawl the source code and statically replace all sandboxed foreign funcs with an error. +sanitizeSection :: Set ForeignFunc -> GSection CombIx -> GSection CombIx +sanitizeSection sandboxedForeigns section = case section of + Ins (ForeignCall _ f as) nx + | Set.member f sandboxedForeigns -> Ins (SandboxingFailure (foreignFuncBuiltinName f)) (sanitizeSection sandboxedForeigns nx) + | otherwise -> Ins (ForeignCall True f as) (sanitizeSection sandboxedForeigns nx) + Ins i nx -> Ins i (sanitizeSection sandboxedForeigns nx) + App {} -> section + Call {} -> section + Jump {} -> section + Match i bs -> Match i (sanitizeBranches sandboxedForeigns bs) + Yield {} -> section + Let s i f b -> Let (sanitizeSection sandboxedForeigns s) i f (sanitizeSection sandboxedForeigns b) + Die {} -> section + Exit -> section + DMatch i j bs -> DMatch i j (sanitizeBranches sandboxedForeigns bs) + NMatch i j bs -> NMatch i j (sanitizeBranches sandboxedForeigns bs) + RMatch i s bs -> RMatch i (sanitizeSection sandboxedForeigns s) (fmap (sanitizeBranches sandboxedForeigns) bs) + +sanitizeBranches :: Set ForeignFunc -> GBranch CombIx -> GBranch CombIx +sanitizeBranches sandboxedForeigns = \case + Test1 i s d -> Test1 i (sanitizeSection sandboxedForeigns s) (sanitizeSection sandboxedForeigns d) + Test2 i s j t d -> Test2 i (sanitizeSection sandboxedForeigns s) j (sanitizeSection sandboxedForeigns t) (sanitizeSection sandboxedForeigns d) + TestW d m -> TestW (sanitizeSection sandboxedForeigns d) (fmap (sanitizeSection sandboxedForeigns) m) + TestT d m -> TestT (sanitizeSection sandboxedForeigns d) (fmap (sanitizeSection sandboxedForeigns) m) diff --git a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs new file mode 100644 index 0000000000..e6946403d9 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Runtime.MCode.Serialize + ( putComb, + getComb, + putCombIx, + getCombIx, + ) +where + +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Bytes.VarInt +import Data.Void (Void) +import Data.Word (Word64) +import GHC.Exts (IsList (..)) +import Unison.Runtime.ANF (PackedTag (..)) +import Unison.Runtime.Array (PrimArray) +import Unison.Runtime.Foreign.Function.Type (ForeignFunc) +import Unison.Runtime.MCode hiding (MatchT) +import Unison.Runtime.Serialize +import Unison.Util.Text qualified as Util.Text +import Prelude hiding (getChar, putChar) + +data CombT = LamT | CachedClosureT + +instance Tag CombT where + tag2word LamT = 0 + tag2word CachedClosureT = 1 + + word2tag 0 = pure LamT + word2tag 1 = pure CachedClosureT + word2tag n = unknownTag "CombT" n + +putPackedTag :: (MonadPut m) => PackedTag -> m () +putPackedTag (PackedTag w) = pWord w + +getPackedTag :: (MonadGet m) => m PackedTag +getPackedTag = PackedTag <$> gWord + +putComb :: (MonadPut m) => (clos -> m ()) -> GComb clos comb -> m () +putComb pClos = \case + (Lam a f body) -> + putTag LamT *> pInt a *> pInt f *> putSection body + (CachedVal w v) -> + putTag CachedClosureT *> putNat w *> pClos v + +getComb :: (MonadGet m) => m (GComb Void CombIx) +getComb = + getTag >>= \case + LamT -> + Lam <$> gInt <*> gInt <*> getSection + CachedClosureT -> error "getComb: Unexpected serialized Cached Closure" + +getMForeignFunc :: (MonadGet m) => m ForeignFunc +getMForeignFunc = do + toEnum <$> gInt + +putMForeignFunc :: (MonadPut m) => ForeignFunc -> m () +putMForeignFunc = pInt . fromEnum + +data SectionT + = AppT + | CallT + | JumpT + | MatchT + | YieldT + | InsT + | LetT + | DieT + | ExitT + | DMatchT + | NMatchT + | RMatchT + +instance Tag SectionT where + tag2word AppT = 0 + tag2word CallT = 1 + tag2word JumpT = 2 + tag2word MatchT = 3 + tag2word YieldT = 4 + tag2word InsT = 5 + tag2word LetT = 6 + tag2word DieT = 7 + tag2word ExitT = 8 + tag2word DMatchT = 9 + tag2word NMatchT = 10 + tag2word RMatchT = 11 + + word2tag 0 = pure AppT + word2tag 1 = pure CallT + word2tag 2 = pure JumpT + word2tag 3 = pure MatchT + word2tag 4 = pure YieldT + word2tag 5 = pure InsT + word2tag 6 = pure LetT + word2tag 7 = pure DieT + word2tag 8 = pure ExitT + word2tag 9 = pure DMatchT + word2tag 10 = pure NMatchT + word2tag 11 = pure RMatchT + word2tag i = unknownTag "SectionT" i + +putSection :: (MonadPut m) => GSection cix -> m () +putSection = \case + App b r a -> putTag AppT *> serialize b *> putRef r *> putArgs a + Call b cix _comb a -> putTag CallT *> serialize b *> putCombIx cix *> putArgs a + Jump i a -> putTag JumpT *> pInt i *> putArgs a + Match i b -> putTag MatchT *> pInt i *> putBranch b + Yield a -> putTag YieldT *> putArgs a + Ins i s -> putTag InsT *> putInstr i *> putSection s + Let s ci f bd -> + putTag LetT + *> putSection s + *> putCombIx ci + *> pInt f + *> putSection bd + Die s -> putTag DieT *> serialize s + Exit -> putTag ExitT + DMatch mr i b -> putTag DMatchT *> putMaybe mr putReference *> pInt i *> putBranch b + NMatch mr i b -> putTag NMatchT *> putMaybe mr putReference *> pInt i *> putBranch b + RMatch i pu bs -> + putTag RMatchT + *> pInt i + *> putSection pu + *> putEnumMap pWord putBranch bs + +getSection :: (MonadGet m) => m Section +getSection = + getTag >>= \case + AppT -> App <$> deserialize <*> getRef <*> getArgs + CallT -> do + skipCheck <- deserialize + cix <- getCombIx + args <- getArgs + pure $ Call skipCheck cix cix args + JumpT -> Jump <$> gInt <*> getArgs + MatchT -> Match <$> gInt <*> getBranch + YieldT -> Yield <$> getArgs + InsT -> Ins <$> getInstr <*> getSection + LetT -> + Let <$> getSection <*> getCombIx <*> gInt <*> getSection + DieT -> Die <$> deserialize + ExitT -> pure Exit + DMatchT -> DMatch <$> getMaybe getReference <*> gInt <*> getBranch + NMatchT -> NMatch <$> getMaybe getReference <*> gInt <*> getBranch + RMatchT -> + RMatch <$> gInt <*> getSection <*> getEnumMap gWord getBranch + +data InstrT + = UPrim1T + | UPrim2T + | BPrim1T + | BPrim2T + | ForeignCallT + | SetDynT + | CaptureT + | NameT + | InfoT + | PackT + | LitT + | PrintT + | ResetT + | ForkT + | AtomicallyT + | SeqT + | TryForceT + | RefCAST + | SandboxingFailureT + +instance Tag InstrT where + tag2word UPrim1T = 0 + tag2word UPrim2T = 1 + tag2word BPrim1T = 2 + tag2word BPrim2T = 3 + tag2word ForeignCallT = 4 + tag2word SetDynT = 5 + tag2word CaptureT = 6 + tag2word NameT = 7 + tag2word InfoT = 8 + tag2word PackT = 9 + tag2word LitT = 10 + tag2word PrintT = 11 + tag2word ResetT = 12 + tag2word ForkT = 13 + tag2word AtomicallyT = 14 + tag2word SeqT = 15 + tag2word TryForceT = 16 + tag2word RefCAST = 17 + tag2word SandboxingFailureT = 18 + + word2tag 0 = pure UPrim1T + word2tag 1 = pure UPrim2T + word2tag 2 = pure BPrim1T + word2tag 3 = pure BPrim2T + word2tag 4 = pure ForeignCallT + word2tag 5 = pure SetDynT + word2tag 6 = pure CaptureT + word2tag 7 = pure NameT + word2tag 8 = pure InfoT + word2tag 9 = pure PackT + word2tag 10 = pure LitT + word2tag 11 = pure PrintT + word2tag 12 = pure ResetT + word2tag 13 = pure ForkT + word2tag 14 = pure AtomicallyT + word2tag 15 = pure SeqT + word2tag 16 = pure TryForceT + word2tag 17 = pure RefCAST + word2tag 18 = pure SandboxingFailureT + word2tag n = unknownTag "InstrT" n + +putInstr :: (MonadPut m) => GInstr cix -> m () +putInstr = \case + (UPrim1 up i) -> putTag UPrim1T *> putTag up *> pInt i + (UPrim2 up i j) -> putTag UPrim2T *> putTag up *> pInt i *> pInt j + (BPrim1 bp i) -> putTag BPrim1T *> putTag bp *> pInt i + (BPrim2 bp i j) -> putTag BPrim2T *> putTag bp *> pInt i *> pInt j + (RefCAS i j k) -> putTag RefCAST *> pInt i *> pInt j *> pInt k + (ForeignCall b ff a) -> putTag ForeignCallT *> serialize b *> putMForeignFunc ff *> putArgs a + (SetDyn w i) -> putTag SetDynT *> pWord w *> pInt i + (Capture w) -> putTag CaptureT *> pWord w + (Name r a) -> putTag NameT *> putRef r *> putArgs a + (Info s) -> putTag InfoT *> serialize s + (Pack r w a) -> putTag PackT *> putReference r *> putPackedTag w *> putArgs a + (Lit l) -> putTag LitT *> putLit l + (Print i) -> putTag PrintT *> pInt i + (Reset s) -> putTag ResetT *> putEnumSet pWord s + (Fork i) -> putTag ForkT *> pInt i + (Atomically i) -> putTag AtomicallyT *> pInt i + (Seq a) -> putTag SeqT *> putArgs a + (TryForce i) -> putTag TryForceT *> pInt i + (SandboxingFailure {}) -> + -- Sandboxing failures should only exist in code we're actively running, it shouldn't be serialized. + error "putInstr: Unexpected serialized Sandboxing Failure" + +getInstr :: (MonadGet m) => m Instr +getInstr = + getTag >>= \case + UPrim1T -> UPrim1 <$> getTag <*> gInt + UPrim2T -> UPrim2 <$> getTag <*> gInt <*> gInt + BPrim1T -> BPrim1 <$> getTag <*> gInt + BPrim2T -> BPrim2 <$> getTag <*> gInt <*> gInt + RefCAST -> RefCAS <$> gInt <*> gInt <*> gInt + ForeignCallT -> ForeignCall <$> deserialize <*> getMForeignFunc <*> getArgs + SetDynT -> SetDyn <$> gWord <*> gInt + CaptureT -> Capture <$> gWord + NameT -> Name <$> getRef <*> getArgs + InfoT -> Info <$> deserialize + PackT -> Pack <$> getReference <*> getPackedTag <*> getArgs + LitT -> Lit <$> getLit + PrintT -> Print <$> gInt + ResetT -> Reset <$> getEnumSet gWord + ForkT -> Fork <$> gInt + AtomicallyT -> Atomically <$> gInt + SeqT -> Seq <$> getArgs + TryForceT -> TryForce <$> gInt + SandboxingFailureT -> error "getInstr: Unexpected serialized Sandboxing Failure" + +data ArgsT + = ZArgsT + | Arg1T + | Arg2T + | ArgRT + | ArgNT + | ArgVT + +instance Tag ArgsT where + tag2word ZArgsT = 0 + tag2word Arg1T = 1 + tag2word Arg2T = 2 + tag2word ArgRT = 3 + tag2word ArgNT = 4 + tag2word ArgVT = 5 + + word2tag 0 = pure ZArgsT + word2tag 1 = pure Arg1T + word2tag 2 = pure Arg2T + word2tag 3 = pure ArgRT + word2tag 4 = pure ArgNT + word2tag 5 = pure ArgVT + word2tag n = unknownTag "ArgsT" n + +putArgs :: (MonadPut m) => Args -> m () +putArgs ZArgs = putTag ZArgsT +putArgs (VArg1 i) = putTag Arg1T *> pInt i +putArgs (VArg2 i j) = putTag Arg2T *> pInt i *> pInt j +putArgs (VArgR i j) = putTag ArgRT *> pInt i *> pInt j +putArgs (VArgN pa) = putTag ArgNT *> putIntArr pa +putArgs (VArgV i) = putTag ArgVT *> pInt i + +getArgs :: (MonadGet m) => m Args +getArgs = + getTag >>= \case + ZArgsT -> pure ZArgs + Arg1T -> VArg1 <$> gInt + Arg2T -> VArg2 <$> gInt <*> gInt + ArgRT -> VArgR <$> gInt <*> gInt + ArgNT -> VArgN <$> getIntArr + ArgVT -> VArgV <$> gInt + +data RefT = StkT | EnvT | DynT + +instance Tag RefT where + tag2word StkT = 0 + tag2word EnvT = 1 + tag2word DynT = 2 + + word2tag 0 = pure StkT + word2tag 1 = pure EnvT + word2tag 2 = pure DynT + word2tag n = unknownTag "RefT" n + +putRef :: (MonadPut m) => GRef cix -> m () +putRef (Stk i) = putTag StkT *> pInt i +putRef (Env cix _) = putTag EnvT *> putCombIx cix +putRef (Dyn i) = putTag DynT *> pWord i + +getRef :: (MonadGet m) => m Ref +getRef = + getTag >>= \case + StkT -> Stk <$> gInt + EnvT -> do + cix <- getCombIx + pure $ Env cix cix + DynT -> Dyn <$> gWord + +putCombIx :: (MonadPut m) => CombIx -> m () +putCombIx (CIx r n i) = putReference r *> pWord n *> pWord i + +getCombIx :: (MonadGet m) => m CombIx +getCombIx = CIx <$> getReference <*> gWord <*> gWord + +data MLitT = MIT | MNT | MCT | MDT | MTT | MMT | MYT + +instance Tag MLitT where + tag2word MIT = 0 + tag2word MNT = 1 + tag2word MCT = 2 + tag2word MDT = 3 + tag2word MTT = 4 + tag2word MMT = 5 + tag2word MYT = 6 + + word2tag 0 = pure MIT + word2tag 1 = pure MNT + word2tag 2 = pure MCT + word2tag 3 = pure MDT + word2tag 4 = pure MTT + word2tag 5 = pure MMT + word2tag 6 = pure MYT + word2tag n = unknownTag "MLitT" n + +putLit :: (MonadPut m) => MLit -> m () +putLit (MI i) = putTag MIT *> pInt i +putLit (MN n) = putTag MNT *> pWord n +putLit (MC c) = putTag MCT *> putChar c +putLit (MD d) = putTag MDT *> putFloat d +putLit (MT t) = putTag MTT *> putText (Util.Text.toText t) +putLit (MM r) = putTag MMT *> putReferent r +putLit (MY r) = putTag MYT *> putReference r + +getLit :: (MonadGet m) => m MLit +getLit = + getTag >>= \case + MIT -> MI <$> gInt + MNT -> MN <$> gWord + MCT -> MC <$> getChar + MDT -> MD <$> getFloat + MTT -> MT . Util.Text.fromText <$> getText + MMT -> MM <$> getReferent + MYT -> MY <$> getReference + +data BranchT = Test1T | Test2T | TestWT | TestTT + +instance Tag BranchT where + tag2word Test1T = 0 + tag2word Test2T = 1 + tag2word TestWT = 2 + tag2word TestTT = 3 + + word2tag 0 = pure Test1T + word2tag 1 = pure Test2T + word2tag 2 = pure TestWT + word2tag 3 = pure TestTT + word2tag n = unknownTag "BranchT" n + +putBranch :: (MonadPut m) => GBranch cix -> m () +putBranch (Test1 w s d) = + putTag Test1T *> pWord w *> putSection s *> putSection d +putBranch (Test2 a sa b sb d) = + putTag Test2T + *> pWord a + *> putSection sa + *> pWord b + *> putSection sb + *> putSection d +putBranch (TestW d m) = + putTag TestWT *> putSection d *> putEnumMap pWord putSection m +putBranch (TestT d m) = + putTag TestTT *> putSection d *> putMap (putText . Util.Text.toText) putSection m + +getBranch :: (MonadGet m) => m Branch +getBranch = + getTag >>= \case + Test1T -> Test1 <$> gWord <*> getSection <*> getSection + Test2T -> + Test2 + <$> gWord + <*> getSection + <*> gWord + <*> getSection + <*> getSection + TestWT -> TestW <$> getSection <*> getEnumMap gWord getSection + TestTT -> TestT <$> getSection <*> getMap (Util.Text.fromText <$> getText) getSection + +gInt :: (MonadGet m) => m Int +gInt = unVarInt <$> deserialize + +pInt :: (MonadPut m) => Int -> m () +pInt i = serialize (VarInt i) + +gWord :: (MonadGet m) => m Word64 +gWord = unVarInt <$> deserialize + +pWord :: (MonadPut m) => Word64 -> m () +pWord w = serialize (VarInt w) + +putIntArr :: (MonadPut m) => PrimArray Int -> m () +putIntArr pa = putFoldable pInt $ toList pa + +getIntArr :: (MonadGet m) => m (PrimArray Int) +getIntArr = fromList <$> getList gInt diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs new file mode 100644 index 0000000000..bfc7ab0c00 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -0,0 +1,2732 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnboxedTuples #-} + +module Unison.Runtime.Machine + ( ActiveThreads, + CCache (..), + Combs, + Tracer (..), + apply0, + baseCCache, + cacheAdd, + cacheAdd0, + eval0, + expandSandbox, + preEvalTopLevelConstants, + refLookup, + refNumTm, + refNumsTm, + refNumsTy, + reifyValue, + resolveSection, + ) +where + +import Control.Concurrent (ThreadId) +import Control.Concurrent.STM as STM +import Control.Exception +import Control.Lens +import Data.Atomics qualified as Atomic +import Data.Bits +import Data.Functor.Classes (Eq1 (..), Ord1 (..)) +import Data.IORef (IORef) +import Data.IORef qualified as IORef +import Data.Map.Strict qualified as M +import Data.Ord (comparing) +import Data.Sequence qualified as Sq +import Data.Set qualified as S +import Data.Set qualified as Set +import Data.Text qualified as DTx +import Data.Text.IO qualified as Tx +import Data.Traversable +import GHC.Conc as STM (unsafeIOToSTM) +import GHC.Stack +import Unison.Builtin.Decls (exceptionRef, ioFailureRef) +import Unison.Builtin.Decls qualified as Rf +import Unison.Builtin.Decls qualified as Ty +import Unison.ConstructorReference qualified as CR +import Unison.Prelude hiding (Text) +import Unison.Reference + ( Reference, + Reference' (Builtin), + isBuiltin, + toShortHash, + ) +import Unison.Referent (Referent, pattern Con, pattern Ref) +import Unison.Runtime.ANF as ANF + ( Cacheability (..), + Code (..), + CompileExn (..), + PackedTag (..), + SuperGroup, + codeGroup, + foldGroup, + foldGroupLinks, + maskTags, + packTags, + valueLinks, + ) +import Unison.Runtime.ANF qualified as ANF +import Unison.Runtime.Array as PA +import Unison.Runtime.Builtin hiding (unitValue) +import Unison.Runtime.Exception hiding (die) +import Unison.Runtime.Foreign +import Unison.Runtime.Foreign.Function (foreignCall) +import Unison.Runtime.MCode +import Unison.Runtime.Stack +import Unison.Runtime.TypeTags qualified as TT +import Unison.ShortHash qualified as SH +import Unison.Symbol (Symbol) +import Unison.Type qualified as Rf +import Unison.Util.Bytes qualified as By +import Unison.Util.EnumContainers as EC +import Unison.Util.Monoid qualified as Monoid +import Unison.Util.Pretty (toPlainUnbroken) +import Unison.Util.Pretty qualified as P +import Unison.Util.Text qualified as Util.Text +import UnliftIO qualified +import UnliftIO.Concurrent qualified as UnliftIO + +{- ORMOLU_DISABLE -} +#ifdef STACK_CHECK +import Unison.Debug qualified as Debug +import System.IO.Unsafe (unsafePerformIO) +#endif + +#ifdef OPT_CHECK +import Test.Inspection qualified as TI +#endif +{- ORMOLU_ENABLE -} + +-- | A ref storing every currently active thread. +-- This is helpful for cleaning up orphaned threads when the main process +-- completes. +-- +-- We track threads when running in a host process like UCM, +-- otherwise, in one-off environments 'Nothing' is used and we don't bother tracking forked threads since they'll be +-- cleaned up automatically on process termination. +type ActiveThreads = Maybe (IORef (Set ThreadId)) + +type Tag = Word64 + +-- dynamic environment +type DEnv = EnumMap Word64 Val + +type MCombs = RCombs Val + +type Combs = GCombs Void CombIx + +type MSection = RSection Val + +type MBranch = RBranch Val + +type MInstr = RInstr Val + +type MComb = RComb Val + +type MRef = RRef Val + +data Tracer + = NoTrace + | MsgTrace String String String + | SimpleTrace String + +-- code caching environment +data CCache = CCache + { sandboxed :: Bool, + tracer :: Bool -> Val -> Tracer, + -- Combinators in their original form, where they're easier to serialize into SCache + srcCombs :: TVar (EnumMap Word64 Combs), + combs :: TVar (EnumMap Word64 MCombs), + combRefs :: TVar (EnumMap Word64 Reference), + -- Combs which we're allowed to cache after evaluating + cacheableCombs :: TVar (EnumSet Word64), + tagRefs :: TVar (EnumMap Word64 Reference), + freshTm :: TVar Word64, + freshTy :: TVar Word64, + intermed :: TVar (M.Map Reference (SuperGroup Symbol)), + refTm :: TVar (M.Map Reference Word64), + refTy :: TVar (M.Map Reference Word64), + sandbox :: TVar (M.Map Reference (Set Reference)) + } + +refNumsTm :: CCache -> IO (M.Map Reference Word64) +refNumsTm cc = readTVarIO (refTm cc) + +refNumsTy :: CCache -> IO (M.Map Reference Word64) +refNumsTy cc = readTVarIO (refTy cc) + +refNumTm :: CCache -> Reference -> IO Word64 +refNumTm cc r = + refNumsTm cc >>= \case + (M.lookup r -> Just w) -> pure w + _ -> die $ "refNumTm: unknown reference: " ++ show r + +baseCCache :: Bool -> IO CCache +baseCCache sandboxed = do + CCache sandboxed noTrace + <$> newTVarIO srcCombs + <*> newTVarIO combs + <*> newTVarIO builtinTermBackref + <*> newTVarIO cacheableCombs + <*> newTVarIO builtinTypeBackref + <*> newTVarIO ftm + <*> newTVarIO fty + <*> newTVarIO mempty + <*> newTVarIO builtinTermNumbering + <*> newTVarIO builtinTypeNumbering + <*> newTVarIO baseSandboxInfo + where + cacheableCombs = mempty + noTrace _ _ = NoTrace + ftm = 1 + maximum builtinTermNumbering + fty = 1 + maximum builtinTypeNumbering + + rns = emptyRNs {dnum = refLookup "ty" builtinTypeNumbering} + + srcCombs :: EnumMap Word64 Combs + srcCombs = + numberedTermLookup + & mapWithKey + (\k v -> let r = builtinTermBackref ! k in emitComb @Symbol rns r k mempty (0, v)) + combs :: EnumMap Word64 MCombs + combs = + srcCombs + & sanitizeCombsOfForeignFuncs sandboxed sandboxedForeignFuncs + & absurdCombs + & resolveCombs Nothing + +info :: (Show a) => String -> a -> IO () +info ctx x = infos ctx (show x) + +infos :: String -> String -> IO () +infos ctx s = putStrLn $ ctx ++ ": " ++ s + +-- Entry point for evaluating a section +eval0 :: CCache -> ActiveThreads -> MSection -> IO () +eval0 env !activeThreads !co = do + stk <- alloc + cmbs <- readTVarIO $ combs env + (denv, k) <- + topDEnv cmbs <$> readTVarIO (refTy env) <*> readTVarIO (refTm env) + eval env denv activeThreads stk (k KE) dummyRef co + +mCombVal :: CombIx -> MComb -> Val +mCombVal cix (RComb (Comb comb)) = + BoxedVal (PAp cix comb nullSeg) +mCombVal _ (RComb (CachedVal _ clo)) = clo + +topDEnv :: + EnumMap Word64 MCombs -> + M.Map Reference Word64 -> + M.Map Reference Word64 -> + (DEnv, K -> K) +topDEnv combs rfTy rfTm + | Just n <- M.lookup exceptionRef rfTy, + rcrf <- Builtin (DTx.pack "raise"), + Just j <- M.lookup rcrf rfTm, + cix <- CIx rcrf j 0, + clo <- mCombVal cix $ rCombSection combs cix = + ( EC.mapSingleton n clo, + Mark 0 (EC.setSingleton n) mempty + ) +topDEnv _ _ _ = (mempty, id) + +-- Entry point for evaluating a numbered combinator. +-- An optional callback for the base of the stack may be supplied. +-- +-- This is the entry point actually used in the interactive +-- environment currently. +apply0 :: + Maybe (XStack -> IO ()) -> + CCache -> + ActiveThreads -> + Word64 -> + IO () +apply0 !callback env !threadTracker !i = do + stk <- alloc + cmbrs <- readTVarIO $ combRefs env + cmbs <- readTVarIO $ combs env + (denv, kf) <- + topDEnv cmbs <$> readTVarIO (refTy env) <*> readTVarIO (refTm env) + r <- case EC.lookup i cmbrs of + Just r -> pure r + Nothing -> die "apply0: missing reference to entry point" + let entryCix = (CIx r i 0) + case unRComb $ rCombSection cmbs entryCix of + Comb entryComb -> do + apply env denv threadTracker stk (kf k0) True ZArgs . BoxedVal $ + PAp entryCix entryComb nullSeg + -- if it's cached, we can just finish + CachedVal _ val -> bump stk >>= \stk -> poke stk val + where + k0 = fromMaybe KE (callback <&> \cb -> CB . Hook $ \stk -> cb stk) + +-- Apply helper currently used for forking. Creates the new stacks +-- necessary to evaluate a closure with the provided information. +apply1 :: + (Stack -> IO ()) -> + CCache -> + ActiveThreads -> + Val -> + IO () +apply1 callback env threadTracker clo = do + stk <- alloc + apply env mempty threadTracker stk k0 True ZArgs $ clo + where + k0 = CB $ Hook (\stk -> callback $ packXStack stk) + +unitValue :: Val +unitValue = BoxedVal $ unitClosure +{-# NOINLINE unitValue #-} + +unitClosure :: Closure +unitClosure = Enum Ty.unitRef (PackedTag 0) +{-# NOINLINE unitClosure #-} + +litToVal :: MLit -> Val +litToVal = \case + MT t -> BoxedVal $ Foreign (Wrap Rf.textRef t) + MM r -> BoxedVal $ Foreign (Wrap Rf.termLinkRef r) + MY r -> BoxedVal $ Foreign (Wrap Rf.typeLinkRef r) + MI i -> IntVal i + MN n -> NatVal n + MC c -> CharVal c + MD d -> DoubleVal d +{-# INLINE litToVal #-} + +{- ORMOLU_DISABLE -} +#ifdef STACK_CHECK +debugger :: (Show a) => Stack -> String -> a -> Bool +debugger stk msg a = unsafePerformIO $ do + dumpStack stk + Debug.debugLogM Debug.Interpreter (msg ++ ": " ++ show a) + pure False + +dumpStack :: Stack -> IO () +dumpStack stk@(Stack ap fp sp _ustk _bstk) + | sp - fp < 0 = Debug.debugLogM Debug.Interpreter "Stack before 👇: Empty" + | otherwise = do + stkLocals <- for [0 .. ((sp - fp) - 1)] $ \i -> do + peekOff stk i + Debug.debugM Debug.Interpreter "Stack frame locals 👇:" stkLocals + stkArgs <- for [0 .. ((fp - ap) - 1)] $ \i -> do + peekOff stk (i + (sp - fp)) + Debug.debugM Debug.Interpreter "Stack args 👇:" stkArgs +#endif +{- ORMOLU_ENABLE -} + +-- | Execute an instruction +exec :: + CCache -> + DEnv -> + ActiveThreads -> + Stack -> + K -> + Reference -> + MInstr -> + IO (DEnv, Stack, K) +{- ORMOLU_DISABLE -} +#ifdef STACK_CHECK +exec _ !_ !_ !stk !_ !_ instr + | debugger stk "exec" instr = undefined +#endif +{- ORMOLU_ENABLE -} +exec _ !denv !_activeThreads !stk !k _ (Info tx) = do + info tx stk + info tx k + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (Name r args) = do + v <- resolve env denv stk r + stk <- name stk args v + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (SetDyn p i) = do + val <- peekOff stk i + pure (EC.mapInsert p val denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (Capture p) = do + (cap, denv, stk, k) <- splitCont denv stk k p + stk <- bump stk + poke stk cap + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (UPrim1 op i) = do + stk <- uprim1 stk op i + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (UPrim2 op i j) = do + stk <- uprim2 stk op i j + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (BPrim1 MISS i) + | sandboxed env = die "attempted to use sandboxed operation: isMissing" + | otherwise = do + clink <- bpeekOff stk i + let link = case unwrapForeign $ marshalToForeign clink of + Ref r -> r + _ -> error "exec:BPrim1:MISS: Expected Ref" + m <- readTVarIO (intermed env) + stk <- bump stk + pokeBool stk $ (link `M.member` m) + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (BPrim1 CACH i) + | sandboxed env = die "attempted to use sandboxed operation: cache" + | otherwise = do + arg <- peekOffS stk i + news <- decodeCacheArgument arg + unknown <- cacheAdd news env + stk <- bump stk + pokeS + stk + (Sq.fromList $ boxedVal . Foreign . Wrap Rf.termLinkRef . Ref <$> unknown) + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (BPrim1 CVLD i) + | sandboxed env = die "attempted to use sandboxed operation: validate" + | otherwise = do + arg <- peekOffS stk i + news <- decodeCacheArgument arg + codeValidate (second codeGroup <$> news) env >>= \case + Nothing -> do + stk <- bump stk + pokeTag stk 0 + pure (denv, stk, k) + Just (Failure ref msg clo) -> do + stk <- bumpn stk 3 + bpoke stk (Foreign $ Wrap Rf.typeLinkRef ref) + pokeOffBi stk 1 msg + bpokeOff stk 2 clo + stk <- bump stk + pokeTag stk 1 + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (BPrim1 LKUP i) + | sandboxed env = die "attempted to use sandboxed operation: lookup" + | otherwise = do + clink <- bpeekOff stk i + let link = case unwrapForeign $ marshalToForeign clink of + Ref r -> r + _ -> error "exec:BPrim1:LKUP: Expected Ref" + m <- readTVarIO (intermed env) + rfn <- readTVarIO (refTm env) + cach <- readTVarIO (cacheableCombs env) + stk <- bump stk + stk <- case M.lookup link m of + Nothing + | Just w <- M.lookup link builtinTermNumbering, + Just sn <- EC.lookup w numberedTermLookup -> do + pokeBi stk (CodeRep (ANF.Rec [] sn) Uncacheable) + stk <- bump stk + stk <$ pokeTag stk 1 + | otherwise -> stk <$ pokeTag stk 0 + Just sg -> do + let ch + | Just n <- M.lookup link rfn, + EC.member n cach = + Cacheable + | otherwise = Uncacheable + pokeBi stk (CodeRep sg ch) + stk <- bump stk + stk <$ pokeTag stk 1 + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (BPrim1 TLTT i) = do + clink <- bpeekOff stk i + let shortHash = case unwrapForeign $ marshalToForeign clink of + Ref r -> toShortHash r + Con r _ -> CR.toShortHash r + let sh = Util.Text.fromText . SH.toText $ shortHash + stk <- bump stk + pokeBi stk sh + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (BPrim1 LOAD i) + | sandboxed env = die "attempted to use sandboxed operation: load" + | otherwise = do + v <- peekOffBi stk i + stk <- bumpn stk 2 + reifyValue env v >>= \case + Left miss -> do + pokeOffS stk 1 $ + Sq.fromList $ + boxedVal . Foreign . Wrap Rf.termLinkRef . Ref <$> miss + pokeTag stk 0 + Right x -> do + pokeOff stk 1 x + pokeTag stk 1 + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (BPrim1 VALU i) = do + m <- readTVarIO (tagRefs env) + c <- peekOff stk i + stk <- bump stk + pokeBi stk =<< reflectValue m c + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (BPrim1 DBTX i) + | sandboxed env = + die "attempted to use sandboxed operation: Debug.toText" + | otherwise = do + val <- peekOff stk i + stk <- bump stk + stk <- case tracer env False val of + NoTrace -> stk <$ pokeTag stk 0 + MsgTrace _ _ tx -> do + pokeBi stk (Util.Text.pack tx) + stk <- bump stk + stk <$ pokeTag stk 1 + SimpleTrace tx -> do + pokeBi stk (Util.Text.pack tx) + stk <- bump stk + stk <$ pokeTag stk 2 + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (BPrim1 SDBL i) + | sandboxed env = + die "attempted to use sandboxed operation: sandboxLinks" + | otherwise = do + tl <- peekOffBi stk i + stk <- bump stk + pokeS stk . encodeSandboxListResult =<< sandboxList env tl + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (BPrim1 op i) = do + stk <- bprim1 env stk op i + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (BPrim2 SDBX i j) = do + s <- peekOffS stk i + c <- bpeekOff stk j + l <- decodeSandboxArgument s + b <- checkSandboxing env l c + stk <- bump stk + pokeBool stk $ b + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (BPrim2 SDBV i j) + | sandboxed env = + die "attempted to use sandboxed operation: Value.validateSandboxed" + | otherwise = do + s <- peekOffS stk i + v <- peekOffBi stk j + l <- decodeSandboxArgument s + res <- checkValueSandboxing env l v + stk <- bump stk + bpoke stk $ encodeSandboxResult res + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (BPrim2 EQLU i j) = do + x <- peekOff stk i + y <- peekOff stk j + stk <- bump stk + pokeBool stk $ universalEq (==) x y + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (BPrim2 LEQU i j) = do + x <- peekOff stk i + y <- peekOff stk j + stk <- bump stk + pokeBool stk $ (universalCompare compare x y) /= GT + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (BPrim2 LESU i j) = do + x <- peekOff stk i + y <- peekOff stk j + stk <- bump stk + pokeBool stk $ (universalCompare compare x y) == LT + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (BPrim2 CMPU i j) = do + x <- peekOff stk i + y <- peekOff stk j + stk <- bump stk + pokeI stk . pred . fromEnum $ universalCompare compare x y + pure (denv, stk, k) +exec _ !_ !_activeThreads !stk !k r (BPrim2 THRO i j) = do + name <- peekOffBi @Util.Text.Text stk i + x <- peekOff stk j + () <- throwIO (BU (traceK r k) (Util.Text.toText name) x) + error "throwIO should never return" +exec env !denv !_activeThreads !stk !k _ (BPrim2 TRCE i j) + | sandboxed env = die "attempted to use sandboxed operation: trace" + | otherwise = do + tx <- peekOffBi stk i + clo <- peekOff stk j + case tracer env True clo of + NoTrace -> pure () + SimpleTrace str -> do + putStrLn $ "trace: " ++ Util.Text.unpack tx + putStrLn str + MsgTrace msg ugl pre -> do + putStrLn $ "trace: " ++ Util.Text.unpack tx + putStrLn "" + putStrLn msg + putStrLn "\nraw structure:\n" + putStrLn ugl + putStrLn "partial decompilation:\n" + putStrLn pre + pure (denv, stk, k) +exec _ !denv !_trackThreads !stk !k _ (BPrim2 op i j) = do + stk <- bprim2 stk op i j + pure (denv, stk, k) +exec env !denv !_activeThreads !stk !k _ (RefCAS refI ticketI valI) + | sandboxed env = die "attempted to use sandboxed operation: Ref.cas" + | otherwise = do + (ref :: IORef Val) <- peekOffBi stk refI + -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it + -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal + -- forcing of the values and tickets. + !(ticket :: Atomic.Ticket Val) <- peekOffBi stk ticketI + v <- peekOff stk valI + (r, _) <- Atomic.casIORef ref ticket v + stk <- bump stk + pokeBool stk r + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (Pack r t args) = do + clo <- buildData stk r t args + stk <- bump stk + bpoke stk clo + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (Print i) = do + t <- peekOffBi stk i + Tx.putStrLn (Util.Text.toText t) + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (Lit ml) = do + stk <- bump stk + poke stk $ litToVal ml + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (Reset ps) = do + (stk, a) <- saveArgs stk + pure (denv, stk, Mark a ps clos k) + where + clos = EC.restrictKeys denv ps +exec _ !denv !_activeThreads !stk !k _ (Seq as) = do + l <- closureArgs stk as + stk <- bump stk + pokeS stk $ Sq.fromList l + pure (denv, stk, k) +exec _env !denv !_activeThreads !stk !k _ (ForeignCall _ func args) = do + stk <- xStackIOToIO $ foreignCall func args (unpackXStack stk) + pure (denv, stk, k) +exec env !denv !activeThreads !stk !k _ (Fork i) + | sandboxed env = die "attempted to use sandboxed operation: fork" + | otherwise = do + tid <- forkEval env activeThreads =<< peekOff stk i + stk <- bump stk + bpoke stk . Foreign . Wrap Rf.threadIdRef $ tid + pure (denv, stk, k) +exec env !denv !activeThreads !stk !k _ (Atomically i) + | sandboxed env = die $ "attempted to use sandboxed operation: atomically" + | otherwise = do + v <- peekOff stk i + stk <- bump stk + atomicEval env activeThreads (poke stk) v + pure (denv, stk, k) +exec env !denv !activeThreads !stk !k _ (TryForce i) + | sandboxed env = die $ "attempted to use sandboxed operation: tryForce" + | otherwise = do + v <- peekOff stk i + stk <- bump stk -- Bump the boxed stack to make a slot for the result, which will be written in the callback if we succeed. + ev <- Control.Exception.try $ nestEval env activeThreads (poke stk) v + stk <- encodeExn stk ev + pure (denv, stk, k) +exec !_ !_ !_ !_ !_ _ (SandboxingFailure t) = do + die $ "Attempted to use disallowed builtin in sandboxed environment: " <> DTx.unpack t +{-# INLINE exec #-} + +encodeExn :: + Stack -> + Either SomeException () -> + IO Stack +encodeExn stk exc = do + case exc of + Right () -> do + stk <- bump stk + stk <$ pokeTag stk 1 + Left exn -> do + -- If we hit an exception, we have one unused slot on the stack + -- from where the result _would_ have been placed. + -- So here we bump one less than it looks like we should, and re-use + -- that slot. + stk <- bumpn stk 3 + pokeTag stk 0 + bpokeOff stk 1 $ Foreign (Wrap Rf.typeLinkRef link) + pokeOffBi stk 2 msg + stk <$ pokeOff stk 3 extra + where + disp e = Util.Text.pack $ show e + (link, msg, extra) + | Just (ioe :: IOException) <- fromException exn = + (Rf.ioFailureRef, disp ioe, unitValue) + | Just re <- fromException exn = case re of + PE _stk msg -> + (Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, unitValue) + BU _ tx val -> (Rf.runtimeFailureRef, Util.Text.fromText tx, val) + | Just (ae :: ArithException) <- fromException exn = + (Rf.arithmeticFailureRef, disp ae, unitValue) + | Just (nae :: NestedAtomically) <- fromException exn = + (Rf.stmFailureRef, disp nae, unitValue) + | Just (be :: BlockedIndefinitelyOnSTM) <- fromException exn = + (Rf.stmFailureRef, disp be, unitValue) + | Just (be :: BlockedIndefinitelyOnMVar) <- fromException exn = + (Rf.ioFailureRef, disp be, unitValue) + | Just (ie :: AsyncException) <- fromException exn = + (Rf.threadKilledFailureRef, disp ie, unitValue) + | otherwise = (Rf.miscFailureRef, disp exn, unitValue) + +-- | Evaluate a section +eval :: + CCache -> + DEnv -> + ActiveThreads -> + Stack -> + K -> + Reference -> + MSection -> + IO () +{- ORMOLU_DISABLE -} +#ifdef STACK_CHECK +eval _ !_ !_ !stk !_ !_ section + | debugger stk "eval" section = undefined +#endif +{- ORMOLU_ENABLE -} +eval env !denv !activeThreads !stk !k r (Match i (TestT df cs)) = do + t <- peekOffBi stk i + eval env denv activeThreads stk k r $ selectTextBranch t df cs +eval env !denv !activeThreads !stk !k r (Match i br) = do + n <- peekOffN stk i + eval env denv activeThreads stk k r $ selectBranch n br +eval env !denv !activeThreads !stk !k r (DMatch mr i br) = do + (t, stk) <- dumpDataNoTag mr stk =<< peekOff stk i + eval env denv activeThreads stk k r $ + selectBranch (maskTags t) br +eval env !denv !activeThreads !stk !k r (NMatch _mr i br) = do + n <- peekOffN stk i + eval env denv activeThreads stk k r $ selectBranch n br +eval env !denv !activeThreads !stk !k r (RMatch i pu br) = do + (t, stk) <- dumpDataNoTag Nothing stk =<< peekOff stk i + if t == PackedTag 0 + then eval env denv activeThreads stk k r pu + else case ANF.unpackTags t of + (ANF.rawTag -> e, ANF.rawTag -> t) + | Just ebs <- EC.lookup e br -> + eval env denv activeThreads stk k r $ selectBranch t ebs + | otherwise -> unhandledAbilityRequest +eval env !denv !activeThreads !stk !k _ (Yield args) + | asize stk > 0, + VArg1 i <- args = + peekOff stk i >>= apply env denv activeThreads stk k False ZArgs + | otherwise = do + stk <- moveArgs stk args + stk <- frameArgs stk + yield env denv activeThreads stk k +eval env !denv !activeThreads !stk !k _ (App ck r args) = + resolve env denv stk r + >>= apply env denv activeThreads stk k ck args +eval env !denv !activeThreads !stk !k _ (Call ck combIx rcomb args) = + enter env denv activeThreads stk k (combRef combIx) ck args rcomb +eval env !denv !activeThreads !stk !k _ (Jump i args) = + bpeekOff stk i >>= jump env denv activeThreads stk k args +eval env !denv !activeThreads !stk !k r (Let nw cix f sect) = do + (stk, fsz, asz) <- saveFrame stk + eval + env + denv + activeThreads + stk + (Push fsz asz cix f sect k) + r + nw +eval env !denv !activeThreads !stk !k r (Ins i nx) = do + (denv, stk, k) <- exec env denv activeThreads stk k r i + eval env denv activeThreads stk k r nx +eval _ !_ !_ !_activeThreads !_ _ Exit = pure () +eval _ !_ !_ !_activeThreads !_ _ (Die s) = die s +{-# NOINLINE eval #-} + +unhandledAbilityRequest :: (HasCallStack) => IO a +unhandledAbilityRequest = error . show . PE callStack . P.lit . fromString $ "eval: unhandled ability request" + +forkEval :: CCache -> ActiveThreads -> Val -> IO ThreadId +forkEval env activeThreads clo = + do + threadId <- + UnliftIO.forkFinally + (apply1 err env activeThreads clo) + (const cleanupThread) + trackThread threadId + pure threadId + where + err :: Stack -> IO () + err _ = pure () + trackThread :: ThreadId -> IO () + trackThread threadID = do + case activeThreads of + Nothing -> pure () + Just activeThreads -> UnliftIO.atomicModifyIORef' activeThreads (\ids -> (Set.insert threadID ids, ())) + cleanupThread :: IO () + cleanupThread = do + case activeThreads of + Nothing -> pure () + Just activeThreads -> do + myThreadId <- UnliftIO.myThreadId + UnliftIO.atomicModifyIORef' activeThreads (\ids -> (Set.delete myThreadId ids, ())) +{-# INLINE forkEval #-} + +nestEval :: CCache -> ActiveThreads -> (Val -> IO ()) -> Val -> IO () +nestEval env activeThreads write val = apply1 readBack env activeThreads val + where + readBack stk = peek stk >>= write +{-# INLINE nestEval #-} + +atomicEval :: CCache -> ActiveThreads -> (Val -> IO ()) -> Val -> IO () +atomicEval env activeThreads write val = + atomically . unsafeIOToSTM $ nestEval env activeThreads write val +{-# INLINE atomicEval #-} + +-- fast path application +enter :: + CCache -> + DEnv -> + ActiveThreads -> + Stack -> + K -> + Reference -> + Bool -> + Args -> + MComb -> + IO () +enter env !denv !activeThreads !stk !k !cref !sck !args = \case + (RComb (Lam a f entry)) -> do + -- check for stack check _skip_ + stk <- if sck then pure stk else ensure stk f + stk <- moveArgs stk args + stk <- acceptArgs stk a + eval env denv activeThreads stk k cref entry + (RComb (CachedVal _ val)) -> do + stk <- discardFrame stk + stk <- bump stk + poke stk val + yield env denv activeThreads stk k +{-# INLINE enter #-} + +-- fast path by-name delaying +name :: Stack -> Args -> Val -> IO Stack +name !stk !args = \case + BoxedVal (PAp cix comb seg) -> do + seg <- closeArgs I stk seg args + stk <- bump stk + bpoke stk $ PAp cix comb seg + pure stk + v -> die $ "naming non-function: " ++ show v +{-# INLINE name #-} + +-- slow path application +apply :: + CCache -> + DEnv -> + ActiveThreads -> + Stack -> + K -> + Bool -> + Args -> + Val -> + IO () +{- ORMOLU_DISABLE -} +#ifdef STACK_CHECK +apply _env !_denv !_activeThreads !stk !_k !_ck !args !val + | debugger stk "apply" (args, val) = undefined +#endif +{- ORMOLU_ENABLE -} +apply env !denv !activeThreads !stk !k !ck !args !val = + case val of + BoxedVal (PAp cix@(CIx combRef _ _) comb seg) -> + case comb of + LamI a f entry + | ck || a <= ac -> do + stk <- ensure stk f + stk <- moveArgs stk args + stk <- dumpSeg stk seg A + stk <- acceptArgs stk a + eval env denv activeThreads stk k combRef entry + | otherwise -> do + seg <- closeArgs C stk seg args + stk <- discardFrame =<< frameArgs stk + stk <- bump stk + bpoke stk $ PAp cix comb seg + yield env denv activeThreads stk k + where + ac = asize stk + countArgs args + scount seg + v -> zeroArgClosure v + where + zeroArgClosure :: Val -> IO () + zeroArgClosure v + | ZArgs <- args, + asize stk == 0 = do + stk <- discardFrame stk + stk <- bump stk + poke stk v + yield env denv activeThreads stk k + | otherwise = die $ "applying non-function: " ++ show v +{-# INLINE apply #-} + +jump :: + CCache -> + DEnv -> + ActiveThreads -> + Stack -> + K -> + Args -> + Closure -> + IO () +jump env !denv !activeThreads !stk !k !args clo = case clo of + Captured sk0 a seg -> do + let (p, sk) = adjust sk0 + seg <- closeArgs K stk seg args + stk <- discardFrame stk + stk <- dumpSeg stk seg $ F (countArgs args) a + stk <- adjustArgs stk p + repush env activeThreads stk denv sk k + _ -> die "jump: non-cont" + where + -- Adjusts a repushed continuation to account for pending arguments. If + -- there are any frames in the pushed continuation, the nearest one needs to + -- record the additional pending arguments. + -- + -- If the repushed continuation has no frames, then the arguments are still + -- pending, and the result stacks need to be adjusted. + adjust :: K -> (SZ, K) + adjust (Mark a rs denv k) = + (0, Mark (a + asize stk) rs denv k) + adjust (Push n a cix f rsect k) = + (0, Push n (a + asize stk) cix f rsect k) + adjust k = (asize stk, k) +{-# INLINE jump #-} + +repush :: + CCache -> + ActiveThreads -> + Stack -> + DEnv -> + K -> + K -> + IO () +repush env !activeThreads !stk = go + where + go !denv KE !k = yield env denv activeThreads stk k + go !denv (Mark a ps cs sk) !k = go denv' sk $ Mark a ps cs' k + where + denv' = cs <> EC.withoutKeys denv ps + cs' = EC.restrictKeys denv ps + go !denv (Push n a cix f rsect sk) !k = + go denv sk $ Push n a cix f rsect k + go !_ (CB _) !_ = die "repush: impossible" +{-# INLINE repush #-} + +moveArgs :: + Stack -> + Args -> + IO Stack +moveArgs !stk ZArgs = do + stk <- discardFrame stk + pure stk +moveArgs !stk (VArg1 i) = do + stk <- prepareArgs stk (Arg1 i) + pure stk +moveArgs !stk (VArg2 i j) = do + stk <- prepareArgs stk (Arg2 i j) + pure stk +moveArgs !stk (VArgR i l) = do + stk <- prepareArgs stk (ArgR i l) + pure stk +moveArgs !stk (VArgN as) = do + stk <- prepareArgs stk (ArgN as) + pure stk +moveArgs !stk (VArgV i) = do + stk <- + if l > 0 + then prepareArgs stk (ArgR 0 l) + else discardFrame stk + pure stk + where + l = fsize stk - i +{-# INLINE moveArgs #-} + +closureArgs :: Stack -> Args -> IO [Val] +closureArgs !_ ZArgs = pure [] +closureArgs !stk (VArg1 i) = do + x <- peekOff stk i + pure [x] +closureArgs !stk (VArg2 i j) = do + x <- peekOff stk i + y <- peekOff stk j + pure [x, y] +closureArgs !stk (VArgR i l) = + for (take l [i ..]) (peekOff stk) +closureArgs !stk (VArgN bs) = + for (PA.primArrayToList bs) (peekOff stk) +closureArgs !_ _ = + error "closure arguments can only be boxed." +{-# INLINE closureArgs #-} + +-- | Pack some number of args into a data type of the provided ref/tag type. +buildData :: + Stack -> Reference -> PackedTag -> Args -> IO Closure +buildData !_ !r !t ZArgs = pure $ Enum r t +buildData !stk !r !t (VArg1 i) = do + v <- peekOff stk i + pure $ Data1 r t v +buildData !stk !r !t (VArg2 i j) = do + v1 <- peekOff stk i + v2 <- peekOff stk j + pure $ Data2 r t v1 v2 +buildData !stk !r !t (VArgR i l) = do + seg <- augSeg I stk nullSeg (Just $ ArgR i l) + pure $ DataG r t seg +buildData !stk !r !t (VArgN as) = do + seg <- augSeg I stk nullSeg (Just $ ArgN as) + pure $ DataG r t seg +buildData !stk !r !t (VArgV i) = do + seg <- + if l > 0 + then augSeg I stk nullSeg (Just $ ArgR 0 l) + else pure nullSeg + pure $ DataG r t seg + where + l = fsize stk - i +{-# INLINE buildData #-} + +-- Dumps a data type closure to the stack without writing its tag. +-- Instead, the tag is returned for direct case analysis. +dumpDataNoTag :: + Maybe Reference -> + Stack -> + Val -> + IO (PackedTag, Stack) +dumpDataNoTag !mr !stk = \case + -- Normally we want to avoid dumping unboxed values since it's unnecessary, but sometimes we don't know the type of + -- the incoming value and end up dumping unboxed values, so we just push them back to the stack as-is. e.g. in type-casts/coercions + val@(UnboxedVal _ t) -> do + stk <- bump stk + poke stk val + pure (unboxedPackedTag t, stk) + BoxedVal clos -> case clos of + (Enum _ t) -> pure (t, stk) + (Data1 _ t x) -> do + stk <- bump stk + poke stk x + pure (t, stk) + (Data2 _ t x y) -> do + stk <- bumpn stk 2 + pokeOff stk 1 y + poke stk x + pure (t, stk) + (DataG _ t seg) -> do + stk <- dumpSeg stk seg S + pure (t, stk) + clo -> + die $ + "dumpDataNoTag: bad closure: " + ++ show clo + ++ maybe "" (\r -> "\nexpected type: " ++ show r) mr + where + unboxedPackedTag :: UnboxedTypeTag -> PackedTag + unboxedPackedTag = \case + CharTag -> TT.charTag + FloatTag -> TT.floatTag + IntTag -> TT.intTag + NatTag -> TT.natTag +{-# INLINE dumpDataNoTag #-} + +-- Note: although the representation allows it, it is impossible +-- to under-apply one sort of argument while over-applying the +-- other. Thus, it is unnecessary to worry about doing tricks to +-- only grab a certain number of arguments. +closeArgs :: + Augment -> + Stack -> + Seg -> + Args -> + IO Seg +closeArgs mode !stk !seg args = augSeg mode stk seg as + where + as = case args of + ZArgs -> Nothing + VArg1 i -> Just $ Arg1 i + VArg2 i j -> Just $ Arg2 i j + VArgR i l -> Just $ ArgR i l + VArgN as -> Just $ ArgN as + VArgV i -> a + where + a + | l > 0 = Just $ ArgR 0 l + | otherwise = Nothing + l = fsize stk - i + +uprim1 :: Stack -> UPrim1 -> Int -> IO Stack +uprim1 !stk DECI !i = do + m <- peekOffI stk i + stk <- bump stk + pokeI stk (m - 1) + pure stk +uprim1 !stk DECN !i = do + m <- peekOffN stk i + stk <- bump stk + pokeN stk (m - 1) + pure stk +uprim1 !stk INCI !i = do + m <- peekOffI stk i + stk <- bump stk + pokeI stk (m + 1) + pure stk +uprim1 !stk INCN !i = do + m <- peekOffN stk i + stk <- bump stk + pokeN stk (m + 1) + pure stk +uprim1 !stk TRNC !i = do + v <- peekOffI stk i + stk <- bump stk + unsafePokeIasN stk (max 0 v) + pure stk +uprim1 !stk NEGI !i = do + m <- upeekOff stk i + stk <- bump stk + pokeI stk (-m) + pure stk +uprim1 !stk SGNI !i = do + m <- upeekOff stk i + stk <- bump stk + pokeI stk (signum m) + pure stk +uprim1 !stk ABSF !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (abs d) + pure stk +uprim1 !stk CEIL !i = do + d <- peekOffD stk i + stk <- bump stk + pokeI stk (ceiling d) + pure stk +uprim1 !stk FLOR !i = do + d <- peekOffD stk i + stk <- bump stk + pokeI stk (floor d) + pure stk +uprim1 !stk TRNF !i = do + d <- peekOffD stk i + stk <- bump stk + pokeI stk (truncate d) + pure stk +uprim1 !stk RNDF !i = do + d <- peekOffD stk i + stk <- bump stk + pokeI stk (round d) + pure stk +uprim1 !stk EXPF !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (exp d) + pure stk +uprim1 !stk LOGF !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (log d) + pure stk +uprim1 !stk SQRT !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (sqrt d) + pure stk +uprim1 !stk COSF !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (cos d) + pure stk +uprim1 !stk SINF !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (sin d) + pure stk +uprim1 !stk TANF !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (tan d) + pure stk +uprim1 !stk COSH !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (cosh d) + pure stk +uprim1 !stk SINH !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (sinh d) + pure stk +uprim1 !stk TANH !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (tanh d) + pure stk +uprim1 !stk ACOS !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (acos d) + pure stk +uprim1 !stk ASIN !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (asin d) + pure stk +uprim1 !stk ATAN !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (atan d) + pure stk +uprim1 !stk ASNH !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (asinh d) + pure stk +uprim1 !stk ACSH !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (acosh d) + pure stk +uprim1 !stk ATNH !i = do + d <- peekOffD stk i + stk <- bump stk + pokeD stk (atanh d) + pure stk +uprim1 !stk ITOF !i = do + n <- upeekOff stk i + stk <- bump stk + pokeD stk (fromIntegral n) + pure stk +uprim1 !stk NTOF !i = do + n <- peekOffN stk i + stk <- bump stk + pokeD stk (fromIntegral n) + pure stk +uprim1 !stk LZRO !i = do + n <- peekOffN stk i + stk <- bump stk + unsafePokeIasN stk (countLeadingZeros n) + pure stk +uprim1 !stk TZRO !i = do + n <- peekOffN stk i + stk <- bump stk + unsafePokeIasN stk (countTrailingZeros n) + pure stk +uprim1 !stk POPC !i = do + n <- peekOffN stk i + stk <- bump stk + unsafePokeIasN stk (popCount n) + pure stk +uprim1 !stk COMN !i = do + n <- peekOffN stk i + stk <- bump stk + pokeN stk (complement n) + pure stk +uprim1 !stk COMI !i = do + n <- peekOffI stk i + stk <- bump stk + pokeI stk (complement n) + pure stk +uprim1 !stk NOTB !i = do + b <- peekOffBool stk i + stk <- bump stk + pokeBool stk (not b) + pure stk +{-# INLINE uprim1 #-} + +uprim2 :: Stack -> UPrim2 -> Int -> Int -> IO Stack +uprim2 !stk ADDI !i !j = do + m <- upeekOff stk i + n <- upeekOff stk j + stk <- bump stk + pokeI stk (m + n) + pure stk +uprim2 !stk ADDN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + pokeN stk (m + n) + pure stk +uprim2 !stk SUBI !i !j = do + m <- upeekOff stk i + n <- upeekOff stk j + stk <- bump stk + pokeI stk (m - n) + pure stk +uprim2 !stk DRPN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + let r = if n >= m then 0 else m - n + pokeN stk r + pure stk +uprim2 !stk SUBN !i !j = do + m <- peekOffI stk i + n <- peekOffI stk j + stk <- bump stk + pokeI stk (m - n) + pure stk +uprim2 !stk MULI !i !j = do + m <- upeekOff stk i + n <- upeekOff stk j + stk <- bump stk + pokeI stk (m * n) + pure stk +uprim2 !stk MULN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + pokeN stk (m * n) + pure stk +uprim2 !stk DIVI !i !j = do + m <- upeekOff stk i + n <- upeekOff stk j + stk <- bump stk + pokeI stk (m `div` n) + pure stk +uprim2 !stk MODI !i !j = do + m <- upeekOff stk i + n <- upeekOff stk j + stk <- bump stk + pokeI stk (m `mod` n) + pure stk +uprim2 !stk SHLI !i !j = do + m <- upeekOff stk i + n <- upeekOff stk j + stk <- bump stk + pokeI stk (m `shiftL` n) + pure stk +uprim2 !stk SHLN !i !j = do + m <- peekOffN stk i + n <- upeekOff stk j + stk <- bump stk + pokeN stk (m `shiftL` n) + pure stk +uprim2 !stk SHRI !i !j = do + m <- upeekOff stk i + n <- upeekOff stk j + stk <- bump stk + pokeI stk (m `shiftR` n) + pure stk +uprim2 !stk SHRN !i !j = do + m <- peekOffN stk i + n <- upeekOff stk j + stk <- bump stk + pokeN stk (m `shiftR` n) + pure stk +uprim2 !stk POWI !i !j = do + m <- upeekOff stk i + n <- peekOffN stk j + stk <- bump stk + pokeI stk (m ^ n) + pure stk +uprim2 !stk POWN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + pokeN stk (m ^ n) + pure stk +uprim2 !stk EQLI !i !j = do + m <- upeekOff stk i + n <- upeekOff stk j + stk <- bump stk + pokeBool stk $ m == n + pure stk +uprim2 !stk NEQI !i !j = do + m <- upeekOff stk i + n <- upeekOff stk j + stk <- bump stk + pokeBool stk $ m /= n + pure stk +uprim2 !stk EQLN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + pokeBool stk $ m == n + pure stk +uprim2 !stk NEQN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + pokeBool stk $ m /= n + pure stk +uprim2 !stk LEQI !i !j = do + m <- upeekOff stk i + n <- upeekOff stk j + stk <- bump stk + pokeBool stk $ m <= n + pure stk +uprim2 !stk LEQN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + pokeBool stk $ m <= n + pure stk +uprim2 !stk LESI !i !j = do + m <- upeekOff stk i + n <- upeekOff stk j + stk <- bump stk + pokeBool stk $ m < n + pure stk +uprim2 !stk LESN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + pokeBool stk $ m < n + pure stk +uprim2 !stk DIVN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + pokeN stk (m `div` n) + pure stk +uprim2 !stk MODN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + pokeN stk (m `mod` n) + pure stk +uprim2 !stk ADDF !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeD stk (x + y) + pure stk +uprim2 !stk SUBF !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeD stk (x - y) + pure stk +uprim2 !stk MULF !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeD stk (x * y) + pure stk +uprim2 !stk DIVF !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeD stk (x / y) + pure stk +uprim2 !stk LOGB !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeD stk (logBase x y) + pure stk +uprim2 !stk POWF !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeD stk (x ** y) + pure stk +uprim2 !stk MAXF !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeD stk (max x y) + pure stk +uprim2 !stk MINF !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeD stk (min x y) + pure stk +uprim2 !stk EQLF !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeBool stk $ x == y + pure stk +uprim2 !stk NEQF !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeBool stk $ x /= y + pure stk +uprim2 !stk LEQF !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeBool stk $ x <= y + pure stk +uprim2 !stk LESF !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeBool stk $ x < y + pure stk +uprim2 !stk ATN2 !i !j = do + x <- peekOffD stk i + y <- peekOffD stk j + stk <- bump stk + pokeD stk (atan2 x y) + pure stk +uprim2 !stk ANDN !i !j = do + x <- peekOffN stk i + y <- peekOffN stk j + stk <- bump stk + pokeN stk (x .&. y) + pure stk +uprim2 !stk ANDI !i !j = do + x <- peekOffI stk i + y <- peekOffI stk j + stk <- bump stk + pokeI stk (x .&. y) + pure stk +uprim2 !stk IORN !i !j = do + x <- peekOffN stk i + y <- peekOffN stk j + stk <- bump stk + pokeN stk (x .|. y) + pure stk +uprim2 !stk IORI !i !j = do + x <- peekOffI stk i + y <- peekOffI stk j + stk <- bump stk + pokeI stk (x .|. y) + pure stk +uprim2 !stk XORN !i !j = do + x <- peekOffN stk i + y <- peekOffN stk j + stk <- bump stk + pokeN stk (xor x y) + pure stk +uprim2 !stk XORI !i !j = do + x <- peekOffI stk i + y <- peekOffI stk j + stk <- bump stk + pokeI stk (xor x y) + pure stk +uprim2 !stk CAST !vi !ti = do + newTypeTag <- peekOffI stk ti + v <- upeekOff stk vi + stk <- bump stk + poke stk $ UnboxedVal v (unboxedTypeTagFromInt newTypeTag) + pure stk +uprim2 !stk ANDB !i !j = do + x <- peekOffBool stk i + y <- peekOffBool stk j + stk <- bump stk + pokeBool stk (x && y) + pure stk +uprim2 !stk IORB !i !j = do + x <- peekOffBool stk i + y <- peekOffBool stk j + stk <- bump stk + pokeBool stk (x || y) + pure stk +{-# INLINE uprim2 #-} + +bprim1 :: + CCache -> + Stack -> + BPrim1 -> + Int -> + IO Stack +bprim1 !_env !stk SIZT i = do + t <- peekOffBi stk i + stk <- bump stk + unsafePokeIasN stk $ Util.Text.size t + pure stk +bprim1 !_env !stk SIZS i = do + s <- peekOffS stk i + stk <- bump stk + unsafePokeIasN stk $ Sq.length s + pure stk +bprim1 !_env !stk ITOT i = do + n <- upeekOff stk i + stk <- bump stk + pokeBi stk . Util.Text.pack $ show n + pure stk +bprim1 !_env !stk NTOT i = do + n <- peekOffN stk i + stk <- bump stk + pokeBi stk . Util.Text.pack $ show n + pure stk +bprim1 !_env !stk FTOT i = do + f <- peekOffD stk i + stk <- bump stk + pokeBi stk . Util.Text.pack $ show f + pure stk +bprim1 !_env !stk USNC i = + peekOffBi stk i >>= \t -> case Util.Text.unsnoc t of + Nothing -> do + stk <- bump stk + pokeTag stk 0 + pure stk + Just (t, c) -> do + stk <- bumpn stk 3 + pokeOffC stk 2 $ c -- char value + pokeOffBi stk 1 t -- remaining text + pokeTag stk 1 -- 'Just' tag + pure stk +bprim1 !_env !stk UCNS i = + peekOffBi stk i >>= \t -> case Util.Text.uncons t of + Nothing -> do + stk <- bump stk + pokeTag stk 0 + pure stk + Just (c, t) -> do + stk <- bumpn stk 3 + pokeOffBi stk 2 t -- remaining text + pokeOffC stk 1 $ c -- char value + pokeTag stk 1 -- 'Just' tag + pure stk +bprim1 !_env !stk TTOI i = + peekOffBi stk i >>= \t -> case readm $ Util.Text.unpack t of + Just n + | fromIntegral (minBound :: Int) <= n, + n <= fromIntegral (maxBound :: Int) -> do + stk <- bumpn stk 2 + pokeTag stk 1 + pokeOffI stk 1 (fromInteger n) + pure stk + _ -> do + stk <- bump stk + pokeTag stk 0 + pure stk + where + readm ('+' : s) = readMaybe s + readm s = readMaybe s +bprim1 !_env !stk TTON i = + peekOffBi stk i >>= \t -> case readMaybe $ Util.Text.unpack t of + Just n + | 0 <= n, + n <= fromIntegral (maxBound :: Word) -> do + stk <- bumpn stk 2 + pokeTag stk 1 + pokeOffN stk 1 (fromInteger n) + pure stk + _ -> do + stk <- bump stk + pokeTag stk 0 + pure stk +bprim1 !_env !stk TTOF i = + peekOffBi stk i >>= \t -> case readMaybe $ Util.Text.unpack t of + Nothing -> do + stk <- bump stk + pokeTag stk 0 + pure stk + Just f -> do + stk <- bumpn stk 2 + pokeTag stk 1 + pokeOffD stk 1 f + pure stk +bprim1 !_env !stk VWLS i = + peekOffS stk i >>= \case + Sq.Empty -> do + stk <- bump stk + pokeTag stk 0 -- 'Empty' tag + pure stk + x Sq.:<| xs -> do + stk <- bumpn stk 3 + pokeOffS stk 2 xs -- remaining seq + pokeOff stk 1 x -- head + pokeTag stk 1 -- ':<|' tag + pure stk +bprim1 !_env !stk VWRS i = + peekOffS stk i >>= \case + Sq.Empty -> do + stk <- bump stk + pokeTag stk 0 -- 'Empty' tag + pure stk + xs Sq.:|> x -> do + stk <- bumpn stk 3 + pokeOff stk 2 x -- last + pokeOffS stk 1 xs -- remaining seq + pokeTag stk 1 -- ':|>' tag + pure stk +bprim1 !_env !stk PAKT i = do + s <- peekOffS stk i + stk <- bump stk + pokeBi stk . Util.Text.pack . toList $ val2char <$> s + pure stk + where + val2char :: Val -> Char + val2char (CharVal c) = c + val2char c = error $ "pack text: non-character closure: " ++ show c +bprim1 !_env !stk UPKT i = do + t <- peekOffBi stk i + stk <- bump stk + pokeS stk + . Sq.fromList + . fmap CharVal + . Util.Text.unpack + $ t + pure stk +bprim1 !_env !stk PAKB i = do + s <- peekOffS stk i + stk <- bump stk + pokeBi stk . By.fromWord8s . fmap val2w8 $ toList s + pure stk + where + -- TODO: Should we have a tag for bytes specifically? + val2w8 :: Val -> Word8 + val2w8 (NatVal n) = toEnum . fromEnum $ n + val2w8 c = error $ "pack bytes: non-natural closure: " ++ show c +bprim1 !_env !stk UPKB i = do + b <- peekOffBi stk i + stk <- bump stk + pokeS stk . Sq.fromList . fmap (NatVal . toEnum @Word64 . fromEnum @Word8) $ + By.toWord8s b + pure stk +bprim1 !_env !stk SIZB i = do + b <- peekOffBi stk i + stk <- bump stk + unsafePokeIasN stk $ By.size b + pure stk +bprim1 !_env !stk FLTB i = do + b <- peekOffBi stk i + stk <- bump stk + pokeBi stk $ By.flatten b + pure stk + +-- The docs for IORef state that IORef operations can be observed +-- out of order ([1]) but actually GHC does emit the appropriate +-- load and store barriers nowadays ([2], [3]). +-- +-- [1] https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-IORef.html#g:2 +-- [2] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L286 +-- [3] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L298 +bprim1 !_env !stk REFR i = do + (ref :: IORef Val) <- peekOffBi stk i + v <- IORef.readIORef ref + stk <- bump stk + poke stk v + pure stk +bprim1 !_env !stk REFN i = do + -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it + -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal + -- forcing of the values and tickets. + !v <- evaluate =<< peekOff stk i + ref <- IORef.newIORef v + stk <- bump stk + pokeBi stk ref + pure stk +bprim1 !env !stk RRFC i + | sandboxed env = die "attempted to use sandboxed operation: Ref.readForCAS" + | otherwise = do + (ref :: IORef Val) <- peekOffBi stk i + ticket <- Atomic.readForCAS ref + stk <- bump stk + pokeBi stk ticket + pure stk +bprim1 !_env !stk TIKR i = do + (t :: Atomic.Ticket Val) <- peekOffBi stk i + stk <- bump stk + let v = Atomic.peekTicket t + poke stk v + pure stk + +-- impossible +bprim1 !_env !stk MISS _ = pure stk +bprim1 !_env !stk CACH _ = pure stk +bprim1 !_env !stk LKUP _ = pure stk +bprim1 !_env !stk CVLD _ = pure stk +bprim1 !_env !stk TLTT _ = pure stk +bprim1 !_env !stk LOAD _ = pure stk +bprim1 !_env !stk VALU _ = pure stk +bprim1 !_env !stk DBTX _ = pure stk +bprim1 !_env !stk SDBL _ = pure stk +{-# INLINE bprim1 #-} + +bprim2 :: + Stack -> + BPrim2 -> + Int -> + Int -> + IO Stack +bprim2 !stk IXOT i j = do + x <- peekOffBi stk i + y <- peekOffBi stk j + case Util.Text.indexOf x y of + Nothing -> do + stk <- bump stk + pokeTag stk 0 + pure stk + Just i -> do + stk <- bumpn stk 2 + pokeTag stk 1 + pokeOffN stk 1 i + pure stk +bprim2 !stk IXOB i j = do + x <- peekOffBi stk i + y <- peekOffBi stk j + case By.indexOf x y of + Nothing -> do + stk <- bump stk + pokeTag stk 0 + pure stk + Just i -> do + stk <- bumpn stk 2 + pokeTag stk 1 + pokeOffN stk 1 i + pure stk +bprim2 !stk DRPT i j = do + n <- upeekOff stk i + t <- peekOffBi stk j + stk <- bump stk + -- Note; if n < 0, the Nat argument was greater than the maximum + -- signed integer. As an approximation, just return the empty + -- string, as a string larger than this would require an absurd + -- amount of memory. + pokeBi stk $ if n < 0 then Util.Text.empty else Util.Text.drop n t + pure stk +bprim2 !stk CATT i j = do + x <- peekOffBi stk i + y <- peekOffBi stk j + stk <- bump stk + pokeBi stk $ (x <> y :: Util.Text.Text) + pure stk +bprim2 !stk TAKT i j = do + n <- upeekOff stk i + t <- peekOffBi stk j + stk <- bump stk + -- Note: if n < 0, the Nat argument was greater than the maximum + -- signed integer. As an approximation, we just return the original + -- string, because it's unlikely such a large string exists. + pokeBi stk $ if n < 0 then t else Util.Text.take n t + pure stk +bprim2 !stk EQLT i j = do + x <- peekOffBi @Util.Text.Text stk i + y <- peekOffBi stk j + stk <- bump stk + pokeBool stk $ x == y + pure stk +bprim2 !stk LEQT i j = do + x <- peekOffBi @Util.Text.Text stk i + y <- peekOffBi stk j + stk <- bump stk + pokeBool stk $ x <= y + pure stk +bprim2 !stk LEST i j = do + x <- peekOffBi @Util.Text.Text stk i + y <- peekOffBi stk j + stk <- bump stk + pokeBool stk $ x < y + pure stk +bprim2 !stk DRPS i j = do + n <- upeekOff stk i + s <- peekOffS stk j + stk <- bump stk + -- Note: if n < 0, then the Nat argument was larger than the largest + -- signed integer. Seq actually doesn't handle this well, despite it + -- being possible to build (lazy) sequences this large. So, + -- approximate by yielding the empty sequence. + pokeS stk $ if n < 0 then Sq.empty else Sq.drop n s + pure stk +bprim2 !stk TAKS i j = do + n <- upeekOff stk i + s <- peekOffS stk j + stk <- bump stk + -- Note: if n < 0, then the Nat argument was greater than the + -- largest signed integer. It is possible to build such large + -- sequences, but the internal size will actually be wrong then. So, + -- we just return the original sequence as an approximation. + pokeS stk $ if n < 0 then s else Sq.take n s + pure stk +bprim2 !stk CONS i j = do + x <- peekOff stk i + s <- peekOffS stk j + stk <- bump stk + pokeS stk $ x Sq.<| s + pure stk +bprim2 !stk SNOC i j = do + s <- peekOffS stk i + x <- peekOff stk j + stk <- bump stk + pokeS stk $ s Sq.|> x + pure stk +bprim2 !stk CATS i j = do + x <- peekOffS stk i + y <- peekOffS stk j + stk <- bump stk + pokeS stk $ x Sq.>< y + pure stk +bprim2 !stk IDXS i j = do + n <- upeekOff stk i + s <- peekOffS stk j + case Sq.lookup n s of + Nothing -> do + stk <- bump stk + pokeTag stk 0 + pure stk + Just x -> do + stk <- bump stk + poke stk x + stk <- bump stk + pokeTag stk 1 + pure stk +bprim2 !stk SPLL i j = do + n <- upeekOff stk i + s <- peekOffS stk j + if Sq.length s < n + then do + stk <- bump stk + pokeTag stk 0 + pure stk + else do + stk <- bumpn stk 2 + let (l, r) = Sq.splitAt n s + pokeOffS stk 1 r + pokeS stk l + stk <- bump stk + pokeTag stk 1 + pure stk +bprim2 !stk SPLR i j = do + n <- upeekOff stk i + s <- peekOffS stk j + if Sq.length s < n + then do + stk <- bump stk + pokeTag stk 0 + pure stk + else do + stk <- bumpn stk 2 + let (l, r) = Sq.splitAt (Sq.length s - n) s + pokeOffS stk 1 r + pokeS stk l + stk <- bump stk + pokeTag stk 1 + pure stk +bprim2 !stk TAKB i j = do + n <- upeekOff stk i + b <- peekOffBi stk j + stk <- bump stk + -- If n < 0, the Nat argument was larger than the maximum signed + -- integer. Building a value this large would reuire an absurd + -- amount of memory, so just assume n is larger. + pokeBi stk $ if n < 0 then b else By.take n b + pure stk +bprim2 !stk DRPB i j = do + n <- upeekOff stk i + b <- peekOffBi stk j + stk <- bump stk + -- See above for n < 0 + pokeBi stk $ if n < 0 then By.empty else By.drop n b + pure stk +bprim2 !stk IDXB i j = do + n <- upeekOff stk i + b <- peekOffBi stk j + stk <- bump stk + stk <- case By.at n b of + Nothing -> stk <$ pokeTag stk 0 + Just x -> do + pokeByte stk x + stk <- bump stk + stk <$ pokeTag stk 1 + pure stk +bprim2 !stk CATB i j = do + l <- peekOffBi stk i + r <- peekOffBi stk j + stk <- bump stk + pokeBi stk (l <> r :: By.Bytes) + pure stk +bprim2 !stk REFW i j = do + (ref :: IORef Val) <- peekOffBi stk i + v <- peekOff stk j + IORef.writeIORef ref v + stk <- bump stk + bpoke stk unitClosure + pure stk +bprim2 !stk THRO _ _ = pure stk -- impossible +bprim2 !stk TRCE _ _ = pure stk -- impossible +bprim2 !stk EQLU _ _ = pure stk -- impossible +bprim2 !stk LEQU _ _ = pure stk -- impossible +bprim2 !stk LESU _ _ = pure stk -- impossible +bprim2 !stk CMPU _ _ = pure stk -- impossible +bprim2 !stk SDBX _ _ = pure stk -- impossible +bprim2 !stk SDBV _ _ = pure stk -- impossible +{-# INLINE bprim2 #-} + +yield :: + CCache -> + DEnv -> + ActiveThreads -> + Stack -> + K -> + IO () +yield env !denv !activeThreads !stk !k = leap denv k + where + leap !denv0 (Mark a ps cs k) = do + let denv = cs <> EC.withoutKeys denv0 ps + val = denv0 EC.! EC.findMin ps + v <- peek stk + stk <- bump stk + bpoke stk $ Data1 Rf.effectRef (PackedTag 0) v + stk <- adjustArgs stk a + apply env denv activeThreads stk k False (VArg1 0) val + leap !denv (Push fsz asz (CIx ref _ _) f nx k) = do + stk <- restoreFrame stk fsz asz + stk <- ensure stk f + eval env denv activeThreads stk k ref nx + leap _ (CB (Hook f)) = f (unpackXStack stk) + leap _ KE = pure () +{-# INLINE yield #-} + +selectTextBranch :: + Util.Text.Text -> MSection -> M.Map Util.Text.Text MSection -> MSection +selectTextBranch t df cs = M.findWithDefault df t cs +{-# INLINE selectTextBranch #-} + +selectBranch :: Tag -> MBranch -> MSection +selectBranch t (Test1 u y n) + | t == u = y + | otherwise = n +selectBranch t (Test2 u cu v cv e) + | t == u = cu + | t == v = cv + | otherwise = e +selectBranch t (TestW df cs) = lookupWithDefault df t cs +selectBranch _ (TestT {}) = error "impossible" +{-# INLINE selectBranch #-} + +-- Splits off a portion of the continuation up to a given prompt. +-- +-- The main procedure walks along the 'code' stack `k`, keeping track of how +-- many cells of the data stacks need to be captured. Then the `finish` function +-- performs the actual splitting of the data stacks together with some tweaking. +-- +-- Some special attention is required for pending arguments for over-applied +-- functions. They are part of the continuation, so how many there are at the +-- time of capture is recorded in the `Captured` closure, so that information +-- can be restored later. Also, the `Mark` frame that is popped off as part of +-- this operation potentially exposes pending arguments beyond the delimited +-- region, so those are restored in the `finish` function. +splitCont :: + DEnv -> + Stack -> + K -> + Word64 -> + IO (Val, DEnv, Stack, K) +splitCont !denv !stk !k !p = + walk denv asz KE k + where + asz = asize stk + walk :: EnumMap Word64 Val -> SZ -> K -> K -> IO (Val, EnumMap Word64 Val, Stack, K) + walk !denv !sz !ck KE = + die "fell off stack" >> finish denv sz 0 ck KE + walk !denv !sz !ck (CB _) = + die "fell off stack" >> finish denv sz 0 ck KE + walk !denv !sz !ck (Mark a ps cs k) + | EC.member p ps = finish denv' sz a ck k + | otherwise = walk denv' (sz + a) (Mark a ps cs' ck) k + where + denv' = cs <> EC.withoutKeys denv ps + cs' = EC.restrictKeys denv ps + walk !denv !sz !ck (Push n a br p brSect k) = + walk + denv + (sz + n + a) + (Push n a br p brSect ck) + k + + finish :: EnumMap Word64 Val -> SZ -> SZ -> K -> K -> (IO (Val, EnumMap Word64 Val, Stack, K)) + finish !denv !sz !a !ck !k = do + (seg, stk) <- grab stk sz + stk <- adjustArgs stk a + return (BoxedVal $ Captured ck asz seg, denv, stk, k) +{-# INLINE splitCont #-} + +resolve :: CCache -> DEnv -> Stack -> MRef -> IO Val +resolve _ _ _ (Env cix mcomb) = pure $ mCombVal cix mcomb +resolve _ _ stk (Stk i) = peekOff stk i +resolve env denv _ (Dyn i) = case EC.lookup i denv of + Just val -> pure val + Nothing -> unhandledErr "resolve" env i + +unhandledErr :: String -> CCache -> Word64 -> IO a +unhandledErr fname env i = + readTVarIO (tagRefs env) >>= \rs -> case EC.lookup i rs of + Just r -> bomb (show r) + Nothing -> bomb (show i) + where + bomb sh = die $ fname ++ ": unhandled ability request: " ++ sh + +rCombSection :: EnumMap Word64 MCombs -> CombIx -> MComb +rCombSection combs (CIx r n i) = + case EC.lookup n combs of + Just cmbs -> case EC.lookup i cmbs of + Just cmb -> RComb cmb + Nothing -> error $ "unknown section `" ++ show i ++ "` of combinator `" ++ show n ++ "`. Reference: " ++ show r + Nothing -> error $ "unknown combinator `" ++ show n ++ "`. Reference: " ++ show r + +resolveSection :: CCache -> Section -> IO MSection +resolveSection cc section = do + rcombs <- readTVarIO (combs cc) + pure $ rCombSection rcombs <$> section + +dummyRef :: Reference +dummyRef = Builtin (DTx.pack "dummy") + +updateMap :: (Semigroup s) => s -> TVar s -> STM s +updateMap new0 r = do + new <- evaluateSTM new0 + stateTVar r $ \old -> + let total = new <> old in (total, total) + +refLookup :: String -> M.Map Reference Word64 -> Reference -> Word64 +refLookup s m r + | Just w <- M.lookup r m = w + | otherwise = + error $ "refLookup:" ++ s ++ ": unknown reference: " ++ show r + +decodeCacheArgument :: + USeq -> IO [(Reference, Code)] +decodeCacheArgument s = for (toList s) $ \case + (Val _unboxed (Data2 _ _ (BoxedVal (Foreign x)) (BoxedVal (Data2 _ _ (BoxedVal (Foreign y)) _)))) -> + case unwrapForeign x of + Ref r -> pure (r, unwrapForeign y) + _ -> die "decodeCacheArgument: Con reference" + _ -> die "decodeCacheArgument: unrecognized value" + +decodeSandboxArgument :: USeq -> IO [Reference] +decodeSandboxArgument s = fmap join . for (toList s) $ \case + Val _ (Foreign x) -> case unwrapForeign x of + Ref r -> pure [r] + _ -> pure [] -- constructor + _ -> die "decodeSandboxArgument: unrecognized value" + +encodeSandboxListResult :: [Reference] -> Sq.Seq Val +encodeSandboxListResult = + Sq.fromList . fmap (boxedVal . Foreign . Wrap Rf.termLinkRef . Ref) + +encodeSandboxResult :: Either [Reference] [Reference] -> Closure +encodeSandboxResult (Left rfs) = + encodeLeft . boxedVal . Foreign . Wrap Rf.listRef $ encodeSandboxListResult rfs +encodeSandboxResult (Right rfs) = + encodeRight . boxedVal . Foreign . Wrap Rf.listRef $ encodeSandboxListResult rfs + +encodeLeft :: Val -> Closure +encodeLeft = Data1 Rf.eitherRef TT.leftTag + +encodeRight :: Val -> Closure +encodeRight = Data1 Rf.eitherRef TT.rightTag + +addRefs :: + TVar Word64 -> + TVar (M.Map Reference Word64) -> + TVar (EnumMap Word64 Reference) -> + S.Set Reference -> + STM (M.Map Reference Word64) +addRefs vfrsh vfrom vto rs = do + from0 <- readTVar vfrom + let new = S.filter (`M.notMember` from0) rs + sz = fromIntegral $ S.size new + frsh <- stateTVar vfrsh $ \i -> (i, i + sz) + let newl = S.toList new + from = M.fromList (zip newl [frsh ..]) <> from0 + nto = mapFromList (zip [frsh ..] newl) + writeTVar vfrom from + modifyTVar vto (nto <>) + pure from + +codeValidate :: + [(Reference, SuperGroup Symbol)] -> + CCache -> + IO (Maybe (Failure Closure)) +codeValidate tml cc = do + rty0 <- readTVarIO (refTy cc) + fty <- readTVarIO (freshTy cc) + let f b r + | b, M.notMember r rty0 = S.singleton r + | otherwise = mempty + ntys0 = (foldMap . foldMap) (foldGroupLinks f) tml + ntys = M.fromList $ zip (S.toList ntys0) [fty ..] + rty = ntys <> rty0 + ftm <- readTVarIO (freshTm cc) + rtm0 <- readTVarIO (refTm cc) + let rs = fst <$> tml + rtm = rtm0 `M.union` M.fromList (zip rs [ftm ..]) + rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) (const Nothing) + combinate (n, (r, g)) = evaluate $ emitCombs rns r n g + (Nothing <$ traverse_ combinate (zip [ftm ..] tml)) + `catch` \(CE cs perr) -> + let msg = Util.Text.pack $ toPlainUnbroken perr + extra = Foreign . Wrap Rf.textRef . Util.Text.pack $ show cs + in pure . Just $ Failure ioFailureRef msg extra + +sandboxList :: CCache -> Referent -> IO [Reference] +sandboxList cc (Ref r) = do + sands <- readTVarIO $ sandbox cc + pure . maybe [] S.toList $ M.lookup r sands +sandboxList _ _ = pure [] + +checkSandboxing :: + CCache -> + [Reference] -> + Closure -> + IO Bool +checkSandboxing cc allowed0 c = do + sands <- readTVarIO $ sandbox cc + let f r + | Just rs <- M.lookup r sands = + rs `S.difference` allowed + | otherwise = mempty + pure $ S.null (closureTermRefs f c) + where + allowed = S.fromList allowed0 + +-- Checks a Value for sandboxing. A Left result indicates that some +-- dependencies of the Value are unknown. A Right result indicates +-- builtins transitively referenced by the Value that are disallowed. +checkValueSandboxing :: + CCache -> + [Reference] -> + ANF.Value -> + IO (Either [Reference] [Reference]) +checkValueSandboxing cc allowed0 v = do + sands <- readTVarIO $ sandbox cc + have <- readTVarIO $ intermed cc + let f False r + | Nothing <- M.lookup r have, + not (isBuiltin r) = + (S.singleton r, mempty) + | Just rs <- M.lookup r sands = + (mempty, rs `S.difference` allowed) + f _ _ = (mempty, mempty) + case valueLinks f v of + (miss, sbx) + | S.null miss -> pure . Right $ S.toList sbx + | otherwise -> pure . Left $ S.toList miss + where + allowed = S.fromList allowed0 + +-- Just evaluating to force exceptions. Shouldn't actually be that +-- unsafe. +evaluateSTM :: a -> STM a +evaluateSTM x = unsafeIOToSTM (evaluate x) + +cacheAdd0 :: + S.Set Reference -> + [(Reference, Code)] -> + [(Reference, Set Reference)] -> + CCache -> + IO () +cacheAdd0 ntys0 termSuperGroups sands cc = do + let toAdd = M.fromList (termSuperGroups <&> second codeGroup) + (unresolvedCacheableCombs, unresolvedNonCacheableCombs) <- atomically $ do + have <- readTVar (intermed cc) + let new = M.difference toAdd have + let sz = fromIntegral $ M.size new + let rgs = M.toList new + let rs = fst <$> rgs + int <- updateMap new (intermed cc) + rty <- addRefs (freshTy cc) (refTy cc) (tagRefs cc) ntys0 + ntm <- stateTVar (freshTm cc) $ \i -> (i, i + sz) + rtm <- updateMap (M.fromList $ zip rs [ntm ..]) (refTm cc) + -- check for missing references + let arities = fmap (head . ANF.arities) int <> builtinArities + inlinfo = ANF.buildInlineMap int <> builtinInlineInfo + rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) (flip M.lookup arities) + combinate :: Word64 -> (Reference, SuperGroup Symbol) -> (Word64, EnumMap Word64 Comb) + combinate n (r, g) = + (n, emitCombs rns r n $ ANF.inline inlinfo g) + let combRefUpdates = (mapFromList $ zip [ntm ..] rs) + let combIdFromRefMap = (M.fromList $ zip rs [ntm ..]) + let newCacheableCombs = + termSuperGroups + & mapMaybe + ( \case + (ref, CodeRep _ Cacheable) -> + M.lookup ref combIdFromRefMap + _ -> Nothing + ) + & EC.setFromList + newCombRefs <- updateMap combRefUpdates (combRefs cc) + (unresolvedNewCombs, unresolvedCacheableCombs, unresolvedNonCacheableCombs, updatedCombs) <- stateTVar (combs cc) \oldCombs -> + let unresolvedNewCombs :: EnumMap Word64 (GCombs any CombIx) + unresolvedNewCombs = + absurdCombs . sanitizeCombsOfForeignFuncs (sandboxed cc) sandboxedForeignFuncs . mapFromList $ zipWith combinate [ntm ..] rgs + (unresolvedCacheableCombs, unresolvedNonCacheableCombs) = + EC.mapToList unresolvedNewCombs & foldMap \(w, gcombs) -> + if EC.member w newCacheableCombs + then (EC.mapSingleton w gcombs, mempty) + else (mempty, EC.mapSingleton w gcombs) + newCombs :: EnumMap Word64 MCombs + newCombs = resolveCombs (Just oldCombs) $ unresolvedNewCombs + updatedCombs = newCombs <> oldCombs + in ((unresolvedNewCombs, unresolvedCacheableCombs, unresolvedNonCacheableCombs, updatedCombs), updatedCombs) + nsc <- updateMap unresolvedNewCombs (srcCombs cc) + nsn <- updateMap (M.fromList sands) (sandbox cc) + ncc <- updateMap newCacheableCombs (cacheableCombs cc) + -- Now that the code cache is primed with everything we need, + -- we can pre-evaluate the top-level constants. + pure $ int `seq` rtm `seq` newCombRefs `seq` updatedCombs `seq` nsn `seq` ncc `seq` nsc `seq` (unresolvedCacheableCombs, unresolvedNonCacheableCombs) + preEvalTopLevelConstants unresolvedCacheableCombs unresolvedNonCacheableCombs cc + +preEvalTopLevelConstants :: (EnumMap Word64 (GCombs Val CombIx)) -> (EnumMap Word64 (GCombs Val CombIx)) -> CCache -> IO () +preEvalTopLevelConstants cacheableCombs newCombs cc = do + activeThreads <- Just <$> UnliftIO.newIORef mempty + evaluatedCacheableCombsVar <- newTVarIO mempty + for_ (EC.mapToList cacheableCombs) \(w, _) -> do + let hook xstk = do + val <- peek (packXStack xstk) + atomically $ do + modifyTVar evaluatedCacheableCombsVar $ EC.mapInsert w (EC.mapSingleton 0 $ CachedVal w val) + apply0 (Just hook) cc activeThreads w + + evaluatedCacheableCombs <- readTVarIO evaluatedCacheableCombsVar + let allNew = evaluatedCacheableCombs <> newCombs + -- Rewrite all the inlined combinator references to point to the + -- new cached versions. + atomically $ modifyTVar (combs cc) (\existingCombs -> (resolveCombs (Just $ EC.mapDifference existingCombs allNew) allNew) <> existingCombs) + +expandSandbox :: + Map Reference (Set Reference) -> + [(Reference, SuperGroup Symbol)] -> + [(Reference, Set Reference)] +expandSandbox sand0 groups = fixed mempty + where + f sand False r = fromMaybe mempty $ M.lookup r sand + f _ True _ = mempty + + h sand (r, foldGroupLinks (f sand) -> s) + | S.null s = Nothing + | otherwise = Just (r, s) + + fixed extra + | extra == extra' = new + | otherwise = fixed extra' + where + new = mapMaybe (h $ extra <> sand0) groups + extra' = M.fromList new + +cacheAdd :: + [(Reference, Code)] -> + CCache -> + IO [Reference] +cacheAdd l cc = do + rtm <- readTVarIO (refTm cc) + rty <- readTVarIO (refTy cc) + sand <- readTVarIO (sandbox cc) + let known = M.keysSet rtm <> S.fromList (view _1 <$> l) + f b r + | not b, S.notMember r known = Const (S.singleton r, mempty) + | b, M.notMember r rty = Const (mempty, S.singleton r) + | otherwise = Const (mempty, mempty) + (missing, tys) = + getConst $ (foldMap . foldMap . foldGroup) (foldGroupLinks f) l + l'' = filter (\(r, _) -> M.notMember r rtm) l + l' = map (second codeGroup) l'' + if S.null missing + then [] <$ cacheAdd0 tys l'' (expandSandbox sand l') cc + else pure $ S.toList missing + +reflectValue :: EnumMap Word64 Reference -> Val -> IO ANF.Value +reflectValue rty = goV + where + err s = "reflectValue: cannot prepare value for serialization: " ++ s + refTy w + | Just r <- EC.lookup w rty = pure r + | otherwise = + die $ err "unknown type reference" + + goIx (CIx r _ i) = ANF.GR r i + + goV :: Val -> IO ANF.Value + goV = \case + -- For back-compatibility we reflect all Unboxed values into boxed literals, we could change this in the future, + -- but there's not much of a big reason to. + + NatVal n -> pure . ANF.BLit $ ANF.Pos n + IntVal n + | n >= 0 -> pure . ANF.BLit $ ANF.Pos (fromIntegral n) + | otherwise -> pure . ANF.BLit $ ANF.Neg (fromIntegral (abs n)) + DoubleVal f -> pure . ANF.BLit $ ANF.Float f + CharVal c -> pure . ANF.BLit $ ANF.Char c + val@(Val _ clos) -> + case clos of + (PApV cix _rComb args) -> + ANF.Partial (goIx cix) <$> traverse goV args + (DataC r t segs) -> + ANF.Data r (maskTags t) <$> traverse goV segs + (CapV k _ segs) -> + ANF.Cont <$> traverse goV segs <*> goK k + (Foreign f) -> ANF.BLit <$> goF f + BlackHole -> die $ err "black hole" + UnboxedTypeTag {} -> die $ err $ "unknown unboxed value" <> show val + + goK (CB _) = die $ err "callback continuation" + goK KE = pure ANF.KE + goK (Mark a ps de k) = do + ps <- traverse refTy (EC.setToList ps) + de <- traverse (\(k, v) -> (,) <$> refTy k <*> goV v) (mapToList de) + ANF.Mark (fromIntegral a) ps (M.fromList de) <$> goK k + goK (Push f a cix _ _rsect k) = + ANF.Push + (fromIntegral f) + (fromIntegral a) + (goIx cix) + <$> goK k + + goF f + | Just t <- maybeUnwrapBuiltin f = + pure (ANF.Text t) + | Just b <- maybeUnwrapBuiltin f = + pure (ANF.Bytes b) + | Just s <- maybeUnwrapForeign Rf.listRef f = + ANF.List <$> traverse goV s + | Just l <- maybeUnwrapForeign Rf.termLinkRef f = + pure (ANF.TmLink l) + | Just l <- maybeUnwrapForeign Rf.typeLinkRef f = + pure (ANF.TyLink l) + | Just v <- maybeUnwrapForeign Rf.valueRef f = + pure (ANF.Quote v) + | Just g <- maybeUnwrapForeign Rf.codeRef f = + pure (ANF.Code g) + | Just a <- maybeUnwrapForeign Rf.ibytearrayRef f = + pure (ANF.BArr a) + | Just a <- maybeUnwrapForeign Rf.iarrayRef f = + ANF.Arr <$> traverse goV a + | otherwise = die $ err $ "foreign value: " <> (show f) + +reifyValue :: CCache -> ANF.Value -> IO (Either [Reference] Val) +reifyValue cc val = do + erc <- + atomically $ do + combs <- readTVar (combs cc) + rtm <- readTVar (refTm cc) + case S.toList $ S.filter (`M.notMember` rtm) tmLinks of + [] -> do + newTy <- addRefs (freshTy cc) (refTy cc) (tagRefs cc) tyLinks + pure . Right $ (combs, newTy, rtm) + l -> pure (Left l) + traverse (\rfs -> reifyValue0 rfs val) erc + where + f False r = (mempty, S.singleton r) + f True r = (S.singleton r, mempty) + (tyLinks, tmLinks) = valueLinks f val + +reifyValue0 :: + (EnumMap Word64 MCombs, M.Map Reference Word64, M.Map Reference Word64) -> + ANF.Value -> + IO Val +reifyValue0 (combs, rty, rtm) = goV + where + err s = "reifyValue: cannot restore value: " ++ s + refTy r + | Just w <- M.lookup r rty = pure w + | otherwise = die . err $ "unknown type reference: " ++ show r + refTm r + | Just w <- M.lookup r rtm = pure w + | otherwise = die . err $ "unknown term reference: " ++ show r + goIx :: ANF.GroupRef -> IO (CombIx, MComb) + goIx (ANF.GR r i) = + refTm r <&> \n -> + let cix = (CIx r n i) + in (cix, rCombSection combs cix) + + goV :: ANF.Value -> IO Val + goV (ANF.Partial gr vs) = + goIx gr >>= \case + (cix, RComb (Comb rcomb)) -> boxedVal . PApV cix rcomb <$> traverse goV vs + (_, RComb (CachedVal _ val)) + | [] <- vs -> pure val + | otherwise -> die . err $ msg + where + msg = "reifyValue0: non-trivial partial application to cached value" + goV (ANF.Data r t0 vs) = do + t <- flip packTags (fromIntegral t0) . fromIntegral <$> refTy r + boxedVal . DataC r t <$> traverse goV vs + goV (ANF.Cont vs k) = do + k' <- goK k + vs' <- traverse goV vs + pure . boxedVal $ cv k' vs' + where + cv k s = CapV k a s + where + ksz = frameDataSize k + a = fromIntegral $ length s - ksz + goV (ANF.BLit l) = goL l + + goK ANF.KE = pure KE + goK (ANF.Mark a ps de k) = + mrk + <$> traverse refTy ps + <*> traverse (\(k, v) -> (,) <$> refTy k <*> (goV v)) (M.toList de) + <*> goK k + where + mrk ps de k = + Mark (fromIntegral a) (setFromList ps) (mapFromList de) k + goK (ANF.Push f a gr k) = + goIx gr >>= \case + (cix, RComb (Lam _ fr sect)) -> + Push + (fromIntegral f) + (fromIntegral a) + cix + fr + sect + <$> goK k + (CIx r _ _, _) -> + die . err $ + "tried to reify a continuation with a cached value resumption" + ++ show r + + goL :: ANF.BLit -> IO Val + goL (ANF.Text t) = pure . boxedVal . Foreign $ Wrap Rf.textRef t + goL (ANF.List l) = boxedVal . Foreign . Wrap Rf.listRef <$> traverse goV l + goL (ANF.TmLink r) = pure . boxedVal . Foreign $ Wrap Rf.termLinkRef r + goL (ANF.TyLink r) = pure . boxedVal . Foreign $ Wrap Rf.typeLinkRef r + goL (ANF.Bytes b) = pure . boxedVal . Foreign $ Wrap Rf.bytesRef b + goL (ANF.Quote v) = pure . boxedVal . Foreign $ Wrap Rf.valueRef v + goL (ANF.Code g) = pure . boxedVal . Foreign $ Wrap Rf.codeRef g + goL (ANF.BArr a) = pure . boxedVal . Foreign $ Wrap Rf.ibytearrayRef a + goL (ANF.Char c) = pure $ CharVal c + goL (ANF.Pos w) = + -- TODO: Should this be a Nat or an Int? + pure $ NatVal w + goL (ANF.Neg w) = pure $ IntVal (negate (fromIntegral w :: Int)) + goL (ANF.Float d) = pure $ DoubleVal d + goL (ANF.Arr a) = boxedVal . Foreign . Wrap Rf.iarrayRef <$> traverse goV a + +-- Universal comparison functions + +closureNum :: Closure -> Int +closureNum PAp {} = 0 +closureNum DataC {} = 1 +closureNum Captured {} = 2 +closureNum Foreign {} = 3 +closureNum UnboxedTypeTag {} = 4 +closureNum BlackHole {} = 5 + +universalEq :: + (Foreign -> Foreign -> Bool) -> + Val -> + Val -> + Bool +universalEq frn = eqVal + where + eql :: (a -> b -> Bool) -> [a] -> [b] -> Bool + eql cm l r = length l == length r && and (zipWith cm l r) + eqVal :: Val -> Val -> Bool + eqVal (UnboxedVal v1 t1) (UnboxedVal v2 t2) = matchUnboxedTypes t1 t2 && v1 == v2 + eqVal (BoxedVal x) (BoxedVal y) = eqc x y + eqVal _ _ = False + eqc :: Closure -> Closure -> Bool + eqc (DataC _ ct1 [w1]) (DataC _ ct2 [w2]) = + matchTags ct1 ct2 && eqVal w1 w2 + eqc (DataC _ ct1 vs1) (DataC _ ct2 vs2) = + ct1 == ct2 + && eqValList vs1 vs2 + eqc (PApV cix1 _ segs1) (PApV cix2 _ segs2) = + cix1 == cix2 + && eqValList segs1 segs2 + eqc (CapV k1 a1 vs1) (CapV k2 a2 vs2) = + eqK k1 k2 + && a1 == a2 + && eqValList vs1 vs2 + eqc (Foreign fl) (Foreign fr) + | Just al <- maybeUnwrapForeign @(PA.Array Val) Rf.iarrayRef fl, + Just ar <- maybeUnwrapForeign @(PA.Array Val) Rf.iarrayRef fr = + arrayEq eqVal al ar + | Just sl <- maybeUnwrapForeign @(Seq Val) Rf.listRef fl, + Just sr <- maybeUnwrapForeign @(Seq Val) Rf.listRef fr = + length sl == length sr && and (Sq.zipWith eqVal sl sr) + | otherwise = frn fl fr + eqc c d = closureNum c == closureNum d + + eqValList :: [Val] -> [Val] -> Bool + eqValList vs1 vs2 = eql eqVal vs1 vs2 + + eqK :: K -> K -> Bool + eqK KE KE = True + eqK (CB cb) (CB cb') = cb == cb' + eqK (Mark a ps m k) (Mark a' ps' m' k') = + a == a' && ps == ps' && liftEq eqVal m m' && eqK k k' + eqK (Push f a ci _ _sect k) (Push f' a' ci' _ _sect' k') = + f == f' && a == a' && ci == ci' && eqK k k' + eqK _ _ = False + +-- serialization doesn't necessarily preserve Int tags, so be +-- more accepting for those. +matchTags :: PackedTag -> PackedTag -> Bool +matchTags ct1 ct2 = + ct1 == ct2 + || (ct1 == TT.intTag && ct2 == TT.natTag) + || (ct1 == TT.natTag && ct2 == TT.intTag) + +-- serialization doesn't necessarily preserve Int tags, so be +-- more accepting for those. +matchUnboxedTypes :: UnboxedTypeTag -> UnboxedTypeTag -> Bool +matchUnboxedTypes ct1 ct2 = + ct1 == ct2 + || (ct1 == IntTag && ct2 == NatTag) + || (ct1 == NatTag && ct2 == IntTag) + +arrayEq :: (a -> a -> Bool) -> PA.Array a -> PA.Array a -> Bool +arrayEq eqc l r + | PA.sizeofArray l /= PA.sizeofArray r = False + | otherwise = go (PA.sizeofArray l - 1) + where + go i + | i < 0 = True + | otherwise = eqc (PA.indexArray l i) (PA.indexArray r i) && go (i - 1) + +-- IEEE floating point layout is such that comparison as integers +-- somewhat works. Positive floating values map to positive integers +-- and negatives map to negatives. The corner cases are: +-- +-- 1. If both numbers are negative, ordering is flipped. +-- 2. There is both +0 and -0, with -0 being represented as the +-- minimum signed integer. +-- 3. NaN does weird things. +-- +-- So, the strategy here is to compare normally if one argument is +-- positive, since positive numbers compare normally to others. +-- Otherwise, the sign bit is cleared and the numbers are compared +-- backwards. Clearing the sign bit maps -0 to +0 and maps a negative +-- number to its absolute value (including infinities). The multiple +-- NaN values are just handled according to bit patterns, rather than +-- IEEE specified behavior. +-- +-- Transitivity is somewhat non-obvious for this implementation. +-- +-- if i <= j and j <= k +-- if j > 0 then k > 0, so all 3 comparisons use `compare` +-- if k > 0 then k > i, since i <= j <= 0 +-- if all 3 are <= 0, all 3 comparisons use the alternate +-- comparison, which is transitive via `compare` +compareAsFloat :: Int -> Int -> Ordering +compareAsFloat i j + | i > 0 || j > 0 = compare i j + | otherwise = compare (clear j) (clear i) + where + clear k = clearBit k 64 + +universalCompare :: + (Foreign -> Foreign -> Ordering) -> + Val -> + Val -> + Ordering +universalCompare frn = cmpVal False + where + cmpVal :: Bool -> Val -> Val -> Ordering + cmpVal tyEq = \cases + (BoxedVal c1) (BoxedVal c2) -> cmpc tyEq c1 c2 + (UnboxedVal {}) (BoxedVal {}) -> LT + (BoxedVal {}) (UnboxedVal {}) -> GT + (NatVal i) (NatVal j) -> compare i j + (UnboxedVal v1 t1) (UnboxedVal v2 t2) -> cmpUnboxed tyEq (t1, v1) (t2, v2) + cmpl :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering + cmpl cm l r = + compare (length l) (length r) <> fold (zipWith cm l r) + cmpc :: Bool -> Closure -> Closure -> Ordering + cmpc tyEq = \cases + (DataC rf1 ct1 vs1) (DataC rf2 ct2 vs2) -> + (if tyEq && ct1 /= ct2 then compare rf1 rf2 else EQ) + <> compare (maskTags ct1) (maskTags ct2) + -- when comparing corresponding `Any` values, which have + -- existentials inside check that type references match + <> cmpValList (tyEq || rf1 == Rf.anyRef) vs1 vs2 + (PApV cix1 _ segs1) (PApV cix2 _ segs2) -> + compare cix1 cix2 + <> cmpValList tyEq segs1 segs2 + (CapV k1 a1 vs1) (CapV k2 a2 vs2) -> + cmpK tyEq k1 k2 + <> compare a1 a2 + <> cmpValList True vs1 vs2 + (Foreign fl) (Foreign fr) + | Just sl <- maybeUnwrapForeign @(Seq Val) Rf.listRef fl, + Just sr <- maybeUnwrapForeign @(Seq Val) Rf.listRef fr -> + fold (Sq.zipWith (cmpVal tyEq) sl sr) + <> compare (length sl) (length sr) + | Just al <- maybeUnwrapForeign @(PA.Array Val) Rf.iarrayRef fl, + Just ar <- maybeUnwrapForeign @(PA.Array Val) Rf.iarrayRef fr -> + arrayCmp (cmpVal tyEq) al ar + | otherwise -> frn fl fr + (UnboxedTypeTag t1) (UnboxedTypeTag t2) -> compare t1 t2 + (BlackHole) (BlackHole) -> EQ + c d -> comparing closureNum c d + + cmpUnboxed :: Bool -> (UnboxedTypeTag, Int) -> (UnboxedTypeTag, Int) -> Ordering + cmpUnboxed tyEq = \cases + -- Need to cast to Nat or else maxNat == -1 and it flips comparisons of large Nats. + -- TODO: Investigate whether bit-twiddling is faster than using Haskell's fromIntegral. + (IntTag, n1) (IntTag, n2) -> compare n1 n2 + (NatTag, n1) (NatTag, n2) -> compare (fromIntegral n1 :: Word64) (fromIntegral n2 :: Word64) + (NatTag, n1) (IntTag, n2) + | n2 < 0 -> GT + | otherwise -> compare (fromIntegral n1 :: Word64) (fromIntegral n2 :: Word64) + (IntTag, n1) (NatTag, n2) + | n1 < 0 -> LT + | otherwise -> compare (fromIntegral n1 :: Word64) (fromIntegral n2 :: Word64) + (FloatTag, n1) (FloatTag, n2) -> compareAsFloat n1 n2 + (t1, v1) (t2, v2) -> + Monoid.whenM tyEq (compare t1 t2) + <> compare v1 v2 + + cmpValList :: Bool -> [Val] -> [Val] -> Ordering + cmpValList tyEq vs1 vs2 = cmpl (cmpVal tyEq) vs1 vs2 + + cmpK :: Bool -> K -> K -> Ordering + cmpK tyEq = \cases + KE KE -> EQ + (CB cb) (CB cb') -> compare cb cb' + (Mark a ps m k) (Mark a' ps' m' k') -> + compare a a' + <> compare ps ps' + <> liftCompare (cmpVal tyEq) m m' + <> cmpK tyEq k k' + (Push f a ci _ _sect k) (Push f' a' ci' _ _sect' k') -> + compare f f' + <> compare a a' + <> compare ci ci' + <> cmpK tyEq k k' + KE _ -> LT + _ KE -> GT + (CB {}) _ -> LT + _ (CB {}) -> GT + (Mark {}) _ -> LT + _ (Mark {}) -> GT + +arrayCmp :: + (a -> a -> Ordering) -> + PA.Array a -> + PA.Array a -> + Ordering +arrayCmp cmpVal l r = + comparing PA.sizeofArray l r <> go (PA.sizeofArray l - 1) + where + go i + | i < 0 = EQ + | otherwise = cmpVal (PA.indexArray l i) (PA.indexArray r i) <> go (i - 1) + +die :: (HasCallStack) => String -> IO a +die s = do + void . throwIO . PE callStack . P.lit . fromString $ s + -- This is unreachable, but we need it to fix some quirks in GHC's + -- worker/wrapper optimization, specifically, it seems that when throwIO's polymorphic return + -- value is specialized to a type like 'Stack' which we want GHC to unbox, it will sometimes + -- fail to unbox it, possibly because it can't unbox it when it's strictly a type application. + -- For whatever reason, this seems to fix it while still allowing us to throw exceptions in IO + -- like we prefer. + error "unreachable" +{-# INLINE die #-} + +{- ORMOLU_DISABLE -} +#ifdef OPT_CHECK +-- Assert that we don't allocate any 'Stack' objects in 'eval', since we expect GHC to always +-- trigger the worker/wrapper optimization and unbox it fully, and if it fails to do so, we want to +-- know about it. +-- +-- Note: this must remain in this module, it can't be moved to a testing module, this is a requirement of the inspection +-- testing library. +-- +-- Note: We _must_ check 'eval0' instead of 'eval' here because if you simply check 'eval', you'll be +-- testing the 'wrapper' part of the worker/wrapper, which will always mention the 'Stack' object as part of its +-- unwrapping, and since there's no way to refer to the generated wrapper directly, we instead refer to 'eval0' +-- which allocates its own stack to pass in, meaning it's one level above the wrapper, and GHC should always detect that +-- it can call the worker directly without using the wrapper. +-- See: https://github.com/nomeata/inspection-testing/issues/50 for more information. +-- +-- If this test starts failing, here are some things you can check. +-- +-- 1. Are 'Stack's being passed to dynamic functions? If so, try changing those functions to take an 'XStack' instead, +-- and manually unpack/pack the 'Stack' where necessary. +-- 2. Are there calls to 'die' or 'throwIO' or something similar in which a fully polymorphic type variable is being +-- specialized to 'Stack'? Sometimes this trips up the optimization, you can try using an 'error' instead, or even +-- following the 'throwIO' with a useless call to @error "unreachable"@, this seems to help for some reason. +-- See this page for more info on precise exceptions: https://gitlab.haskell.org/ghc/ghc/-/wikis/exceptions/precise-exceptions +-- +-- Best of luck! +TI.inspect $ 'eval0 `TI.hasNoType` ''Stack +#endif +{- ORMOLU_ENABLE -} diff --git a/parser-typechecker/src/Unison/Runtime/Pattern.hs b/unison-runtime/src/Unison/Runtime/Pattern.hs similarity index 100% rename from parser-typechecker/src/Unison/Runtime/Pattern.hs rename to unison-runtime/src/Unison/Runtime/Pattern.hs diff --git a/unison-runtime/src/Unison/Runtime/Serialize.hs b/unison-runtime/src/Unison/Runtime/Serialize.hs new file mode 100644 index 0000000000..251040ff5d --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Serialize.hs @@ -0,0 +1,595 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Runtime.Serialize where + +import Control.Monad (replicateM) +import Data.Bits (Bits) +import Data.ByteString qualified as B +import Data.Bytes.Get hiding (getBytes) +import Data.Bytes.Get qualified as Ser +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Bytes.Signed (Unsigned) +import Data.Bytes.VarInt +import Data.Foldable (traverse_) +import Data.Int (Int64) +import Data.Map.Strict as Map (Map, fromList, toList) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Vector.Primitive qualified as BA +import Data.Word (Word64, Word8) +import GHC.Exts as IL (IsList (..)) +import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) +import Unison.ConstructorType qualified as CT +import Unison.Hash (Hash) +import Unison.Hash qualified as Hash +import Unison.Reference (Id' (..), Reference, Reference' (Builtin, DerivedId), pattern Derived) +import Unison.Referent (Referent, pattern Con, pattern Ref) +import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Exception +import Unison.Runtime.MCode + ( BPrim1 (..), + BPrim2 (..), + UPrim1 (..), + UPrim2 (..), + ) +import Unison.Util.Bytes qualified as Bytes +import Unison.Util.EnumContainers as EC + +unknownTag :: (MonadGet m) => String -> Word8 -> m a +unknownTag t w = + remaining >>= \r -> + exn $ + "unknown " + ++ t + ++ " word: " + ++ show w + ++ " (" + ++ show (fromIntegral @_ @Int r) + ++ " bytes remaining)" + +class Tag t where + tag2word :: t -> Word8 + word2tag :: (MonadGet m) => Word8 -> m t + +putTag :: (MonadPut m) => (Tag t) => t -> m () +putTag = putWord8 . tag2word + +getTag :: (MonadGet m) => (Tag t) => m t +getTag = word2tag =<< getWord8 + +-- Some basics, moved over from V1 serialization +putChar :: (MonadPut m) => Char -> m () +putChar = serialize . VarInt . fromEnum + +getChar :: (MonadGet m) => m Char +getChar = toEnum . unVarInt <$> deserialize + +putFloat :: (MonadPut m) => Double -> m () +putFloat = serializeBE + +getFloat :: (MonadGet m) => m Double +getFloat = deserializeBE + +putBool :: (MonadPut m) => Bool -> m () +putBool b = putWord8 (if b then 1 else 0) + +getBool :: (MonadGet m) => m Bool +getBool = d =<< getWord8 + where + d 0 = pure False + d 1 = pure True + d n = exn $ "getBool: bad tag: " ++ show n + +putNat :: (MonadPut m) => Word64 -> m () +putNat = putWord64be + +getNat :: (MonadGet m) => m Word64 +getNat = getWord64be + +putInt :: (MonadPut m) => Int64 -> m () +putInt = serializeBE + +getInt :: (MonadGet m) => m Int64 +getInt = deserializeBE + +putLength :: + ( MonadPut m, + Integral n, + Integral (Unsigned n), + Bits n, + Bits (Unsigned n) + ) => + n -> + m () +putLength = serialize . VarInt + +getLength :: + ( MonadGet m, + Integral n, + Integral (Unsigned n), + Bits n, + Bits (Unsigned n) + ) => + m n +getLength = unVarInt <$> deserialize + +-- Checks for negatives, in case you put an Integer, which does not +-- behave properly for negative numbers. +putPositive :: + (MonadPut m, Bits n, Bits (Unsigned n), Integral n, Integral (Unsigned n)) => + n -> + m () +putPositive n + | n < 0 = exn $ "putPositive: negative number: " ++ show (toInteger n) + | otherwise = serialize (VarInt n) + +-- Reads as an Integer, then checks that the result will fit in the +-- result type. +getPositive :: forall m n. (Bounded n, Integral n, MonadGet m) => m n +getPositive = validate . unVarInt =<< deserialize + where + mx0 :: n + mx0 = maxBound + mx :: Integer + mx = fromIntegral mx0 + + validate :: Integer -> m n + validate n + | n <= mx = pure $ fromIntegral n + | otherwise = fail $ "getPositive: overflow: " ++ show n + +putFoldable :: + (Foldable f, MonadPut m) => (a -> m ()) -> f a -> m () +putFoldable putA as = do + putLength (length as) + traverse_ putA as + +putMap :: (MonadPut m) => (a -> m ()) -> (b -> m ()) -> Map a b -> m () +putMap putA putB m = putFoldable (putPair putA putB) (Map.toList m) + +getList :: (MonadGet m) => m a -> m [a] +getList a = getLength >>= (`replicateM` a) + +getMap :: (MonadGet m, Ord a) => m a -> m b -> m (Map a b) +getMap getA getB = Map.fromList <$> getList (getPair getA getB) + +putEnumMap :: + (MonadPut m) => + (EnumKey k) => + (k -> m ()) -> + (v -> m ()) -> + EnumMap k v -> + m () +putEnumMap pk pv m = putFoldable (putPair pk pv) (mapToList m) + +getEnumMap :: (MonadGet m) => (EnumKey k) => m k -> m v -> m (EnumMap k v) +getEnumMap gk gv = mapFromList <$> getList (getPair gk gv) + +putEnumSet :: (MonadPut m) => (EnumKey k) => (k -> m ()) -> EnumSet k -> m () +putEnumSet pk s = putLength (setSize s) *> traverseSet_ pk s + +getEnumSet :: (MonadGet m) => (EnumKey k) => m k -> m (EnumSet k) +getEnumSet gk = setFromList <$> getList gk + +putMaybe :: (MonadPut m) => Maybe a -> (a -> m ()) -> m () +putMaybe Nothing _ = putWord8 0 +putMaybe (Just a) putA = putWord8 1 *> putA a + +getMaybe :: (MonadGet m) => m a -> m (Maybe a) +getMaybe getA = + getWord8 >>= \tag -> case tag of + 0 -> pure Nothing + 1 -> Just <$> getA + _ -> unknownTag "Maybe" tag + +putPair :: (MonadPut m) => (a -> m ()) -> (b -> m ()) -> (a, b) -> m () +putPair putA putB (a, b) = putA a *> putB b + +getPair :: (MonadGet m) => m a -> m b -> m (a, b) +getPair = liftA2 (,) + +getBytes :: (MonadGet m) => m Bytes.Bytes +getBytes = Bytes.fromChunks <$> getList getBlock + +putBytes :: (MonadPut m) => Bytes.Bytes -> m () +putBytes = putFoldable putBlock . Bytes.chunks + +getByteArray :: (MonadGet m) => m PA.ByteArray +getByteArray = PA.byteArrayFromList <$> getList getWord8 + +putByteArray :: (MonadPut m) => PA.ByteArray -> m () +putByteArray a = putFoldable putWord8 (IL.toList a) + +getArray :: (MonadGet m) => m a -> m (PA.Array a) +getArray getThing = PA.arrayFromList <$> getList getThing + +putArray :: (MonadPut m) => (a -> m ()) -> PA.Array a -> m () +putArray putThing a = putFoldable putThing (IL.toList a) + +getBlock :: (MonadGet m) => m Bytes.Chunk +getBlock = getLength >>= fmap Bytes.byteStringToChunk . getByteString + +putBlock :: (MonadPut m) => Bytes.Chunk -> m () +putBlock b = putLength (BA.length b) *> putByteString (Bytes.chunkToByteString b) + +putHash :: (MonadPut m) => Hash -> m () +putHash h = do + let bs = Hash.toByteString h + putLength (B.length bs) + putByteString bs + +getHash :: (MonadGet m) => m Hash +getHash = do + len <- getLength + bs <- B.copy <$> Ser.getBytes len + pure $ Hash.fromByteString bs + +putReferent :: (MonadPut m) => Referent -> m () +putReferent = \case + Ref r -> do + putWord8 0 + putReference r + Con r ct -> do + putWord8 1 + putConstructorReference r + putConstructorType ct + +getReferent :: (MonadGet m) => m Referent +getReferent = do + tag <- getWord8 + case tag of + 0 -> Ref <$> getReference + 1 -> Con <$> getConstructorReference <*> getConstructorType + _ -> unknownTag "getReferent" tag + +getConstructorType :: (MonadGet m) => m CT.ConstructorType +getConstructorType = + getWord8 >>= \case + 0 -> pure CT.Data + 1 -> pure CT.Effect + t -> unknownTag "getConstructorType" t + +putConstructorType :: (MonadPut m) => CT.ConstructorType -> m () +putConstructorType = \case + CT.Data -> putWord8 0 + CT.Effect -> putWord8 1 + +putText :: (MonadPut m) => Text -> m () +putText text = do + let bs = encodeUtf8 text + putLength $ B.length bs + putByteString bs + +getText :: (MonadGet m) => m Text +getText = do + len <- getLength + bs <- B.copy <$> Ser.getBytes len + pure $ decodeUtf8 bs + +putReference :: (MonadPut m) => Reference -> m () +putReference r = case r of + Builtin name -> do + putWord8 0 + putText name + Derived hash i -> do + putWord8 1 + putHash hash + putLength i + +getReference :: (MonadGet m) => m Reference +getReference = do + tag <- getWord8 + case tag of + 0 -> Builtin <$> getText + 1 -> DerivedId <$> (Id <$> getHash <*> getLength) + _ -> unknownTag "Reference" tag + +putConstructorReference :: (MonadPut m) => ConstructorReference -> m () +putConstructorReference (ConstructorReference r i) = do + putReference r + putLength i + +getConstructorReference :: (MonadGet m) => m ConstructorReference +getConstructorReference = + ConstructorReference <$> getReference <*> getLength + +instance Tag UPrim1 where + tag2word DECI = 0 + tag2word DECN = 1 + tag2word INCI = 2 + tag2word INCN = 3 + tag2word NEGI = 4 + tag2word SGNI = 5 + tag2word LZRO = 6 + tag2word TZRO = 7 + tag2word COMN = 8 + tag2word COMI = 9 + tag2word POPC = 10 + tag2word ABSF = 11 + tag2word EXPF = 12 + tag2word LOGF = 13 + tag2word SQRT = 14 + tag2word COSF = 15 + tag2word ACOS = 16 + tag2word COSH = 17 + tag2word ACSH = 18 + tag2word SINF = 19 + tag2word ASIN = 20 + tag2word SINH = 21 + tag2word ASNH = 22 + tag2word TANF = 23 + tag2word ATAN = 24 + tag2word TANH = 25 + tag2word ATNH = 26 + tag2word ITOF = 27 + tag2word NTOF = 28 + tag2word CEIL = 29 + tag2word FLOR = 30 + tag2word TRNF = 31 + tag2word RNDF = 32 + tag2word TRNC = 33 + tag2word NOTB = 34 + + word2tag 0 = pure DECI + word2tag 1 = pure DECN + word2tag 2 = pure INCI + word2tag 3 = pure INCN + word2tag 4 = pure NEGI + word2tag 5 = pure SGNI + word2tag 6 = pure LZRO + word2tag 7 = pure TZRO + word2tag 8 = pure COMN + word2tag 9 = pure COMI + word2tag 10 = pure POPC + word2tag 11 = pure ABSF + word2tag 12 = pure EXPF + word2tag 13 = pure LOGF + word2tag 14 = pure SQRT + word2tag 15 = pure COSF + word2tag 16 = pure ACOS + word2tag 17 = pure COSH + word2tag 18 = pure ACSH + word2tag 19 = pure SINF + word2tag 20 = pure ASIN + word2tag 21 = pure SINH + word2tag 22 = pure ASNH + word2tag 23 = pure TANF + word2tag 24 = pure ATAN + word2tag 25 = pure TANH + word2tag 26 = pure ATNH + word2tag 27 = pure ITOF + word2tag 28 = pure NTOF + word2tag 29 = pure CEIL + word2tag 30 = pure FLOR + word2tag 31 = pure TRNF + word2tag 32 = pure RNDF + word2tag 33 = pure TRNC + word2tag 34 = pure NOTB + word2tag n = unknownTag "UPrim1" n + +instance Tag UPrim2 where + tag2word ADDI = 0 + tag2word ADDN = 1 + tag2word SUBI = 2 + tag2word SUBN = 3 + tag2word MULI = 4 + tag2word MULN = 5 + tag2word DIVI = 6 + tag2word MODI = 7 + tag2word DIVN = 8 + tag2word MODN = 9 + tag2word SHLI = 10 + tag2word SHLN = 11 + tag2word SHRI = 12 + tag2word SHRN = 13 + tag2word POWI = 14 + tag2word POWN = 15 + tag2word EQLI = 16 + tag2word NEQI = 17 + tag2word EQLN = 18 + tag2word NEQN = 19 + tag2word LEQI = 20 + tag2word LEQN = 21 + tag2word LESI = 22 + tag2word LESN = 23 + tag2word ANDN = 24 + tag2word ANDI = 25 + tag2word IORN = 26 + tag2word IORI = 27 + tag2word XORN = 28 + tag2word XORI = 29 + tag2word EQLF = 30 + tag2word NEQF = 31 + tag2word LEQF = 32 + tag2word LESF = 33 + tag2word ADDF = 34 + tag2word SUBF = 35 + tag2word MULF = 36 + tag2word DIVF = 37 + tag2word ATN2 = 38 + tag2word POWF = 39 + tag2word LOGB = 40 + tag2word MAXF = 41 + tag2word MINF = 42 + tag2word CAST = 43 + tag2word DRPN = 44 + tag2word ANDB = 45 + tag2word IORB = 46 + + word2tag 0 = pure ADDI + word2tag 1 = pure ADDN + word2tag 2 = pure SUBI + word2tag 3 = pure SUBN + word2tag 4 = pure MULI + word2tag 5 = pure MULN + word2tag 6 = pure DIVI + word2tag 7 = pure MODI + word2tag 8 = pure DIVN + word2tag 9 = pure MODN + word2tag 10 = pure SHLI + word2tag 11 = pure SHLN + word2tag 12 = pure SHRI + word2tag 13 = pure SHRN + word2tag 14 = pure POWI + word2tag 15 = pure POWN + word2tag 16 = pure EQLI + word2tag 17 = pure NEQI + word2tag 18 = pure EQLN + word2tag 19 = pure NEQN + word2tag 20 = pure LEQI + word2tag 21 = pure LEQN + word2tag 22 = pure LESI + word2tag 23 = pure LESN + word2tag 24 = pure ANDN + word2tag 25 = pure ANDI + word2tag 26 = pure IORN + word2tag 27 = pure IORI + word2tag 28 = pure XORN + word2tag 29 = pure XORI + word2tag 30 = pure EQLF + word2tag 31 = pure NEQF + word2tag 32 = pure LEQF + word2tag 33 = pure LESF + word2tag 34 = pure ADDF + word2tag 35 = pure SUBF + word2tag 36 = pure MULF + word2tag 37 = pure DIVF + word2tag 38 = pure ATN2 + word2tag 39 = pure POWF + word2tag 40 = pure LOGB + word2tag 41 = pure MAXF + word2tag 42 = pure MINF + word2tag 43 = pure CAST + word2tag 44 = pure DRPN + word2tag 45 = pure ANDB + word2tag 46 = pure IORB + word2tag n = unknownTag "UPrim2" n + +instance Tag BPrim1 where + tag2word SIZT = 0 + tag2word USNC = 1 + tag2word UCNS = 2 + tag2word ITOT = 3 + tag2word NTOT = 4 + tag2word FTOT = 5 + tag2word TTOI = 6 + tag2word TTON = 7 + tag2word TTOF = 8 + tag2word PAKT = 9 + tag2word UPKT = 10 + tag2word VWLS = 11 + tag2word VWRS = 12 + tag2word SIZS = 13 + tag2word PAKB = 14 + tag2word UPKB = 15 + tag2word SIZB = 16 + tag2word FLTB = 17 + tag2word MISS = 18 + tag2word CACH = 19 + tag2word LKUP = 20 + tag2word LOAD = 21 + tag2word CVLD = 22 + tag2word VALU = 23 + tag2word TLTT = 24 + tag2word DBTX = 25 + tag2word SDBL = 26 + tag2word REFN = 27 + tag2word REFR = 28 + tag2word RRFC = 29 + tag2word TIKR = 30 + + word2tag 0 = pure SIZT + word2tag 1 = pure USNC + word2tag 2 = pure UCNS + word2tag 3 = pure ITOT + word2tag 4 = pure NTOT + word2tag 5 = pure FTOT + word2tag 6 = pure TTOI + word2tag 7 = pure TTON + word2tag 8 = pure TTOF + word2tag 9 = pure PAKT + word2tag 10 = pure UPKT + word2tag 11 = pure VWLS + word2tag 12 = pure VWRS + word2tag 13 = pure SIZS + word2tag 14 = pure PAKB + word2tag 15 = pure UPKB + word2tag 16 = pure SIZB + word2tag 17 = pure FLTB + word2tag 18 = pure MISS + word2tag 19 = pure CACH + word2tag 20 = pure LKUP + word2tag 21 = pure LOAD + word2tag 22 = pure CVLD + word2tag 23 = pure VALU + word2tag 24 = pure TLTT + word2tag 25 = pure DBTX + word2tag 26 = pure SDBL + word2tag 27 = pure REFN + word2tag 28 = pure REFR + word2tag 29 = pure RRFC + word2tag 30 = pure TIKR + word2tag n = unknownTag "BPrim1" n + +instance Tag BPrim2 where + tag2word EQLU = 0 + tag2word LEQU = 1 + tag2word LESU = 2 + tag2word CMPU = 3 + tag2word DRPT = 4 + tag2word CATT = 5 + tag2word TAKT = 6 + tag2word EQLT = 7 + tag2word LEQT = 8 + tag2word LEST = 9 + tag2word DRPS = 10 + tag2word CATS = 11 + tag2word TAKS = 12 + tag2word CONS = 13 + tag2word SNOC = 14 + tag2word IDXS = 15 + tag2word SPLL = 16 + tag2word SPLR = 17 + tag2word TAKB = 18 + tag2word DRPB = 19 + tag2word IDXB = 20 + tag2word CATB = 21 + tag2word THRO = 22 + tag2word TRCE = 23 + tag2word SDBX = 24 + tag2word IXOT = 25 + tag2word IXOB = 26 + tag2word SDBV = 27 + tag2word REFW = 28 + + word2tag 0 = pure EQLU + word2tag 1 = pure LEQU + word2tag 2 = pure LESU + word2tag 3 = pure CMPU + word2tag 4 = pure DRPT + word2tag 5 = pure CATT + word2tag 6 = pure TAKT + word2tag 7 = pure EQLT + word2tag 8 = pure LEQT + word2tag 9 = pure LEST + word2tag 10 = pure DRPS + word2tag 11 = pure CATS + word2tag 12 = pure TAKS + word2tag 13 = pure CONS + word2tag 14 = pure SNOC + word2tag 15 = pure IDXS + word2tag 16 = pure SPLL + word2tag 17 = pure SPLR + word2tag 18 = pure TAKB + word2tag 19 = pure DRPB + word2tag 20 = pure IDXB + word2tag 21 = pure CATB + word2tag 22 = pure THRO + word2tag 23 = pure TRCE + word2tag 24 = pure SDBX + word2tag 25 = pure IXOT + word2tag 26 = pure IXOB + word2tag 27 = pure SDBV + word2tag 28 = pure REFW + word2tag n = unknownTag "BPrim2" n diff --git a/parser-typechecker/src/Unison/Runtime/SparseVector.hs b/unison-runtime/src/Unison/Runtime/SparseVector.hs similarity index 100% rename from parser-typechecker/src/Unison/Runtime/SparseVector.hs rename to unison-runtime/src/Unison/Runtime/SparseVector.hs diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs new file mode 100644 index 0000000000..4babe7f3d7 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Stack.hs @@ -0,0 +1,1270 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UnboxedTuples #-} + +module Unison.Runtime.Stack + ( K (..), + GClosure (..), + Closure + ( .., + DataC, + PApV, + CapV, + PAp, + Enum, + Data1, + Data2, + DataG, + Captured, + Foreign, + BlackHole, + UnboxedTypeTag + ), + UnboxedTypeTag (..), + unboxedTypeTagToInt, + unboxedTypeTagFromInt, + IxClosure, + Callback (..), + Augment (..), + Dump (..), + Stack (..), + XStack, + pattern XStack, + packXStack, + unpackXStack, + xStackIOToIO, + stackIOToIOX, + IOXStack, + apX, + fpX, + spX, + ustkX, + bstkX, + Off, + SZ, + FP, + Seg, + USeg, + BSeg, + SegList, + Val + ( .., + CharVal, + NatVal, + DoubleVal, + IntVal, + BoolVal, + UnboxedVal, + BoxedVal + ), + emptyVal, + falseVal, + trueVal, + boxedVal, + USeq, + traceK, + frameDataSize, + marshalToForeign, + unull, + bnull, + nullSeg, + peekD, + peekOffD, + peekC, + peekOffC, + poke, + pokeD, + pokeOffD, + pokeC, + pokeOffC, + pokeBool, + pokeTag, + peekTag, + peekTagOff, + peekI, + peekOffI, + peekN, + peekOffN, + pokeN, + pokeOffN, + pokeI, + pokeOffI, + pokeByte, + peekBi, + peekOffBi, + pokeBi, + pokeOffBi, + peekBool, + peekOffBool, + peekOffS, + pokeS, + pokeOffS, + frameView, + scount, + closureTermRefs, + dumpAP, + dumpFP, + alloc, + peek, + upeek, + bpeek, + peekOff, + upeekOff, + bpeekOff, + bpoke, + bpokeOff, + pokeOff, + upokeT, + upokeOffT, + unsafePokeIasN, + bump, + bumpn, + grab, + ensure, + duplicate, + discardFrame, + saveFrame, + saveArgs, + restoreFrame, + prepareArgs, + acceptArgs, + frameArgs, + augSeg, + dumpSeg, + adjustArgs, + fsize, + asize, + + -- * Unboxed type tags + natTypeTag, + intTypeTag, + charTypeTag, + floatTypeTag, + hasNoAllocations, + ) +where + +import Control.Monad.Primitive +import Data.Char qualified as Char +import Data.IORef (IORef) +import Data.Primitive (sizeOf) +import Data.Primitive.ByteArray qualified as BA +import Data.Tagged (Tagged (..)) +import Data.Word +import GHC.Base +import GHC.Exts as L (IsList (..)) +import Language.Haskell.TH qualified as TH +import Test.Inspection qualified as TI +import Unison.Prelude +import Unison.Reference (Reference) +import Unison.Runtime.ANF (PackedTag) +import Unison.Runtime.Array +import Unison.Runtime.Foreign +import Unison.Runtime.MCode +import Unison.Runtime.TypeTags qualified as TT +import Unison.Type qualified as Ty +import Unison.Util.EnumContainers as EC +import Prelude hiding (words) + +{- ORMOLU_DISABLE -} +#ifdef STACK_CHECK +type DebugCallStack = (HasCallStack :: Constraint) + +unboxedSentinel :: Int +unboxedSentinel = -99 + +boxedSentinel :: Closure +boxedSentinel = (Closure GUnboxedSentinel) + +assertBumped :: HasCallStack => Stack -> Off -> IO () +assertBumped (Stack _ _ sp ustk bstk) i = do + u <- readByteArray ustk (sp - i) + b :: BVal <- readArray bstk (sp - i) + when (u /= unboxedSentinel || not (isBoxedSentinel b)) do + error $ "Expected stack slot to have been bumped, but it was:" <> show (Val u b) + where + isBoxedSentinel :: Closure -> Bool + isBoxedSentinel (Closure GUnboxedSentinel) = True + isBoxedSentinel _ = False + +assertUnboxed :: HasCallStack => Stack -> Off -> IO () +assertUnboxed (Stack _ _ sp ustk bstk) i = do + (u :: Int) <- readByteArray ustk (sp - i) + b <- readArray bstk (sp - i) + case b of + UnboxedTypeTag _ -> pure () + _ -> error $ "Expected stack val to be unboxed, but it was:" <> show (Val u b) + +pokeSentinelOff :: Stack -> Off -> IO () +pokeSentinelOff (Stack _ _ sp ustk bstk) off = do + writeByteArray ustk (sp - off) unboxedSentinel + writeArray bstk (sp - off) boxedSentinel +#else +-- Don't track callstacks in production, it's expensive +type DebugCallStack = (() :: Constraint) +#endif +{- ORMOLU_ENABLE -} + +newtype Callback = Hook (XStack -> IO ()) + +instance Eq Callback where _ == _ = True + +instance Ord Callback where compare _ _ = EQ + +-- Evaluation stack +data K + = KE + | -- callback hook + CB Callback + | -- mark continuation with a prompt + Mark + !Int -- pending args + !(EnumSet Word64) + !(EnumMap Word64 Val) + !K + | -- save information about a frame for later resumption + Push + !Int -- frame size + !Int -- pending args + !CombIx -- resumption section reference + !Int -- stack guard + !(RSection Val) -- resumption section + !K + +newtype Closure = Closure {unClosure :: (GClosure (RComb Val))} + deriving stock (Show) + +-- | Implementation for Unison sequences. +type USeq = Seq Val + +type IxClosure = GClosure CombIx + +-- Don't re-order these, the ord instance affects Universal.compare +data UnboxedTypeTag + = CharTag + | FloatTag + | IntTag + | NatTag + deriving stock (Show, Eq, Ord) + +unboxedTypeTagToInt :: UnboxedTypeTag -> Int +unboxedTypeTagToInt = \case + CharTag -> 0 + FloatTag -> 1 + IntTag -> 2 + NatTag -> 3 + +unboxedTypeTagFromInt :: (HasCallStack) => Int -> UnboxedTypeTag +unboxedTypeTagFromInt = \case + 0 -> CharTag + 1 -> FloatTag + 2 -> IntTag + 3 -> NatTag + _ -> error "intToUnboxedTypeTag: invalid tag" + +{- ORMOLU_DISABLE -} +data GClosure comb + = GPAp + !CombIx + {-# UNPACK #-} !(GCombInfo comb) + {-# UNPACK #-} !Seg -- args + | GEnum !Reference !PackedTag + | GData1 !Reference !PackedTag !Val + | GData2 !Reference !PackedTag !Val !Val + | GDataG !Reference !PackedTag {-# UNPACK #-} !Seg + | -- code cont, arg size, u/b data stacks + GCaptured !K !Int {-# UNPACK #-} !Seg + | GForeign !Foreign + | -- The type tag for the value in the corresponding unboxed stack slot. + -- We should consider adding separate constructors for common builtin type tags. + -- GHC will optimize nullary constructors into singletons. + GUnboxedTypeTag !UnboxedTypeTag + | GBlackHole +#ifdef STACK_CHECK + | GUnboxedSentinel +#endif + deriving stock (Show, Functor, Foldable, Traversable) +{- ORMOLU_ENABLE -} + +-- Singleton black hole value to avoid allocation. +blackHole :: Closure +blackHole = Closure GBlackHole +{-# NOINLINE blackHole #-} + +pattern PAp :: CombIx -> GCombInfo (RComb Val) -> Seg -> Closure +pattern PAp cix comb seg = Closure (GPAp cix comb seg) + +pattern Enum :: Reference -> PackedTag -> Closure +pattern Enum r t = Closure (GEnum r t) + +pattern Data1 r t i = Closure (GData1 r t i) + +pattern Data2 r t i j = Closure (GData2 r t i j) + +pattern DataG r t seg = Closure (GDataG r t seg) + +pattern Captured k a seg = Closure (GCaptured k a seg) + +pattern Foreign x = Closure (GForeign x) + +pattern BlackHole <- Closure GBlackHole + where + BlackHole = blackHole + +pattern UnboxedTypeTag t <- Closure (GUnboxedTypeTag t) + where + UnboxedTypeTag t = case t of + CharTag -> charTypeTag + FloatTag -> floatTypeTag + IntTag -> intTypeTag + NatTag -> natTypeTag + +{-# COMPLETE PAp, Enum, Data1, Data2, DataG, Captured, Foreign, UnboxedTypeTag, BlackHole #-} + +{-# COMPLETE DataC, PAp, Captured, Foreign, BlackHole, UnboxedTypeTag #-} + +{-# COMPLETE DataC, PApV, Captured, Foreign, BlackHole, UnboxedTypeTag #-} + +{-# COMPLETE DataC, PApV, CapV, Foreign, BlackHole, UnboxedTypeTag #-} + +-- We can avoid allocating a closure for common type tags on each poke by having shared top-level closures for them. +natTypeTag :: Closure +natTypeTag = (Closure (GUnboxedTypeTag NatTag)) +{-# NOINLINE natTypeTag #-} + +intTypeTag :: Closure +intTypeTag = (Closure (GUnboxedTypeTag IntTag)) +{-# NOINLINE intTypeTag #-} + +charTypeTag :: Closure +charTypeTag = (Closure (GUnboxedTypeTag CharTag)) +{-# NOINLINE charTypeTag #-} + +floatTypeTag :: Closure +floatTypeTag = (Closure (GUnboxedTypeTag FloatTag)) +{-# NOINLINE floatTypeTag #-} + +traceK :: Reference -> K -> [(Reference, Int)] +traceK begin = dedup (begin, 1) + where + dedup p (Mark _ _ _ k) = dedup p k + dedup p@(cur, n) (Push _ _ (CIx r _ _) _ _ k) + | cur == r = dedup (cur, 1 + n) k + | otherwise = p : dedup (r, 1) k + dedup p _ = [p] + +splitData :: Closure -> Maybe (Reference, PackedTag, SegList) +splitData = \case + (Enum r t) -> Just (r, t, []) + (Data1 r t u) -> Just (r, t, [u]) + (Data2 r t i j) -> Just (r, t, [i, j]) + (DataG r t seg) -> Just (r, t, segToList seg) + _ -> Nothing + +-- | Converts a list of integers representing an unboxed segment back into the +-- appropriate segment. Segments are stored backwards in the runtime, so this +-- reverses the list. +useg :: [Int] -> USeg +useg ws = case L.fromList $ reverse ws of + PrimArray ba -> ByteArray ba + +-- | Converts a boxed segment to a list of closures. The segments are stored +-- backwards, so this reverses the contents. +bsegToList :: BSeg -> [Closure] +bsegToList = reverse . L.toList + +-- | Converts a list of closures back to a boxed segment. Segments are stored +-- backwards, so this reverses the contents. +bseg :: [Closure] -> BSeg +bseg = L.fromList . reverse + +formData :: Reference -> PackedTag -> SegList -> Closure +formData r t [] = Enum r t +formData r t [v1] = Data1 r t v1 +formData r t [v1, v2] = Data2 r t v1 v2 +formData r t segList = DataG r t (segFromList segList) + +frameDataSize :: K -> Int +frameDataSize = go 0 + where + go sz KE = sz + go sz (CB _) = sz + go sz (Mark a _ _ k) = go (sz + a) k + go sz (Push f a _ _ _ k) = + go (sz + f + a) k + +pattern DataC :: Reference -> PackedTag -> SegList -> Closure +pattern DataC rf ct segs <- + (splitData -> Just (rf, ct, segs)) + where + DataC rf ct segs = formData rf ct segs + +matchCharVal :: Val -> Maybe Char +matchCharVal = \case + (UnboxedVal u CharTag) -> Just (Char.chr u) + _ -> Nothing + +pattern CharVal :: Char -> Val +pattern CharVal c <- (matchCharVal -> Just c) + where + CharVal c = Val (Char.ord c) charTypeTag + +matchNatVal :: Val -> Maybe Word64 +matchNatVal = \case + (UnboxedVal u NatTag) -> Just (fromIntegral u) + _ -> Nothing + +pattern NatVal :: Word64 -> Val +pattern NatVal n <- (matchNatVal -> Just n) + where + NatVal n = Val (fromIntegral n) natTypeTag + +matchDoubleVal :: Val -> Maybe Double +matchDoubleVal = \case + (UnboxedVal u FloatTag) -> Just (intToDouble u) + _ -> Nothing + +pattern DoubleVal :: Double -> Val +pattern DoubleVal d <- (matchDoubleVal -> Just d) + where + DoubleVal d = Val (doubleToInt d) floatTypeTag + +matchIntVal :: Val -> Maybe Int +matchIntVal = \case + (UnboxedVal u IntTag) -> Just u + _ -> Nothing + +pattern IntVal :: Int -> Val +pattern IntVal i <- (matchIntVal -> Just i) + where + IntVal i = Val i intTypeTag + +matchBoolVal :: Val -> Maybe Bool +matchBoolVal = \case + (BoxedVal (Enum r t)) | r == Ty.booleanRef -> Just (t == TT.falseTag) + _ -> Nothing + +pattern BoolVal :: Bool -> Val +pattern BoolVal b <- (matchBoolVal -> Just b) + where + BoolVal b = if b then trueVal else falseVal + +-- Define singletons we can use for the bools to prevent allocation where possible. +falseVal :: Val +falseVal = BoxedVal (Enum Ty.booleanRef TT.falseTag) +{-# NOINLINE falseVal #-} + +trueVal :: Val +trueVal = BoxedVal (Enum Ty.booleanRef TT.trueTag) +{-# NOINLINE trueVal #-} + +doubleToInt :: Double -> Int +doubleToInt d = indexByteArray (BA.byteArrayFromList [d]) 0 +{-# INLINE doubleToInt #-} + +intToDouble :: Int -> Double +intToDouble w = indexByteArray (BA.byteArrayFromList [w]) 0 +{-# INLINE intToDouble #-} + +type SegList = [Val] + +pattern PApV :: CombIx -> RCombInfo Val -> SegList -> Closure +pattern PApV cix rcomb segs <- + PAp cix rcomb (segToList -> segs) + where + PApV cix rcomb segs = PAp cix rcomb (segFromList segs) + +pattern CapV :: K -> Int -> SegList -> Closure +pattern CapV k a segs <- Captured k a (segToList -> segs) + where + CapV k a segList = Captured k a (segFromList segList) + +-- | Converts from the efficient stack form of a segment to the list representation. Segments are stored backwards, +-- so this reverses the contents +segToList :: Seg -> SegList +segToList (u, b) = + zipWith Val (ints u) (bsegToList b) + +-- | Converts an unboxed segment to a list of integers for a more interchangeable +-- representation. The segments are stored in backwards order, so this reverses +-- the contents. +ints :: ByteArray -> [Int] +ints ba = fmap (indexByteArray ba) [n - 1, n - 2 .. 0] + where + n = sizeofByteArray ba `div` 8 + +-- | Converts from the list representation of a segment to the efficient stack form. Segments are stored backwards, +-- so this reverses the contents. +segFromList :: SegList -> Seg +segFromList xs = + xs + & foldMap + ( \(Val unboxed boxed) -> ([unboxed], [boxed]) + ) + & \(us, bs) -> (useg us, bseg bs) + +marshalToForeign :: (HasCallStack) => Closure -> Foreign +marshalToForeign (Foreign x) = x +marshalToForeign c = + error $ "marshalToForeign: unhandled closure: " ++ show c + +type Off = Int + +type SZ = Int + +type FP = Int + +type UA = MutableByteArray (PrimState IO) + +type BA = MutableArray (PrimState IO) Closure + +intSize :: Int +intSize = sizeOf (0 :: Int) + +words :: Int -> Int +words n = n `div` intSize + +bytes :: Int -> Int +bytes n = n * intSize + +type Arrs = (UA, BA) + +argOnto :: Arrs -> Off -> Arrs -> Off -> Args' -> IO Int +argOnto (srcUstk, srcBstk) srcSp (dstUstk, dstBstk) dstSp args = do + -- Both new cp's should be the same, so we can just return one. + _cp <- uargOnto srcUstk srcSp dstUstk dstSp args + cp <- bargOnto srcBstk srcSp dstBstk dstSp args + pure cp + +-- The Caller must ensure that when setting the unboxed stack, the equivalent +-- boxed stack is zeroed out to BlackHole where necessary. +uargOnto :: UA -> Off -> UA -> Off -> Args' -> IO Int +uargOnto stk sp cop cp0 (Arg1 i) = do + (x :: Int) <- readByteArray stk (sp - i) + writeByteArray cop cp x + pure cp + where + cp = cp0 + 1 +uargOnto stk sp cop cp0 (Arg2 i j) = do + (x :: Int) <- readByteArray stk (sp - i) + (y :: Int) <- readByteArray stk (sp - j) + writeByteArray cop cp x + writeByteArray cop (cp - 1) y + pure cp + where + cp = cp0 + 2 +uargOnto stk sp cop cp0 (ArgN v) = do + buf <- + if overwrite + then newByteArray $ bytes sz + else pure cop + let loop i + | i < 0 = return () + | otherwise = do + (x :: Int) <- readByteArray stk (sp - indexPrimArray v i) + writeByteArray buf (boff - i) x + loop $ i - 1 + loop $ sz - 1 + when overwrite $ + copyMutableByteArray cop (bytes $ cp0 + 1) buf 0 (bytes sz) + pure cp + where + cp = cp0 + sz + sz = sizeofPrimArray v + overwrite = sameMutableByteArray stk cop + boff | overwrite = sz - 1 | otherwise = cp0 + sz +uargOnto stk sp cop cp0 (ArgR i l) = do + moveByteArray cop cbp stk sbp (bytes l) + pure $ cp0 + l + where + cbp = bytes $ cp0 + 1 + sbp = bytes $ sp - i - l + 1 + +bargOnto :: BA -> Off -> BA -> Off -> Args' -> IO Int +bargOnto stk sp cop cp0 (Arg1 i) = do + x <- readArray stk (sp - i) + writeArray cop cp x + pure cp + where + cp = cp0 + 1 +bargOnto stk sp cop cp0 (Arg2 i j) = do + x <- readArray stk (sp - i) + y <- readArray stk (sp - j) + writeArray cop cp x + writeArray cop (cp - 1) y + pure cp + where + cp = cp0 + 2 +bargOnto stk sp cop cp0 (ArgN v) = do + buf <- + if overwrite + then newArray sz $ BlackHole + else pure cop + let loop i + | i < 0 = return () + | otherwise = do + x <- readArray stk $ sp - indexPrimArray v i + writeArray buf (boff - i) x + loop $ i - 1 + loop $ sz - 1 + + when overwrite $ + copyMutableArray cop (cp0 + 1) buf 0 sz + pure cp + where + cp = cp0 + sz + sz = sizeofPrimArray v + overwrite = stk == cop + boff | overwrite = sz - 1 | otherwise = cp0 + sz +bargOnto stk sp cop cp0 (ArgR i l) = do + copyMutableArray cop (cp0 + 1) stk (sp - i - l + 1) l + pure $ cp0 + l + +data Dump = A | F Int Int | S + +dumpAP :: Int -> Int -> Int -> Dump -> Int +dumpAP _ fp sz d@(F _ a) = dumpFP fp sz d - a +dumpAP ap _ _ _ = ap + +dumpFP :: Int -> Int -> Dump -> Int +dumpFP fp _ S = fp +dumpFP fp sz A = fp + sz +dumpFP fp sz (F n _) = fp + sz - n + +-- closure augmentation mode +-- instruction, kontinuation, call +data Augment = I | K | C + +data Stack = Stack + { ap :: !Int, -- arg pointer + fp :: !Int, -- frame pointer + sp :: !Int, -- stack pointer + ustk :: {-# UNPACK #-} !(MutableByteArray (PrimState IO)), + bstk :: {-# UNPACK #-} !(MutableArray (PrimState IO) Closure) + } + +-- Unboxed representation of the Stack, used to force GHC optimizations in a few spots. +type XStack = (# Int#, Int#, Int#, MutableByteArray# (PrimState IO), MutableArray# (PrimState IO) Closure #) + +type IOXStack = State# RealWorld -> (# State# RealWorld, XStack #) + +pattern XStack :: Int# -> Int# -> Int# -> MutableByteArray# RealWorld -> MutableArray# RealWorld Closure -> Stack +pattern XStack {apX, fpX, spX, ustkX, bstkX} = Stack (I# apX) (I# fpX) (I# spX) (MutableByteArray ustkX) (MutableArray bstkX) + +{-# COMPLETE XStack #-} + +{-# INLINE XStack #-} + +packXStack :: XStack -> Stack +packXStack (# ap, fp, sp, ustk, bstk #) = Stack {ap = I# ap, fp = I# fp, sp = I# sp, ustk = MutableByteArray ustk, bstk = MutableArray bstk} +{-# INLINE packXStack #-} + +unpackXStack :: Stack -> XStack +unpackXStack (Stack (I# ap) (I# fp) (I# sp) (MutableByteArray ustk) (MutableArray bstk)) = (# ap, fp, sp, ustk, bstk #) +{-# INLINE unpackXStack #-} + +xStackIOToIO :: IOXStack -> IO Stack +xStackIOToIO f = IO $ \s -> case f s of (# s', x #) -> (# s', packXStack x #) +{-# INLINE xStackIOToIO #-} + +stackIOToIOX :: IO Stack -> IOXStack +stackIOToIOX (IO f) = \s -> case f s of (# s', x #) -> (# s', unpackXStack x #) +{-# INLINE stackIOToIOX #-} + +instance Show Stack where + show (Stack ap fp sp _ _) = + "Stack " ++ show ap ++ " " ++ show fp ++ " " ++ show sp + +type UVal = Int + +-- | A runtime value, which is either a boxed or unboxed value, but we may not know which. +data Val = Val {getUnboxedVal :: !UVal, getBoxedVal :: !BVal} + -- The Eq instance for Val is deliberately omitted because you need to take into account the fact that if a Val is boxed, the + -- unboxed side is garbage and should not be compared. + -- See universalEq. + deriving (Show) + +instance BuiltinForeign (IORef Val) where foreignRef = Tagged Ty.refRef + +-- | A nulled out value you can use when filling empty arrays, etc. +emptyVal :: Val +emptyVal = Val (-1) BlackHole + +pattern UnboxedVal :: Int -> UnboxedTypeTag -> Val +pattern UnboxedVal v t = (Val v (UnboxedTypeTag t)) + +valToBoxed :: Val -> Maybe Closure +valToBoxed UnboxedVal {} = Nothing +valToBoxed (Val _ b) = Just b + +-- | Matches a Val which is known to be boxed, and returns the closure portion. +pattern BoxedVal :: Closure -> Val +pattern BoxedVal b <- (valToBoxed -> Just b) + where + BoxedVal b = Val (-1) b + +{-# COMPLETE UnboxedVal, BoxedVal #-} + +-- | Lift a boxed val into an Val +boxedVal :: BVal -> Val +boxedVal = Val 0 + +type USeg = ByteArray + +type BVal = Closure + +type BSeg = Array Closure + +type Seg = (USeg, BSeg) + +alloc :: IO Stack +alloc = do + ustk <- newByteArray 4096 + bstk <- newArray 512 BlackHole + pure $ Stack {ap = -1, fp = -1, sp = -1, ustk, bstk} +{-# INLINE alloc #-} + +{- ORMOLU_DISABLE -} +peek :: DebugCallStack => Stack -> IO Val +peek stk@(Stack _ _ sp ustk _) = do + -- Can't use upeek here because in stack-check mode it will assert that the stack slot is unboxed. + u <- readByteArray ustk sp + b <- bpeek stk + pure (Val u b) +{-# INLINE peek #-} + +peekI :: DebugCallStack => Stack -> IO Int +peekI _stk@(Stack _ _ sp ustk _) = do +#ifdef STACK_CHECK + assertUnboxed _stk 0 +#endif + readByteArray ustk sp +{-# INLINE peekI #-} + +peekOffI :: DebugCallStack => Stack -> Off -> IO Int +peekOffI _stk@(Stack _ _ sp ustk _) i = do +#ifdef STACK_CHECK + assertUnboxed _stk i +#endif + readByteArray ustk (sp - i) +{-# INLINE peekOffI #-} + +bpeek :: DebugCallStack => Stack -> IO BVal +bpeek (Stack _ _ sp _ bstk) = readArray bstk sp +{-# INLINE bpeek #-} + +upeek :: DebugCallStack => Stack -> IO UVal +upeek _stk@(Stack _ _ sp ustk _) = do +#ifdef STACK_CHECK + assertUnboxed _stk 0 +#endif + readByteArray ustk sp +{-# INLINE upeek #-} + +peekOff :: DebugCallStack => Stack -> Off -> IO Val +peekOff stk@(Stack _ _ sp ustk _) i = do + -- Can't use upeekOff here because in stack-check mode it will assert that the stack slot is unboxed. + u <- readByteArray ustk (sp - i) + b <- bpeekOff stk i + pure $ Val u b +{-# INLINE peekOff #-} + +bpeekOff :: DebugCallStack => Stack -> Off -> IO BVal +bpeekOff (Stack _ _ sp _ bstk) i = readArray bstk (sp - i) +{-# INLINE bpeekOff #-} + +upeekOff :: DebugCallStack => Stack -> Off -> IO UVal +upeekOff _stk@(Stack _ _ sp ustk _) i = do +#ifdef STACK_CHECK + assertUnboxed _stk i +#endif + readByteArray ustk (sp - i) +{-# INLINE upeekOff #-} + +upokeT :: DebugCallStack => Stack -> UVal -> BVal -> IO () +upokeT !stk@(Stack _ _ sp ustk _) !u !t = do + bpoke stk t + writeByteArray ustk sp u +{-# INLINE upokeT #-} + +poke :: DebugCallStack => Stack -> Val -> IO () +poke _stk@(Stack _ _ sp ustk bstk) (Val u b) = do +#ifdef STACK_CHECK + assertBumped _stk 0 +#endif + writeByteArray ustk sp u + writeArray bstk sp b +{-# INLINE poke #-} + +-- | Sometimes we get back an int from a foreign call which we want to use as a Nat. +-- If we know it's positive and smaller than 2^63 then we can safely store the Int directly as a Nat without +-- checks. +unsafePokeIasN :: DebugCallStack => Stack -> Int -> IO () +unsafePokeIasN stk n = do + upokeT stk n natTypeTag +{-# INLINE unsafePokeIasN #-} + +-- | Store an unboxed tag to later match on. +-- Often used to indicate the constructor of a data type that's been unpacked onto the stack, +-- or some tag we're about to branch on. +pokeTag :: DebugCallStack => Stack -> Int -> IO () +pokeTag = + -- For now we just use ints, but maybe should have a separate type for tags so we can detect if we're leaking them. + pokeI +{-# INLINE pokeTag #-} + +peekTag :: DebugCallStack => Stack -> IO Int +peekTag = peekI +{-# INLINE peekTag #-} + +peekTagOff :: DebugCallStack => Stack -> Off -> IO Int +peekTagOff = peekOffI +{-# INLINE peekTagOff #-} + +pokeBool :: DebugCallStack => Stack -> Bool -> IO () +pokeBool stk b = + poke stk $ if b then trueVal else falseVal +{-# INLINE pokeBool #-} + +-- | Store a boxed value. +-- We don't bother nulling out the unboxed stack, +-- it's extra work and there's nothing to garbage collect. +bpoke :: DebugCallStack => Stack -> BVal -> IO () +bpoke _stk@(Stack _ _ sp _ bstk) b = do +#ifdef STACK_CHECK + assertBumped _stk 0 +#endif + writeArray bstk sp b +{-# INLINE bpoke #-} + +pokeOff :: DebugCallStack => Stack -> Off -> Val -> IO () +pokeOff stk i (Val u t) = do + bpokeOff stk i t + writeByteArray (ustk stk) (sp stk - i) u +{-# INLINE pokeOff #-} + +upokeOffT :: DebugCallStack => Stack -> Off -> UVal -> BVal -> IO () +upokeOffT stk i u t = do + bpokeOff stk i t + writeByteArray (ustk stk) (sp stk - i) u +{-# INLINE upokeOffT #-} + +bpokeOff :: DebugCallStack => Stack -> Off -> BVal -> IO () +bpokeOff _stk@(Stack _ _ sp _ bstk) i b = do +#ifdef STACK_CHECK + assertBumped _stk i +#endif + writeArray bstk (sp - i) b +{-# INLINE bpokeOff #-} + +-- | Eats up arguments +grab :: Stack -> SZ -> IO (Seg, Stack) +grab (Stack _ fp sp ustk bstk) sze = do + uSeg <- ugrab + bSeg <- bgrab + pure $ ((uSeg, bSeg), Stack (fp - sze) (fp - sze) (sp - sze) ustk bstk) + where + ugrab = do + mut <- newByteArray bsz + copyMutableByteArray mut 0 ustk (bfp - bsz) bsz + seg <- unsafeFreezeByteArray mut + moveByteArray ustk (bfp - bsz) ustk bfp fsz + pure seg + where + bsz = bytes sze + bfp = bytes $ fp + 1 + fsz = bytes $ sp - fp + bgrab = do + seg <- unsafeFreezeArray =<< cloneMutableArray bstk (fp + 1 - sze) sze + copyMutableArray bstk (fp + 1 - sze) bstk (fp + 1) fsz + pure seg + where + fsz = sp - fp +{-# INLINE grab #-} + +ensure :: Stack -> SZ -> IO Stack +ensure stk@(Stack ap fp sp ustk bstk) sze + | sze <= 0 = pure stk + | sp + sze + 1 < bsz = pure stk + | otherwise = do + bstk' <- newArray (bsz + bext) BlackHole + copyMutableArray bstk' 0 bstk 0 (sp + 1) + ustk' <- resizeMutableByteArray ustk (usz + uext) + pure $ Stack ap fp sp ustk' bstk' + where + usz = sizeofMutableByteArray ustk + bsz = sizeofMutableArray bstk + bext + | sze > 1280 = sze + 512 + | otherwise = 1280 + uext + | bytes sze > 10240 = bytes sze + 4096 + | otherwise = 10240 +{-# INLINE ensure #-} + +bump :: Stack -> IO Stack +bump (Stack ap fp sp ustk bstk) = do + let stk' = Stack ap fp (sp + 1) ustk bstk +#ifdef STACK_CHECK + pokeSentinelOff stk' 0 +#endif + pure stk' +{-# INLINE bump #-} + +bumpn :: Stack -> SZ -> IO Stack +bumpn (Stack ap fp sp ustk bstk) n = do + let stk' = Stack ap fp (sp + n) ustk bstk +#ifdef STACK_CHECK + for_ [0..n-1] $ \i -> + pokeSentinelOff stk' i +#endif + pure stk' +{-# INLINE bumpn #-} + +duplicate :: Stack -> IO Stack +duplicate (Stack ap fp sp ustk bstk) = do + ustk' <- dupUStk + bstk' <- dupBStk + pure $ Stack ap fp sp ustk' bstk' + where + dupUStk = do + let sz = sizeofMutableByteArray ustk + b <- newByteArray sz + copyMutableByteArray b 0 ustk 0 sz + pure b + dupBStk = do + cloneMutableArray bstk 0 (sizeofMutableArray bstk) +{-# INLINE duplicate #-} + +discardFrame :: Stack -> IO Stack +discardFrame (Stack ap fp _ ustk bstk) = pure $ Stack ap fp fp ustk bstk +{-# INLINE discardFrame #-} + +saveFrame :: Stack -> IO (Stack, SZ, SZ) +saveFrame (Stack ap fp sp ustk bstk) = pure (Stack sp sp sp ustk bstk, sp - fp, fp - ap) +{-# INLINE saveFrame #-} + +saveArgs :: Stack -> IO (Stack, SZ) +saveArgs (Stack ap fp sp ustk bstk) = pure (Stack fp fp sp ustk bstk, fp - ap) +{-# INLINE saveArgs #-} + +restoreFrame :: Stack -> SZ -> SZ -> IO Stack +restoreFrame (Stack _ fp0 sp ustk bstk) fsz asz = pure $ Stack ap fp sp ustk bstk + where + fp = fp0 - fsz + ap = fp - asz +{-# INLINE restoreFrame #-} + +prepareArgs :: Stack -> Args' -> IO Stack +prepareArgs (Stack ap fp sp ustk bstk) = \case + ArgR i l + | fp + l + i == sp -> + pure $ Stack ap (sp - i) (sp - i) ustk bstk + args -> do + sp <- argOnto (ustk, bstk) sp (ustk, bstk) fp args + pure $ Stack ap sp sp ustk bstk +{-# INLINE prepareArgs #-} + +acceptArgs :: Stack -> Int -> IO Stack +acceptArgs (Stack ap fp sp ustk bstk) n = pure $ Stack ap (fp - n) sp ustk bstk +{-# INLINE acceptArgs #-} + +frameArgs :: Stack -> IO Stack +frameArgs (Stack ap _ sp ustk bstk) = pure $ Stack ap ap sp ustk bstk +{-# INLINE frameArgs #-} + +augSeg :: Augment -> Stack -> Seg -> Maybe Args' -> IO Seg +augSeg mode (Stack ap fp sp ustk bstk) (useg, bseg) margs = do + useg' <- unboxedSeg + bseg' <- boxedSeg + pure (useg', bseg') + where + bpsz + | I <- mode = 0 + | otherwise = fp - ap + unboxedSeg = do + cop <- newByteArray $ ssz + upsz + asz + copyByteArray cop soff useg 0 ssz + copyMutableByteArray cop 0 ustk (bytes $ ap + 1) upsz + for_ margs $ uargOnto ustk sp cop (words poff + bpsz - 1) + unsafeFreezeByteArray cop + where + ssz = sizeofByteArray useg + (poff, soff) + | K <- mode = (ssz, 0) + | otherwise = (0, upsz + asz) + upsz = bytes bpsz + asz = case margs of + Nothing -> bytes 0 + Just (Arg1 _) -> bytes 1 + Just (Arg2 _ _) -> bytes 2 + Just (ArgN v) -> bytes $ sizeofPrimArray v + Just (ArgR _ l) -> bytes l + boxedSeg = do + cop <- newArray (ssz + bpsz + asz) BlackHole + copyArray cop soff bseg 0 ssz + copyMutableArray cop poff bstk (ap + 1) bpsz + for_ margs $ bargOnto bstk sp cop (poff + bpsz - 1) + unsafeFreezeArray cop + where + ssz = sizeofArray bseg + (poff, soff) + | K <- mode = (ssz, 0) + | otherwise = (0, bpsz + asz) + asz = case margs of + Nothing -> 0 + Just (Arg1 _) -> 1 + Just (Arg2 _ _) -> 2 + Just (ArgN v) -> sizeofPrimArray v + Just (ArgR _ l) -> l +{-# INLINE augSeg #-} + +dumpSeg :: Stack -> Seg -> Dump -> IO Stack +dumpSeg (Stack ap fp sp ustk bstk) (useg, bseg) mode = do + dumpUSeg + dumpBSeg + pure $ Stack ap' fp' sp' ustk bstk + where + sz = sizeofArray bseg + sp' = sp + sz + fp' = dumpFP fp sz mode + ap' = dumpAP ap fp sz mode + dumpUSeg = do + let ssz = sizeofByteArray useg + let bsp = bytes $ sp + 1 + copyByteArray ustk bsp useg 0 ssz + dumpBSeg = do + copyArray bstk (sp + 1) bseg 0 sz +{-# INLINE dumpSeg #-} + +adjustArgs :: Stack -> SZ -> IO Stack +adjustArgs (Stack ap fp sp ustk bstk) sz = pure $ Stack (ap - sz) fp sp ustk bstk +{-# INLINE adjustArgs #-} + +fsize :: Stack -> SZ +fsize (Stack _ fp sp _ _) = sp - fp +{-# INLINE fsize #-} + +asize :: Stack -> SZ +asize (Stack ap fp _ _ _) = fp - ap +{-# INLINE asize #-} + +peekN :: Stack -> IO Word64 +peekN _stk@(Stack _ _ sp ustk _) = do +#ifdef STACK_CHECK + assertUnboxed _stk 0 +#endif + readByteArray ustk sp +{-# INLINE peekN #-} + +peekD :: Stack -> IO Double +peekD _stk@(Stack _ _ sp ustk _) = do +#ifdef STACK_CHECK + assertUnboxed _stk 0 +#endif + readByteArray ustk sp +{-# INLINE peekD #-} + +peekC :: Stack -> IO Char +peekC stk = do + Char.chr <$> peekI stk +{-# INLINE peekC #-} + +peekOffN :: Stack -> Int -> IO Word64 +peekOffN _stk@(Stack _ _ sp ustk _) i = do +#ifdef STACK_CHECK + assertUnboxed _stk i +#endif + readByteArray ustk (sp - i) +{-# INLINE peekOffN #-} + +peekOffD :: Stack -> Int -> IO Double +peekOffD _stk@(Stack _ _ sp ustk _) i = do +#ifdef STACK_CHECK + assertUnboxed _stk i +#endif + readByteArray ustk (sp - i) +{-# INLINE peekOffD #-} + +peekOffC :: Stack -> Int -> IO Char +peekOffC _stk@(Stack _ _ sp ustk _) i = do +#ifdef STACK_CHECK + assertUnboxed _stk i +#endif + Char.chr <$> readByteArray ustk (sp - i) +{-# INLINE peekOffC #-} + +{- ORMOLU_ENABLE -} + +pokeN :: Stack -> Word64 -> IO () +pokeN stk@(Stack _ _ sp ustk _) n = do + bpoke stk natTypeTag + writeByteArray ustk sp n +{-# INLINE pokeN #-} + +pokeD :: Stack -> Double -> IO () +pokeD stk@(Stack _ _ sp ustk _) d = do + bpoke stk floatTypeTag + writeByteArray ustk sp d +{-# INLINE pokeD #-} + +pokeC :: Stack -> Char -> IO () +pokeC stk@(Stack _ _ sp ustk _) c = do + bpoke stk charTypeTag + writeByteArray ustk sp (Char.ord c) +{-# INLINE pokeC #-} + +-- | Note: This is for poking an unboxed value that has the UNISON type 'int', not just any unboxed data. +pokeI :: Stack -> Int -> IO () +pokeI stk@(Stack _ _ sp ustk _) i = do + bpoke stk intTypeTag + writeByteArray ustk sp i +{-# INLINE pokeI #-} + +pokeByte :: Stack -> Word8 -> IO () +pokeByte stk b = do + -- NOTE: currently we just store bytes as Word64s, but we should have a separate type runtime type tag for them. + pokeN stk (fromIntegral b) +{-# INLINE pokeByte #-} + +pokeOffN :: Stack -> Int -> Word64 -> IO () +pokeOffN stk@(Stack _ _ sp ustk _) i n = do + bpokeOff stk i natTypeTag + writeByteArray ustk (sp - i) n +{-# INLINE pokeOffN #-} + +pokeOffD :: Stack -> Int -> Double -> IO () +pokeOffD stk@(Stack _ _ sp ustk _) i d = do + bpokeOff stk i floatTypeTag + writeByteArray ustk (sp - i) d +{-# INLINE pokeOffD #-} + +pokeOffI :: Stack -> Int -> Int -> IO () +pokeOffI stk@(Stack _ _ sp ustk _) i n = do + bpokeOff stk i intTypeTag + writeByteArray ustk (sp - i) n +{-# INLINE pokeOffI #-} + +pokeOffC :: Stack -> Int -> Char -> IO () +pokeOffC stk i c = do + upokeOffT stk i (Char.ord c) charTypeTag +{-# INLINE pokeOffC #-} + +pokeBi :: (BuiltinForeign b) => Stack -> b -> IO () +pokeBi stk x = bpoke stk (Foreign $ wrapBuiltin x) +{-# INLINE pokeBi #-} + +pokeOffBi :: (BuiltinForeign b) => Stack -> Int -> b -> IO () +pokeOffBi stk i x = bpokeOff stk i (Foreign $ wrapBuiltin x) +{-# INLINE pokeOffBi #-} + +peekBi :: (BuiltinForeign b) => Stack -> IO b +peekBi stk = unwrapForeign . marshalToForeign <$> bpeek stk +{-# INLINE peekBi #-} + +peekOffBi :: (BuiltinForeign b) => Stack -> Int -> IO b +peekOffBi stk i = unwrapForeign . marshalToForeign <$> bpeekOff stk i +{-# INLINE peekOffBi #-} + +peekBool :: Stack -> IO Bool +peekBool stk = do + b <- bpeek stk + pure $ case b of + Enum _ t -> t /= TT.falseTag + _ -> error "peekBool: not a boolean" +{-# INLINE peekBool #-} + +peekOffBool :: Stack -> Int -> IO Bool +peekOffBool stk i = do + b <- bpeekOff stk i + pure $ case b of + Enum _ t -> t /= TT.falseTag + _ -> error "peekOffBool: not a boolean" +{-# INLINE peekOffBool #-} + +peekOffS :: Stack -> Int -> IO USeq +peekOffS stk i = + unwrapForeign . marshalToForeign <$> bpeekOff stk i +{-# INLINE peekOffS #-} + +pokeS :: Stack -> USeq -> IO () +pokeS stk s = bpoke stk (Foreign $ Wrap Ty.listRef s) +{-# INLINE pokeS #-} + +pokeOffS :: Stack -> Int -> USeq -> IO () +pokeOffS stk i s = bpokeOff stk i (Foreign $ Wrap Ty.listRef s) +{-# INLINE pokeOffS #-} + +unull :: USeg +unull = byteArrayFromListN 0 ([] :: [Int]) + +bnull :: BSeg +bnull = fromListN 0 [] + +nullSeg :: Seg +nullSeg = (unull, bnull) + +instance Show K where + show k = "[" ++ go "" k + where + go _ KE = "]" + go _ (CB _) = "]" + go com (Push f a ci _g _rsect k) = + com ++ show (f, a, ci) ++ go "," k + go com (Mark a ps _ k) = + com ++ "M " ++ show a ++ " " ++ show ps ++ go "," k + +frameView :: Stack -> IO () +frameView stk = putStr "|" >> gof False 0 + where + fsz = fsize stk + asz = asize stk + gof delim n + | n >= fsz = putStr "|" >> goa False 0 + | otherwise = do + when delim $ putStr "," + putStr . show =<< peekOff stk n + gof True (n + 1) + goa delim n + | n >= asz = putStrLn "|.." + | otherwise = do + when delim $ putStr "," + putStr . show =<< peekOff stk (fsz + n) + goa True (n + 1) + +scount :: Seg -> Int +scount (_, bseg) = bscount bseg + where + bscount :: BSeg -> Int + bscount seg = sizeofArray seg + +closureTermRefs :: (Monoid m) => (Reference -> m) -> (Closure -> m) +closureTermRefs f = \case + PAp (CIx r _ _) _ (_useg, bseg) -> + f r <> foldMap (closureTermRefs f) bseg + (DataC _ _ vs) -> + vs & foldMap \case + BoxedVal c -> closureTermRefs f c + UnboxedVal {} -> mempty + (Captured k _ (_useg, bseg)) -> + contTermRefs f k <> foldMap (closureTermRefs f) bseg + (Foreign fo) + | Just (cs :: USeq) <- maybeUnwrapForeign Ty.listRef fo -> + foldMap (\(Val _i clos) -> closureTermRefs f clos) cs + _ -> mempty + +contTermRefs :: (Monoid m) => (Reference -> m) -> K -> m +contTermRefs f (Mark _ _ m k) = + ( m & foldMap \case + BoxedVal clo -> closureTermRefs f clo + _ -> mempty + ) + <> contTermRefs f k +contTermRefs f (Push _ _ (CIx r _ _) _ _ k) = + f r <> contTermRefs f k +contTermRefs _ _ = mempty + +hasNoAllocations :: TH.Name -> TI.Obligation +hasNoAllocations n = TI.mkObligation n TI.NoAllocation diff --git a/unison-runtime/src/Unison/Runtime/TypeTags.hs b/unison-runtime/src/Unison/Runtime/TypeTags.hs new file mode 100644 index 0000000000..e489138414 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/TypeTags.hs @@ -0,0 +1,155 @@ +module Unison.Runtime.TypeTags + ( Tag (..), + RTag (..), + CTag (..), + PackedTag (..), + packTags, + unpackTags, + maskTags, + floatTag, + natTag, + intTag, + charTag, + unitTag, + leftTag, + rightTag, + falseTag, + trueTag, + ) +where + +import Control.Exception (throw) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.List hiding (and, or) +import Data.Map qualified as Map +import GHC.Stack (CallStack, callStack) +import U.Codebase.Reference (Reference) +import Unison.Builtin.Decls qualified as Ty +import Unison.Prelude +import Unison.Runtime.Builtin.Types (builtinTypeNumbering) +import Unison.Type qualified as Ty +import Unison.Util.EnumContainers as EC +import Unison.Util.Pretty qualified as Pretty +import Prelude hiding (abs, and, or, seq) +import Prelude qualified + +-- For internal errors +data CompileExn = CE CallStack (Pretty.Pretty Pretty.ColorText) + deriving (Show) + +instance Exception CompileExn + +internalBug :: (HasCallStack) => String -> a +internalBug = throw . CE callStack . Pretty.lit . fromString + +-- Types representing components that will go into the runtime tag of +-- a data type value. RTags correspond to references, while CTags +-- correspond to constructors. +newtype RTag = RTag Word64 + deriving stock (Eq, Ord, Show, Read) + deriving newtype (EC.EnumKey) + +newtype CTag = CTag Word16 + deriving stock (Eq, Ord, Show, Read) + deriving newtype (EC.EnumKey) + +-- | A combined tag, which is a packed representation of an RTag and a CTag +newtype PackedTag = PackedTag Word64 + deriving stock (Eq, Ord, Show, Read) + deriving newtype (EC.EnumKey) + +class Tag t where rawTag :: t -> Word64 + +instance Tag RTag where rawTag (RTag w) = w + +instance Tag CTag where rawTag (CTag w) = fromIntegral w + +packTags :: RTag -> CTag -> PackedTag +packTags (RTag rt) (CTag ct) = PackedTag (ri .|. ci) + where + ri = rt `shiftL` 16 + ci = fromIntegral ct + +unpackTags :: PackedTag -> (RTag, CTag) +unpackTags (PackedTag w) = (RTag $ w `shiftR` 16, CTag . fromIntegral $ w .&. 0xFFFF) + +-- Masks a packed tag to extract just the constructor tag portion +maskTags :: PackedTag -> Word64 +maskTags (PackedTag w) = (w .&. 0xFFFF) + +ensureRTag :: (Ord n, Show n, Num n) => String -> n -> r -> r +ensureRTag s n x + | n > 0xFFFFFFFFFFFF = + internalBug $ s ++ "@RTag: too large: " ++ show n + | otherwise = x + +ensureCTag :: (Ord n, Show n, Num n) => String -> n -> r -> r +ensureCTag s n x + | n > 0xFFFF = + internalBug $ s ++ "@CTag: too large: " ++ show n + | otherwise = x + +instance Enum RTag where + toEnum i = ensureRTag "toEnum" i . RTag $ toEnum i + fromEnum (RTag w) = fromEnum w + +instance Enum CTag where + toEnum i = ensureCTag "toEnum" i . CTag $ toEnum i + fromEnum (CTag w) = fromEnum w + +instance Num RTag where + fromInteger i = ensureRTag "fromInteger" i . RTag $ fromInteger i + (+) = internalBug "RTag: +" + (*) = internalBug "RTag: *" + abs = internalBug "RTag: abs" + signum = internalBug "RTag: signum" + negate = internalBug "RTag: negate" + +instance Num CTag where + fromInteger i = ensureCTag "fromInteger" i . CTag $ fromInteger i + (+) = internalBug "CTag: +" + (*) = internalBug "CTag: *" + abs = internalBug "CTag: abs" + signum = internalBug "CTag: signum" + negate = internalBug "CTag: negate" + +floatTag :: PackedTag +floatTag = mkSimpleTag "floatTag" Ty.floatRef + +natTag :: PackedTag +natTag = mkSimpleTag "natTag" Ty.natRef + +intTag :: PackedTag +intTag = mkSimpleTag "intTag" Ty.intRef + +charTag :: PackedTag +charTag = mkSimpleTag "charTag" Ty.charRef + +unitTag :: PackedTag +unitTag = mkSimpleTag "unitTag" Ty.unitRef + +falseTag :: PackedTag +falseTag = mkEnumTag "falseTag" Ty.booleanRef 0 + +trueTag :: PackedTag +trueTag = mkEnumTag "trueTag" Ty.booleanRef 1 + +leftTag, rightTag :: PackedTag +(leftTag, rightTag) + | Just n <- Map.lookup Ty.eitherRef builtinTypeNumbering, + et <- toEnum (fromIntegral n), + lt <- toEnum (fromIntegral Ty.eitherLeftId), + rt <- toEnum (fromIntegral Ty.eitherRightId) = + (packTags et lt, packTags et rt) + | otherwise = error "internal error: either tags" + +-- | Construct a tag for a single-constructor builtin type +mkSimpleTag :: String -> Reference -> PackedTag +mkSimpleTag msg r = mkEnumTag msg r 0 + +mkEnumTag :: String -> Reference -> Int -> PackedTag +mkEnumTag msg r i + | Just n <- Map.lookup r builtinTypeNumbering, + rt <- toEnum (fromIntegral n) = + packTags rt (toEnum i) + | otherwise = internalBug $ "internal error: " <> msg diff --git a/parser-typechecker/src/Unison/Runtime/Vector.hs b/unison-runtime/src/Unison/Runtime/Vector.hs similarity index 100% rename from parser-typechecker/src/Unison/Runtime/Vector.hs rename to unison-runtime/src/Unison/Runtime/Vector.hs diff --git a/parser-typechecker/src/Unison/Runtime/docs.markdown b/unison-runtime/src/Unison/Runtime/docs.markdown similarity index 100% rename from parser-typechecker/src/Unison/Runtime/docs.markdown rename to unison-runtime/src/Unison/Runtime/docs.markdown diff --git a/unison-runtime/tests/Suite.hs b/unison-runtime/tests/Suite.hs new file mode 100644 index 0000000000..7d8f033dea --- /dev/null +++ b/unison-runtime/tests/Suite.hs @@ -0,0 +1,35 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module Main where + +import EasyTest +import System.Environment (getArgs) +import System.IO +import System.IO.CodePage (withCP65001) +import Unison.Test.Runtime.ANF qualified as ANF +import Unison.Test.Runtime.ANF.Serialization qualified as ANF.Serialization +import Unison.Test.Runtime.Crypto.Rsa qualified as Rsa +import Unison.Test.Runtime.MCode qualified as MCode +import Unison.Test.Runtime.MCode.Serialization qualified as MCode.Serialization +import Unison.Test.UnisonSources qualified as UnisonSources + +test :: Test () +test = + tests + [ ANF.test, + ANF.Serialization.test, + MCode.test, + MCode.Serialization.test, + Rsa.test, + UnisonSources.test + ] + +main :: IO () +main = withCP65001 do + args <- getArgs + mapM_ (`hSetEncoding` utf8) [stdout, stdin, stderr] + case args of + [] -> runOnly "" test + [prefix] -> runOnly prefix test + [seed, prefix] -> rerunOnly (read seed) prefix test diff --git a/unison-runtime/tests/Unison/Test/Common.hs b/unison-runtime/tests/Unison/Test/Common.hs new file mode 100644 index 0000000000..e1d880002c --- /dev/null +++ b/unison-runtime/tests/Unison/Test/Common.hs @@ -0,0 +1,93 @@ +module Unison.Test.Common + ( hqLength, + t, + tm, + parseAndSynthesizeAsFile, + parsingEnv, + ) +where + +import Control.Monad.Writer (tell) +import Data.Functor.Identity (Identity (..)) +import Data.Sequence (Seq) +import Text.Megaparsec.Error qualified as MPE +import Unison.ABT qualified as ABT +import Unison.Builtin qualified as B +import Unison.FileParsers qualified as FP +import Unison.Parser.Ann (Ann (..)) +import Unison.Parsers qualified as Parsers +import Unison.PrintError (prettyParseError) +import Unison.Result (Note, Result) +import Unison.Result qualified as Result +import Unison.Symbol (Symbol) +import Unison.Syntax.Parser qualified as Parser +import Unison.Syntax.TermParser qualified as TermParser +import Unison.Syntax.TypeParser qualified as TypeParser +import Unison.Term qualified as Term +import Unison.Type qualified as Type +import Unison.UnisonFile (TypecheckedUnisonFile, UnisonFile) +import Unison.Util.Pretty qualified as Pr +import Unison.Var (Var) + +type Term v = Term.Term v Ann + +type Type v = Type.Type v Ann + +hqLength :: Int +hqLength = 10 + +t :: String -> Type Symbol +t s = + ABT.amap (const Intrinsic) + -- . either (error . show ) id + -- . Type.bindSomeNames B.names0 + . either (error . showParseError s) tweak + . runIdentity + $ Parser.run (Parser.root TypeParser.valueType) s parsingEnv + where + tweak = Type.generalizeLowercase mempty + +tm :: String -> Term Symbol +tm s = + either (error . showParseError s) id + -- . Term.bindSomeNames mempty B.names0 + -- . either (error . showParseError s) id + . runIdentity + $ Parser.run (Parser.root TermParser.term) s parsingEnv + +showParseError :: + (Var v) => + String -> + MPE.ParseError Parser.Input (Parser.Error v) -> + String +showParseError s = Pr.toANSI 60 . prettyParseError s + +parseAndSynthesizeAsFile :: + [Type Symbol] -> + FilePath -> + String -> + Result + (Seq (Note Symbol Ann)) + (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann)) +parseAndSynthesizeAsFile ambient filename s = do + file <- Result.fromParsing (runIdentity (Parsers.parseFile filename s parsingEnv)) + let typecheckingEnv = + runIdentity $ + FP.computeTypecheckingEnvironment + (FP.ShouldUseTndr'Yes parsingEnv) + ambient + (\_deps -> pure B.typeLookup) + file + case FP.synthesizeFile typecheckingEnv file of + Result.Result notes Nothing -> tell notes >> pure (Left file) + Result.Result _ (Just typecheckedFile) -> pure (Right typecheckedFile) + +parsingEnv :: Parser.ParsingEnv Identity +parsingEnv = + Parser.ParsingEnv + { uniqueNames = mempty, + uniqueTypeGuid = \_ -> pure Nothing, + names = B.names, + maybeNamespace = Nothing, + localNamespacePrefixedTypesAndConstructors = mempty + } diff --git a/unison-runtime/tests/Unison/Test/Gen.hs b/unison-runtime/tests/Unison/Test/Gen.hs new file mode 100644 index 0000000000..f66ea4e342 --- /dev/null +++ b/unison-runtime/tests/Unison/Test/Gen.hs @@ -0,0 +1,51 @@ +-- | Hedgehog generators for common unison types. +module Unison.Test.Gen where + +import Data.Text qualified as Text +import Hedgehog hiding (Rec, Test, test) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Unison.ConstructorReference +import Unison.ConstructorType qualified as CT +import Unison.Hash (Hash) +import Unison.Hash qualified as Hash +import Unison.Prelude +import Unison.Reference qualified as Reference +import Unison.Referent qualified as Referent +import Unison.Util.Text qualified as Unison.Text + +genSmallWord64 :: Gen Word64 +genSmallWord64 = Gen.word64 (Range.linear 0 100) + +genSmallInt :: Gen Int +genSmallInt = Gen.int (Range.linear 0 100) + +genReference :: Gen Reference.Reference +genReference = + Gen.choice + [ Reference.ReferenceBuiltin <$> genSmallText, + Reference.ReferenceDerived <$> genRefId + ] + where + genRefId :: Gen (Reference.Id' Hash) + genRefId = Reference.Id <$> genHash <*> genSmallWord64 + +-- This can generate invalid hashes, but that's not really an issue for testing serialization. +genHash :: Gen Hash +genHash = Hash.fromByteString <$> Gen.bytes (Range.singleton 32) + +genReferent :: Gen Referent.Referent +genReferent = + Gen.choice + [ Referent.Ref <$> genReference, + Referent.Con <$> genConstructorReference <*> genConstructorType + ] + where + genConstructorType = Gen.choice [pure CT.Data, pure CT.Effect] + genConstructorReference = ConstructorReference <$> genReference <*> genSmallWord64 + +genSmallText :: Gen Text +genSmallText = Gen.text (Range.linear 2 4) Gen.alphaNum + +genUText :: Gen Unison.Text.Text +genUText = Unison.Text.pack . Text.unpack <$> genSmallText diff --git a/unison-runtime/tests/Unison/Test/Runtime/ANF.hs b/unison-runtime/tests/Unison/Test/Runtime/ANF.hs new file mode 100644 index 0000000000..992fbc0230 --- /dev/null +++ b/unison-runtime/tests/Unison/Test/Runtime/ANF.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternGuards #-} + +module Unison.Test.Runtime.ANF where + +import Control.Monad.Reader (ReaderT (..)) +import Control.Monad.State (evalState) +import Data.Map qualified as Map +import Data.Set qualified as Set +import Data.Word (Word64) +import EasyTest +import Unison.ABT qualified as ABT +import Unison.ABT.Normalized (Term (TAbs)) +import Unison.ConstructorReference (GConstructorReference (..)) +import Unison.Pattern qualified as P +import Unison.Reference (Reference, Reference' (Builtin)) +import Unison.Runtime.ANF as ANF +import Unison.Runtime.MCode (RefNums (..), emitCombs) +import Unison.Term qualified as Term +import Unison.Test.Common +import Unison.Type as Ty +import Unison.Util.EnumContainers as EC +import Unison.Util.Text qualified as Util.Text +import Unison.Var as Var + +-- testSNF s = ok +-- where +-- t0 = tm s +-- snf = toSuperNormal (const 0) t0 + +simpleRefs :: Reference -> RTag +simpleRefs r + | r == Ty.natRef = 0 + | r == Ty.intRef = 1 + | r == Ty.floatRef = 2 + | r == Ty.booleanRef = 3 + | r == Ty.textRef = 4 + | r == Ty.charRef = 5 + | otherwise = 100 + +runANF :: (Var v) => ANFM v a -> a +runANF m = evalState (runReaderT m Set.empty) (0, 1, []) + +testANF :: String -> Test () +testANF s + | t0 == denormalize anf = ok + | otherwise = crash $ show $ denormalize anf + where + t0 = const () `Term.amap` tm s + anf = snd . runANF $ anfTerm t0 + +testLift :: String -> Test () +testLift s = case cs of !_ -> ok + where + cs = + emitCombs (RN (const 0) (const 0) (const Nothing)) (Builtin "Test") 0 + . superNormalize + . (\(ll, _, _, _) -> ll) + . lamLift mempty + $ tm s + +denormalizeLit :: (Var v) => Lit -> Term.Term0 v +denormalizeLit (I i) = Term.int () i +denormalizeLit (N n) = Term.nat () n +denormalizeLit (F f) = Term.float () f +denormalizeLit (T t) = Term.text () (Util.Text.toText t) +denormalizeLit (C c) = Term.char () c +denormalizeLit (LM r) = Term.termLink () r +denormalizeLit (LY r) = Term.typeLink () r + +denormalize :: (Var v) => ANormal v -> Term.Term0 v +denormalize (TVar v) = Term.var () v +denormalize (TLit l) = denormalizeLit l +denormalize (TBLit l) = denormalizeLit l +denormalize (THnd _ _ _) = + error "denormalize handler" +-- = Term.match () (denormalize b) $ denormalizeHandler h +denormalize (TShift _ _ _) = + error "denormalize shift" +denormalize (TLet _ v _ bn bo) + | typeOf v == ANFBlank = ABT.subst v dbn dbo + | otherwise = Term.let1_ False [(v, dbn)] dbo + where + dbn = denormalize bn + dbo = denormalize bo +denormalize (TName _ _ _ _) = + error "can't denormalize by-name bindings" +denormalize (TMatch v cs) = + Term.match () (ABT.var v) $ denormalizeMatch cs +denormalize (TApp f args) + | FCon r 0 <- f, + r `elem` [Ty.natRef, Ty.intRef], + [v] <- args = + Term.var () v +denormalize (TApp f args) = Term.apps' df (Term.var () <$> args) + where + df = case f of + FVar v -> Term.var () v + FComb _ -> error "FComb" + FCon r n -> + Term.constructor () (ConstructorReference r (fromIntegral $ rawTag n)) + FReq r n -> + Term.request () (ConstructorReference r (fromIntegral $ rawTag n)) + FPrim _ -> error "FPrim" + FCont _ -> error "denormalize FCont" +denormalize (TFrc _) = error "denormalize TFrc" + +denormalizeRef :: RTag -> Reference +denormalizeRef r + | 0 <- rawTag r = Ty.natRef + | 1 <- rawTag r = Ty.intRef + | 2 <- rawTag r = Ty.floatRef + | 3 <- rawTag r = Ty.booleanRef + | 4 <- rawTag r = Ty.textRef + | 5 <- rawTag r = Ty.charRef + | otherwise = error "denormalizeRef" + +backReference :: Word64 -> Reference +backReference _ = error "backReference" + +denormalizeMatch :: + (Var v) => Branched (ANormal v) -> [Term.MatchCase () (Term.Term0 v)] +denormalizeMatch b + | MatchEmpty <- b = [] + | MatchIntegral m df <- b = + (dcase (ipat @Word64 @Integer Ty.intRef) <$> mapToList m) ++ dfcase df + | MatchText m df <- b = + (dcase (const @_ @Integer $ P.Text () . Util.Text.toText) <$> Map.toList m) ++ dfcase df + | MatchData r cs Nothing <- b, + [(0, ([UN], zb))] <- mapToList cs, + TAbs i (TMatch j (MatchIntegral m df)) <- zb, + i == j = + (dcase (ipat @Word64 @Integer r) <$> mapToList m) ++ dfcase df + | MatchData r m df <- b = + (dcase (dpat r) . fmap snd <$> mapToList m) ++ dfcase df + | MatchRequest hs df <- b = denormalizeHandler hs df + | MatchNumeric _ cs df <- b = + (dcase (ipat @Word64 @Integer Ty.intRef) <$> mapToList cs) ++ dfcase df + | MatchSum _ <- b = error "MatchSum not a compilation target" + where + dfcase (Just d) = + [Term.MatchCase (P.Unbound ()) Nothing $ denormalize d] + dfcase Nothing = [] + + dcase p (t, br) = Term.MatchCase (p n t) Nothing dbr + where + (n, dbr) = denormalizeBranch br + + ipat :: (Integral a) => Reference -> p -> a -> P.Pattern () + ipat r _ i + | r == Ty.natRef = P.Nat () $ fromIntegral i + | otherwise = P.Int () $ fromIntegral i + dpat r n t = P.Constructor () (ConstructorReference r (fromIntegral (fromEnum t))) (replicate n $ P.Var ()) + +denormalizeBranch :: + (Num a, Var v) => + Term ANormalF v -> + (a, ABT.Term (Term.F v () ()) v ()) +denormalizeBranch (TAbs v br) = (n + 1, ABT.abs v dbr) + where + (n, dbr) = denormalizeBranch br +denormalizeBranch tm = (0, denormalize tm) + +denormalizeHandler :: + (Var v) => + Map.Map Reference (EnumMap CTag ([Mem], ANormal v)) -> + ANormal v -> + [Term.MatchCase () (Term.Term0 v)] +denormalizeHandler cs df = dcs + where + dcs = Map.foldMapWithKey rf cs <> dfc + dfc = + [ Term.MatchCase + (P.EffectPure () (P.Var ())) + Nothing + db + ] + where + (_, db) = denormalizeBranch @Int df + rf r rcs = foldMapWithKey (cf r) rcs + cf r t b = + [ Term.MatchCase + ( P.EffectBind + () + (ConstructorReference r (fromIntegral (fromEnum t))) + (replicate n $ P.Var ()) + (P.Var ()) + ) + Nothing + db + ] + where + (n, db) = denormalizeBranch (snd b) + +test :: Test () +test = + scope "anf" . tests $ + [ scope "lift" . tests $ + [ testLift + "let\n\ + \ g = m x -> ##Nat.+ x m\n\ + \ m -> g m m", + testLift + "m n -> let\n\ + \ f acc i = match i with\n\ + \ 0 -> acc\n\ + \ _ -> f (##Nat.+ acc n) (##Nat.sub i 1)\n\ + \ f 0 m" + ], + scope "denormalize" . tests $ + [ testANF "1", + testANF "1 + 2", + testANF + "match x with\n\ + \ +1 -> foo\n\ + \ +2 -> bar\n\ + \ +3 -> baz", + testANF + "1 + match x with\n\ + \ +1 -> foo\n\ + \ +2 -> bar", + testANF "(match x with +3 -> foo) + (match x with +2 -> foo)" + ] + ] diff --git a/unison-runtime/tests/Unison/Test/Runtime/ANF/Serialization.hs b/unison-runtime/tests/Unison/Test/Runtime/ANF/Serialization.hs new file mode 100644 index 0000000000..92b206ea56 --- /dev/null +++ b/unison-runtime/tests/Unison/Test/Runtime/ANF/Serialization.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Round trip tests for ANF serialization. +module Unison.Test.Runtime.ANF.Serialization (Unison.Test.Runtime.ANF.Serialization.test) where + +import Data.Bytes.Get (runGetS) +import Data.Bytes.Put (runPutS) +import Data.Primitive.Array (Array) +import Data.Primitive.Array qualified as Array +import Data.Primitive.ByteArray (ByteArray) +import Data.Primitive.ByteArray qualified as ByteArray +import Data.Primitive.Types (Prim) +import Data.Serialize.Get (Get) +import Data.Serialize.Put (Put) +import EasyTest qualified as EasyTest +import Hedgehog hiding (Rec, Test, test) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Unison.Prelude +import Unison.Runtime.ANF +import Unison.Runtime.ANF.Serialize +import Unison.Test.Gen +import Unison.Util.Bytes qualified as Util.Bytes + +test :: EasyTest.Test () +test = + void . EasyTest.scope "anf.serialization" $ do + success <- + EasyTest.io $ + checkParallel $ + Group + "roundtrip" + [ ("value", valueRoundtrip) + ] + EasyTest.expect success + +genUBytes :: Gen Util.Bytes.Bytes +genUBytes = Util.Bytes.fromByteString <$> Gen.bytes (Range.linear 0 4) + +genGroupRef :: Gen GroupRef +genGroupRef = GR <$> genReference <*> genSmallWord64 + +genValList :: Gen ValList +genValList = Gen.list (Range.linear 0 4) genValue + +genCont :: Gen Cont +genCont = do + Gen.choice + [ pure KE, + Mark <$> genSmallWord64 <*> Gen.list (Range.linear 0 4) genReference <*> Gen.map (Range.linear 0 4) ((,) <$> genReference <*> genValue) <*> genCont, + Push <$> genSmallWord64 <*> genSmallWord64 <*> genGroupRef <*> genCont + ] + +genArray :: Range Int -> Gen a -> Gen (Array a) +genArray range gen = + Array.arrayFromList <$> Gen.list range gen + +genByteArray :: (Prim p) => Gen p -> Gen ByteArray +genByteArray genP = do + ByteArray.byteArrayFromList <$> Gen.list (Range.linear 0 20) genP + +genBLit :: Gen BLit +genBLit = + Gen.choice + [ Text <$> genUText, + List <$> Gen.seq (Range.linear 0 4) genValue, + TmLink <$> genReferent, + TyLink <$> genReference, + Bytes <$> genUBytes, + Quote <$> genValue, + -- Code is not yet included, generating valid ANF terms is complex. + -- , Code <$> genCode + BArr <$> genByteArray genSmallWord64, + Pos <$> genSmallWord64, + Neg <$> genSmallWord64, + Char <$> Gen.unicode, + Float <$> Gen.double (Range.linearFrac 0 100), + Arr <$> genArray (Range.linear 0 4) genValue + ] + +genValue :: Gen Value +genValue = Gen.sized \n -> do + -- Limit amount of recursion to avoid infinitely deep values + let gValList + | n > 1 = Gen.small genValList + | otherwise = pure [] + Gen.choice + [ Partial <$> genGroupRef <*> gValList, + Data <$> genReference <*> genSmallWord64 <*> gValList, + Cont <$> gValList <*> genCont, + BLit <$> genBLit + ] + +valueRoundtrip :: Property +valueRoundtrip = + getPutRoundtrip getValue putValue genValue + +getPutRoundtrip :: (Eq a, Show a) => (Version -> Get a) -> (Version -> a -> Put) -> Gen a -> Property +getPutRoundtrip get put builder = + property $ do + v <- forAll builder + version <- forAll versionToTest + let bytes = runPutS (put version v) + runGetS (get version) bytes === Right v + where + versionToTest = do + Gen.choice + [ Transfer <$> Gen.enum 4 valueVersion, + Hash <$> Gen.enum 4 valueVersion + ] diff --git a/parser-typechecker/tests/Unison/Test/Runtime/Crypto/Rsa.hs b/unison-runtime/tests/Unison/Test/Runtime/Crypto/Rsa.hs similarity index 100% rename from parser-typechecker/tests/Unison/Test/Runtime/Crypto/Rsa.hs rename to unison-runtime/tests/Unison/Test/Runtime/Crypto/Rsa.hs diff --git a/unison-runtime/tests/Unison/Test/Runtime/MCode.hs b/unison-runtime/tests/Unison/Test/Runtime/MCode.hs new file mode 100644 index 0000000000..daaf61ea69 --- /dev/null +++ b/unison-runtime/tests/Unison/Test/Runtime/MCode.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeApplications #-} + +module Unison.Test.Runtime.MCode where + +import Control.Concurrent.STM +import Data.Map.Strict qualified as Map +import EasyTest +import Unison.Reference (Reference, Reference' (Builtin)) +import Unison.Runtime.ANF + ( Cacheability (..), + Code (..), + SuperGroup (..), + lamLift, + superNormalize, + ) +import Unison.Runtime.Machine + ( CCache (..), + apply0, + baseCCache, + cacheAdd, + ) +import Unison.Runtime.Pattern +import Unison.Symbol (Symbol) +import Unison.Term (unannotate) +import Unison.Test.Common (tm) + +dummyRef :: Reference +dummyRef = Builtin "dummy" + +mainRef :: Reference +mainRef = Builtin "main" + +modifyTVarTest :: TVar a -> (a -> a) -> Test () +modifyTVarTest v f = io . atomically $ modifyTVar v f + +testEval0 :: [(Reference, SuperGroup Symbol)] -> SuperGroup Symbol -> Test () +testEval0 env main = + ok << io do + cc <- baseCCache False + _ <- cacheAdd ((fmap . fmap) uncacheable $ (mainRef, main) : env) cc + rtm <- readTVarIO (refTm cc) + apply0 Nothing cc Nothing (rtm Map.! mainRef) + where + (<<) = flip (>>) + uncacheable sg = CodeRep sg Uncacheable + +multRec :: String +multRec = + "let\n\ + \ n = 5\n\ + \ f acc i = match i with\n\ + \ 0 -> acc\n\ + \ _ -> f (##Nat.+ acc n) (##Nat.sub i 1)\n\ + \ if (##Nat.== (f 0 1000) 5000) then () else ##bug ()" + +testEval :: String -> Test () +testEval s = testEval0 (fmap superNormalize <$> ctx) (superNormalize ll) + where + (ll, _, ctx, _) = + lamLift mempty + . splitPatterns builtinDataSpec + . unannotate + $ tm s + +nested :: String +nested = + "let\n\ + \ x = match 2 with\n\ + \ 0 -> ##Nat.+ 0 1\n\ + \ m@n -> n\n\ + \ if (##Nat.== x 2) then () else ##bug ()" + +matching'arguments :: String +matching'arguments = + "let\n\ + \ f x y z = y\n\ + \ g x = f x\n\ + \ blorf = let\n\ + \ a = 0\n\ + \ b = 1\n\ + \ d = 2\n\ + \ h = g a b\n\ + \ c = 2\n\ + \ h c\n\ + \ if (##Nat.== blorf 1) then () else ##bug ()" + +test :: Test () +test = + scope "mcode" . tests $ + [ scope "2=2" $ testEval "if (##Nat.== 2 2) then () else ##bug ()", + scope "2=1+1" $ testEval "if (##Nat.== 2 (##Nat.+ 1 1)) then () else ##bug ()", + scope "2=3-1" $ testEval "if (##Nat.== 2 (##Nat.sub 3 1)) then () else ##bug ()", + scope "5*5=25" $ + testEval "if (##Nat.== (##Nat.* 5 5) 25) then () else ##bug ()", + scope "5*1000=5000" $ + testEval "if (##Nat.== (##Nat.* 5 1000) 5000) then () else ##bug ()", + scope "5*1000=5000 rec" $ testEval multRec, + scope "nested" $ + testEval nested, + scope "matching arguments" $ + testEval matching'arguments + ] diff --git a/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs b/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs new file mode 100644 index 0000000000..a9b82a272a --- /dev/null +++ b/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Round trip tests runtime serialization +module Unison.Test.Runtime.MCode.Serialization (Unison.Test.Runtime.MCode.Serialization.test) where + +import Data.Bytes.Get (runGetS) +import Data.Bytes.Put (runPutS) +import Data.Primitive (Prim, PrimArray, primArrayFromList) +import Data.Serialize.Get (Get) +import Data.Serialize.Put (Put) +import EasyTest qualified as EasyTest +import Hedgehog hiding (Rec, Test, test) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Unison.Prelude +import Unison.Runtime.Foreign.Function.Type (ForeignFunc) +import Unison.Runtime.Interface +import Unison.Runtime.MCode (Args (..), BPrim1, BPrim2, Branch, Comb, CombIx (..), GBranch (..), GComb (..), GCombInfo (..), GInstr (..), GRef (..), GSection (..), Instr, MLit (..), Ref, Section, UPrim1, UPrim2) +import Unison.Runtime.Machine (Combs) +import Unison.Runtime.TypeTags (PackedTag (..)) +import Unison.Test.Gen +import Unison.Util.EnumContainers (EnumMap, EnumSet) +import Unison.Util.EnumContainers qualified as EC + +test :: EasyTest.Test () +test = + void . EasyTest.scope "mcode.serialization" $ do + success <- + EasyTest.io $ + checkParallel $ + Group + "roundtrip" + [ ("SCache", sCacheRoundtrip) + ] + EasyTest.expect success + +genForeignCall :: Gen ForeignFunc +genForeignCall = Gen.enumBounded + +genEnumMap :: (EC.EnumKey k) => Gen k -> Gen v -> Gen (EnumMap k v) +genEnumMap genK genV = EC.mapFromList <$> Gen.list (Range.linear 0 10) ((,) <$> genK <*> genV) + +genEnumSet :: Gen Word64 -> Gen (EnumSet Word64) +genEnumSet gen = EC.setFromList <$> Gen.list (Range.linear 0 10) gen + +genCombs :: Gen Combs +genCombs = genEnumMap genSmallWord64 genComb + +genPrimArray :: (Prim a) => Gen a -> Gen (PrimArray a) +genPrimArray gen = primArrayFromList <$> Gen.list (Range.linear 0 10) gen + +genArgs :: Gen Args +genArgs = + Gen.choice + [ pure ZArgs, + VArg1 <$> genSmallInt, + VArg2 <$> genSmallInt <*> genSmallInt, + VArgR <$> genSmallInt <*> genSmallInt, + VArgN <$> genPrimArray genSmallInt, + VArgV <$> genSmallInt + ] + +genCombIx :: Gen CombIx +genCombIx = + CIx + <$> genReference + <*> genSmallWord64 + <*> genSmallWord64 + +genGRef :: Gen Ref +genGRef = + Gen.choice + [ Stk <$> genSmallInt, + -- For Env, we discard the comb when serializing and replace it with the CombIx anyways, so we do + -- the same during generation to prevent false negatives in roundtrip tests. + do + cix <- genCombIx + pure $ Env cix cix, + Dyn <$> genSmallWord64 + ] + +genBranch :: Gen Branch +genBranch = + Gen.choice + [ Test1 <$> genSmallWord64 <*> genSection <*> genSection, + Test2 <$> genSmallWord64 <*> genSection <*> genSmallWord64 <*> genSection <*> genSection, + TestW <$> genSection <*> genEnumMap genSmallWord64 genSection, + TestT <$> genSection <*> Gen.map (Range.linear 0 10) ((,) <$> genUText <*> genSection) + ] + +genUPrim1 :: Gen UPrim1 +genUPrim1 = Gen.enumBounded + +genUPrim2 :: Gen UPrim2 +genUPrim2 = Gen.enumBounded + +genBPrim1 :: Gen BPrim1 +genBPrim1 = Gen.enumBounded + +genBPrim2 :: Gen BPrim2 +genBPrim2 = Gen.enumBounded + +genMLit :: Gen MLit +genMLit = + Gen.choice + [ MI <$> genSmallInt, + MD <$> Gen.double (Range.linearFrac 0 100), + MT <$> genUText, + MM <$> genReferent, + MY <$> genReference + ] + +genPackedTag :: Gen PackedTag +genPackedTag = PackedTag <$> genSmallWord64 + +genInstr :: Gen Instr +genInstr = + Gen.choice + [ UPrim1 <$> genUPrim1 <*> genSmallInt, + UPrim2 <$> genUPrim2 <*> genSmallInt <*> genSmallInt, + BPrim1 <$> genBPrim1 <*> genSmallInt, + BPrim2 <$> genBPrim2 <*> genSmallInt <*> genSmallInt, + ForeignCall <$> Gen.bool <*> genForeignCall <*> genArgs, + SetDyn <$> genSmallWord64 <*> genSmallInt, + Capture <$> genSmallWord64, + Name <$> genGRef <*> genArgs, + Info <$> Gen.string (Range.linear 0 10) Gen.alphaNum, + Pack <$> genReference <*> genPackedTag <*> genArgs, + Lit <$> genMLit, + Print <$> genSmallInt, + Reset <$> genEnumSet genSmallWord64, + Fork <$> genSmallInt, + Atomically <$> genSmallInt, + Seq <$> genArgs, + TryForce <$> genSmallInt + ] + +genSection :: Gen Section +genSection = do + Gen.recursive + Gen.choice + [ Yield <$> genArgs, + Die <$> Gen.string (Range.linear 0 10) Gen.alphaNum, + pure Exit + ] + [ App <$> Gen.bool <*> genGRef <*> genArgs, + do + b <- Gen.bool + cix <- genCombIx + args <- genArgs + -- For Call, we discard the comb when serializing and replace it with the CombIx anyways, so we do + -- the same during generation to prevent false negatives in roundtrip tests. + pure $ Call b cix cix args, + Match <$> genSmallInt <*> genBranch, + Ins <$> genInstr <*> genSection, + Let <$> genSection <*> genCombIx <*> genSmallInt <*> genSection, + DMatch <$> Gen.maybe genReference <*> genSmallInt <*> genBranch, + NMatch <$> Gen.maybe genReference <*> genSmallInt <*> genBranch, + RMatch <$> genSmallInt <*> genSection <*> genEnumMap genSmallWord64 genBranch + ] + +genCombInfo :: Gen (GCombInfo CombIx) +genCombInfo = + LamI + <$> Gen.int (Range.linear 0 10) + <*> Gen.int (Range.linear 0 10) + <*> genSection + +genComb :: Gen Comb +genComb = + Gen.choice + [ Comb <$> genCombInfo + -- We omit cached closures from roundtrip tests since we don't currently serialize cached closure results + -- CachedClosure + ] + +genStoredCache :: Gen StoredCache +genStoredCache = + SCache + <$> (genEnumMap genSmallWord64 genCombs) + <*> (genEnumMap genSmallWord64 genReference) + <*> (genEnumSet genSmallWord64) + <*> (genEnumMap genSmallWord64 genReference) + <*> genSmallWord64 + <*> genSmallWord64 + <*> + -- We don't yet generate supergroups because generating valid ones is difficult. + mempty + <*> (Gen.map (Range.linear 0 10) ((,) <$> genReference <*> genSmallWord64)) + <*> (Gen.map (Range.linear 0 10) ((,) <$> genReference <*> genSmallWord64)) + <*> (Gen.map (Range.linear 0 10) ((,) <$> genReference <*> (Gen.set (Range.linear 0 10) genReference))) + +sCacheRoundtrip :: Property +sCacheRoundtrip = + getPutRoundtrip getStoredCache (putStoredCache) genStoredCache + +getPutRoundtrip :: (Eq a, Show a) => Get a -> (a -> Put) -> Gen a -> Property +getPutRoundtrip get put builder = + property $ do + v <- forAll builder + let bytes = runPutS (put v) + runGetS get bytes === Right v diff --git a/parser-typechecker/tests/Unison/Test/UnisonSources.hs b/unison-runtime/tests/Unison/Test/UnisonSources.hs similarity index 99% rename from parser-typechecker/tests/Unison/Test/UnisonSources.hs rename to unison-runtime/tests/Unison/Test/UnisonSources.hs index e618ac8fb9..0f7cb980c5 100644 --- a/parser-typechecker/tests/Unison/Test/UnisonSources.hs +++ b/unison-runtime/tests/Unison/Test/UnisonSources.hs @@ -10,7 +10,7 @@ import System.FilePath (joinPath, replaceExtension, splitPath) import System.FilePath.Find (always, extension, find, (==?)) import Unison.Builtin qualified as Builtin import Unison.Codebase.Runtime (Runtime, evaluateWatches) -import Unison.NamesWithHistory qualified as Names +import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) import Unison.Parsers qualified as Parsers import Unison.Prelude diff --git a/unison-runtime/unison-runtime.cabal b/unison-runtime/unison-runtime.cabal new file mode 100644 index 0000000000..ffb43b0179 --- /dev/null +++ b/unison-runtime/unison-runtime.cabal @@ -0,0 +1,248 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: unison-runtime +version: 0.0.0 +homepage: https://github.com/unisonweb/unison#readme +bug-reports: https://github.com/unisonweb/unison/issues +copyright: Copyright (C) 2013-2024 Unison Computing, PBC and contributors +license: MIT +license-file: LICENSE +build-type: Simple + +source-repository head + type: git + location: https://github.com/unisonweb/unison + +flag arraychecks + manual: True + default: False + +flag dumpcore + manual: True + default: False + +flag optchecks + manual: True + default: False + +flag stackchecks + manual: True + default: False + +library + exposed-modules: + Unison.Codebase.Execute + Unison.Runtime.ANF + Unison.Runtime.ANF.Rehash + Unison.Runtime.ANF.Serialize + Unison.Runtime.Array + Unison.Runtime.Builtin + Unison.Runtime.Builtin.Types + Unison.Runtime.Crypto.Rsa + Unison.Runtime.Debug + Unison.Runtime.Decompile + Unison.Runtime.Exception + Unison.Runtime.Foreign + Unison.Runtime.Foreign.Function + Unison.Runtime.Foreign.Function.Type + Unison.Runtime.Interface + Unison.Runtime.IOSource + Unison.Runtime.Machine + Unison.Runtime.MCode + Unison.Runtime.MCode.Serialize + Unison.Runtime.Pattern + Unison.Runtime.Serialize + Unison.Runtime.SparseVector + Unison.Runtime.Stack + Unison.Runtime.TypeTags + Unison.Runtime.Vector + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + ViewPatterns + ghc-options: -fmax-worker-args=100 -Wall -funbox-strict-fields -O2 + build-depends: + asn1-encoding + , asn1-types + , atomic-primops + , base + , binary + , bytes + , bytestring + , cereal + , clock + , containers >=0.6.3 + , crypton-x509 + , crypton-x509-store + , crypton-x509-system + , cryptonite + , data-default + , data-memocombinators + , deepseq + , directory + , exceptions + , filepath + , inspection-testing + , iproute + , lens + , memory + , mmorph + , mtl + , murmur-hash + , network + , network-simple + , network-udp + , pem + , primitive + , process + , raw-strings-qq + , safe-exceptions + , stm + , tagged + , template-haskell + , temporary + , text + , time + , tls + , unison-codebase-sqlite + , unison-core + , unison-core1 + , unison-hash + , unison-parser-typechecker + , unison-prelude + , unison-pretty-printer + , unison-syntax + , unison-util-bytes + , unison-util-recursion + , unliftio + , vector + default-language: Haskell2010 + if flag(arraychecks) + cpp-options: -DARRAY_CHECK + if flag(stackchecks) + cpp-options: -DSTACK_CHECK + if flag(optchecks) + ghc-options: -O2 + cpp-options: -DOPT_CHECK + build-depends: + inspection-testing + if flag(dumpcore) + ghc-options: -ddump-simpl -ddump-stg-final -ddump-to-file -dsuppress-coercions -dsuppress-idinfo -dsuppress-module-prefixes -ddump-str-signatures -ddump-simpl-stats + +test-suite runtime-tests + type: exitcode-stdio-1.0 + main-is: Suite.hs + other-modules: + Unison.Test.Common + Unison.Test.Gen + Unison.Test.Runtime.ANF + Unison.Test.Runtime.ANF.Serialization + Unison.Test.Runtime.Crypto.Rsa + Unison.Test.Runtime.MCode + Unison.Test.Runtime.MCode.Serialization + Unison.Test.UnisonSources + Paths_unison_runtime + hs-source-dirs: + tests + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + ViewPatterns + ghc-options: -fmax-worker-args=100 -Wall -funbox-strict-fields -O2 -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 + build-depends: + base + , bytes + , cereal + , code-page + , containers + , cryptonite + , directory + , easytest + , filemanip + , filepath + , hedgehog + , hex-text + , lens + , megaparsec + , mtl + , primitive + , stm + , text + , unison-core1 + , unison-hash + , unison-parser-typechecker + , unison-prelude + , unison-pretty-printer + , unison-runtime + , unison-syntax + , unison-util-bytes + default-language: Haskell2010 + if flag(arraychecks) + cpp-options: -DARRAY_CHECK + if flag(stackchecks) + cpp-options: -DSTACK_CHECK + if flag(optchecks) + ghc-options: -O2 + cpp-options: -DOPT_CHECK + build-depends: + inspection-testing + if flag(dumpcore) + ghc-options: -ddump-simpl -ddump-stg-final -ddump-to-file -dsuppress-coercions -dsuppress-idinfo -dsuppress-module-prefixes -ddump-str-signatures -ddump-simpl-stats diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 6bea13f3dc..8ed217cf4d 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -9,7 +9,6 @@ library: other-modules: Paths_unison_share_api dependencies: - - NanoID - aeson >= 2.0.0.0 - async - base @@ -25,13 +24,10 @@ dependencies: - fuzzyfind - http-media - http-types - - jose - - jwt - lens - lucid - memory - mtl - - mwc-random - nonempty-containers - openapi3 - regex-tdfa @@ -39,7 +35,6 @@ dependencies: - servant-docs - servant-openapi3 - servant-server - - servant-auth - text - transformers - unison-codebase @@ -53,13 +48,12 @@ dependencies: - unison-parser-typechecker - unison-prelude - unison-pretty-printer - - unison-util-base32hex + - unison-runtime - unison-util-relation - unison-share-projects-api - unison-sqlite - unison-syntax - unliftio - - unordered-containers - uri-encode - utf8-string - vector diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index c2e2ceffb0..f40a85b248 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -38,7 +38,7 @@ module Unison.Server.Backend lsAtPath, lsBranch, mungeSyntaxText, - resolveCausalHashV2, + Codebase.expectCausalBranchByCausalHash, resolveRootBranchHashV2, namesAtPathFromRootBranchHash, termEntryDisplayName, @@ -58,7 +58,6 @@ module Unison.Server.Backend renderDocRefs, docsForDefinitionName, normaliseRootCausalHash, - causalHashForProjectBranchName, -- * Unused, could remove? resolveRootBranchHash, @@ -101,21 +100,18 @@ import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (BranchHash, CausalHash (..)) import U.Codebase.Referent qualified as V2Referent -import U.Codebase.Sqlite.Operations qualified as Operations import U.Codebase.Sqlite.Operations qualified as Ops -import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) -import U.Codebase.Sqlite.Queries qualified as Q import Unison.ABT qualified as ABT import Unison.Builtin qualified as B import Unison.Builtin.Decls qualified as Decls import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase -import Unison.Codebase qualified as UCodebase import Unison.Codebase.Branch (Branch) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Names qualified as Branch import Unison.Codebase.Editor.DisplayObject import Unison.Codebase.Editor.DisplayObject qualified as DisplayObject +import Unison.Codebase.Execute qualified as Codebase import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Runtime qualified as Rt @@ -130,7 +126,7 @@ import Unison.ConstructorType qualified as CT import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration.Dependencies qualified as DD import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Hashing.V2.Convert qualified as Hashing import Unison.LabeledDependency qualified as LD import Unison.Name (Name) @@ -148,8 +144,7 @@ import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnv.Util qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED -import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) -import Unison.Project.Util qualified as ProjectUtils +import Unison.Project (ProjectBranchName, ProjectName) import Unison.Reference (Reference, TermReference, TypeReference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) @@ -161,7 +156,7 @@ import Unison.Server.NameSearch (NameSearch (..), Search (..), applySearch) import Unison.Server.NameSearch.Sqlite (termReferentsByShortHash, typeReferencesByShortHash) import Unison.Server.QueryResult import Unison.Server.SearchResult qualified as SR -import Unison.Server.SearchResult' qualified as SR' +import Unison.Server.SearchResultPrime qualified as SR' import Unison.Server.Syntax qualified as Syntax import Unison.Server.Types import Unison.Server.Types qualified as ServerTypes @@ -170,7 +165,7 @@ import Unison.ShortHash qualified as SH import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Syntax.DeclPrinter qualified as DeclPrinter -import Unison.Syntax.HashQualified' qualified as HQ' (toText) +import Unison.Syntax.HashQualifiedPrime qualified as HQ' (toText) import Unison.Syntax.Name as Name (toText, unsafeParseText) import Unison.Syntax.NamePrinter qualified as NP import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) @@ -219,10 +214,10 @@ data BackendError = NoSuchNamespace Path.Absolute | -- Failed to parse path BadNamespace + -- | error message String - -- ^ error message + -- | namespace String - -- ^ namespace | CouldntExpandBranchHash ShortCausalHash | AmbiguousBranchHash ShortCausalHash (Set ShortCausalHash) | AmbiguousHashForDefinition ShortHash @@ -370,12 +365,12 @@ lsAtPath :: (MonadIO m) => Codebase m Symbol Ann -> -- The root to follow the path from. - Maybe (V2Branch.Branch Sqlite.Transaction) -> + V2Branch.Branch Sqlite.Transaction -> -- Path from the root to the branch to 'ls' Path.Absolute -> m [ShallowListEntry Symbol Ann] -lsAtPath codebase mayRootBranch absPath = do - b <- Codebase.runTransaction codebase (Codebase.getShallowBranchAtPath (Path.unabsolute absPath) mayRootBranch) +lsAtPath codebase rootBranch absPath = do + b <- Codebase.runTransaction codebase (Codebase.getShallowBranchAtPath (Path.unabsolute absPath) rootBranch) lsBranch codebase b findDocInBranch :: @@ -468,11 +463,11 @@ getTermTag codebase r sig = do V2Referent.Con ref _ -> Just <$> Codebase.runTransaction codebase (Codebase.getDeclType codebase ref) pure $ if - | isDoc -> Doc - | isTest -> Test - | Just CT.Effect <- constructorType -> Constructor Ability - | Just CT.Data <- constructorType -> Constructor Data - | otherwise -> Plain + | isDoc -> Doc + | isTest -> Test + | Just CT.Effect <- constructorType -> Constructor Ability + | Just CT.Data <- constructorType -> Constructor Data + | otherwise -> Plain getTypeTag :: (Var v) => @@ -579,14 +574,10 @@ lsBranch codebase b0 = do (ns, (h, stats)) <- Map.toList $ childrenWithStats guard $ V2Branch.hasDefinitions stats pure $ ShallowBranchEntry ns (V2Causal.causalHash h) stats - patchEntries :: [ShallowListEntry Symbol Ann] = do - (ns, _h) <- Map.toList $ V2Branch.patches b0 - pure $ ShallowPatchEntry ns pure . List.sortOn listEntryName $ termEntries ++ typeEntries ++ branchEntries - ++ patchEntries -- Any absolute names in the input which have `root` as a prefix -- are converted to names relative to current path. All other names are @@ -704,14 +695,12 @@ expandShortCausalHash hash = do -- | Efficiently resolve a root hash and path to a shallow branch's causal. getShallowCausalAtPathFromRootHash :: - Maybe CausalHash -> + CausalHash -> Path -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -getShallowCausalAtPathFromRootHash mayRootHash path = do - shallowRoot <- case mayRootHash of - Nothing -> Codebase.getShallowRootCausal - Just h -> Codebase.expectCausalBranchByCausalHash h - Codebase.getShallowCausalAtPath path (Just shallowRoot) +getShallowCausalAtPathFromRootHash rootHash path = do + shallowRoot <- Codebase.expectCausalBranchByCausalHash rootHash + Codebase.getShallowCausalAtPath path shallowRoot formatType' :: (Var v) => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText formatType' ppe w = @@ -813,7 +802,7 @@ evalDocRef rt codebase r = do eval errsVar (Term.amap (const mempty) -> tm) = do -- We use an empty ppe for evalutation, it's only used for adding additional context to errors. let evalPPE = PPE.empty - let codeLookup = Codebase.toCodeLookup codebase + let codeLookup = Codebase.codebaseToCodeLookup codebase let cache r = fmap Term.unannotate <$> Codebase.runTransaction codebase (Codebase.lookupWatchCache codebase r) r <- fmap hush . liftIO $ Rt.evaluateTerm' codeLookup cache evalPPE rt tm -- Only cache watches when we're not in readonly mode @@ -991,16 +980,12 @@ namesAtPathFromRootBranchHash :: forall m n v a. (MonadIO m) => Codebase m v a -> - Maybe (V2Branch.CausalBranch n) -> + V2Branch.CausalBranch n -> Path -> Backend m (Names, PPED.PrettyPrintEnvDecl) -namesAtPathFromRootBranchHash codebase mbh path = do +namesAtPathFromRootBranchHash codebase cb path = do shouldUseNamesIndex <- asks useNamesIndex - (rootBranchHash, rootCausalHash) <- case mbh of - Just cb -> pure (V2Causal.valueHash cb, V2Causal.causalHash cb) - Nothing -> lift $ do - cb <- Codebase.runTransaction codebase Operations.expectRootCausal - pure (V2Causal.valueHash cb, V2Causal.causalHash cb) + let (rootBranchHash, rootCausalHash) = (V2Causal.valueHash cb, V2Causal.causalHash cb) haveNameLookupForRoot <- lift $ Codebase.runTransaction codebase (Ops.checkBranchHashNameLookupExists rootBranchHash) hashLen <- lift $ Codebase.runTransaction codebase Codebase.hashLength names <- @@ -1009,47 +994,34 @@ namesAtPathFromRootBranchHash codebase mbh path = do when (not haveNameLookupForRoot) . throwError $ ExpectedNameLookup rootBranchHash lift . Codebase.runTransaction codebase $ Codebase.namesAtPath rootBranchHash path else do - Branch.toNames . Branch.getAt0 path . Branch.head <$> resolveCausalHash (Just rootCausalHash) codebase + Branch.toNames . Branch.getAt0 path . Branch.head <$> resolveCausalHash rootCausalHash codebase let pped = PPED.makePPED (PPE.hqNamer hashLen names) (PPE.suffixifyByHash names) pure (names, pped) resolveCausalHash :: - (Monad m) => Maybe CausalHash -> Codebase m v a -> Backend m (Branch m) -resolveCausalHash h codebase = case h of - Nothing -> lift (Codebase.getRootBranch codebase) - Just bhash -> do - mayBranch <- lift $ Codebase.getBranchForHash codebase bhash - whenNothing mayBranch (throwError $ NoBranchForHash bhash) - -resolveCausalHashV2 :: Maybe CausalHash -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -resolveCausalHashV2 h = case h of - Nothing -> Codebase.getShallowRootCausal - Just ch -> Codebase.expectCausalBranchByCausalHash ch + (Monad m) => CausalHash -> Codebase m v a -> Backend m (Branch m) +resolveCausalHash bhash codebase = do + mayBranch <- lift $ Codebase.getBranchForHash codebase bhash + whenNothing mayBranch (throwError $ NoBranchForHash bhash) resolveRootBranchHash :: - (MonadIO m) => Maybe ShortCausalHash -> Codebase m v a -> Backend m (Branch m) -resolveRootBranchHash mayRoot codebase = case mayRoot of - Nothing -> - lift (Codebase.getRootBranch codebase) - Just sch -> do - h <- hoistBackend (Codebase.runTransaction codebase) (expandShortCausalHash sch) - resolveCausalHash (Just h) codebase + (MonadIO m) => ShortCausalHash -> Codebase m v a -> Backend m (Branch m) +resolveRootBranchHash sch codebase = do + h <- hoistBackend (Codebase.runTransaction codebase) (expandShortCausalHash sch) + resolveCausalHash h codebase resolveRootBranchHashV2 :: - Maybe ShortCausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -resolveRootBranchHashV2 mayRoot = case mayRoot of - Nothing -> lift Codebase.getShallowRootCausal - Just sch -> do - h <- expandShortCausalHash sch - lift (resolveCausalHashV2 (Just h)) - -normaliseRootCausalHash :: Maybe (Either ShortCausalHash CausalHash) -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -normaliseRootCausalHash mayCh = case mayCh of - Nothing -> lift $ resolveCausalHashV2 Nothing - Just (Left sch) -> do + ShortCausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) +resolveRootBranchHashV2 sch = do + h <- expandShortCausalHash sch + lift (Codebase.expectCausalBranchByCausalHash h) + +normaliseRootCausalHash :: Either ShortCausalHash CausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) +normaliseRootCausalHash = \case + (Left sch) -> do ch <- expandShortCausalHash sch - lift $ resolveCausalHashV2 (Just ch) - Just (Right ch) -> lift $ resolveCausalHashV2 (Just ch) + lift $ Codebase.expectCausalBranchByCausalHash ch + (Right ch) -> lift $ Codebase.expectCausalBranchByCausalHash ch -- | Determines whether we include full cycles in the results, (e.g. if I search for `isEven`, will I find `isOdd` too?) -- @@ -1275,15 +1247,3 @@ loadTypeDisplayObject c = \case Reference.DerivedId id -> maybe (MissingObject $ Reference.idToShortHash id) UserObject <$> Codebase.getTypeDeclaration c id - --- | Get the causal hash a given project branch points to -causalHashForProjectBranchName :: (MonadIO m) => ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe CausalHash) -causalHashForProjectBranchName (ProjectAndBranch projectName branchName) = do - Q.loadProjectBranchByNames projectName branchName >>= \case - Nothing -> pure Nothing - Just ProjectBranch {projectId, branchId} -> do - let path = ProjectUtils.projectBranchPath (ProjectAndBranch projectId branchId) - -- Use the default codebase root - let codebaseRoot = Nothing - mayCausal <- UCodebase.getShallowCausalFromRoot codebaseRoot (Path.unabsolute path) - pure . Just $ V2Causal.causalHash mayCausal diff --git a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs index 443f064545..abef221e37 100644 --- a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs +++ b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs @@ -16,7 +16,7 @@ import Unison.Server.Types (DisplayObjectDiff (..), SemanticSyntaxDiff (..)) import Unison.Util.AnnotatedText (AnnotatedText (..)) import Unison.Util.AnnotatedText qualified as AT -diffDisplayObjects :: HasCallStack => DisplayObject SyntaxText SyntaxText -> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff +diffDisplayObjects :: (HasCallStack) => DisplayObject SyntaxText SyntaxText -> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff diffDisplayObjects from to = case (from, to) of (BuiltinObject fromST, BuiltinObject toST) -> DisplayObjectDiff (BuiltinObject (diffSyntaxText fromST toST)) (MissingObject fromSH, MissingObject toSH) @@ -35,10 +35,24 @@ diffSyntaxText (AnnotatedText fromST) (AnnotatedText toST) = where -- We special-case situations where the name of a definition changed but its hash didn't; -- and cases where the name didn't change but the hash did. - -- So, we treat these elements as equal then detect them in a post-processing step. + -- + -- The diff algorithm only understands whether items are equal or not, so in order to add this special behavior we + -- treat these special cases as equal, then we can detect and expand them in a post-processing step. diffEq :: AT.Segment Syntax.Element -> AT.Segment Syntax.Element -> Bool diffEq (AT.Segment {segment = fromSegment, annotation = fromAnnotation}) (AT.Segment {segment = toSegment, annotation = toAnnotation}) = - fromSegment == toSegment || fromAnnotation == toAnnotation + fromSegment == toSegment + || case (fromAnnotation, toAnnotation) of + (Nothing, _) -> False + (_, Nothing) -> False + (Just a, Just b) -> + case a of + -- The set of annotations we want to special-case + Syntax.TypeReference {} -> a == b + Syntax.TermReference {} -> a == b + Syntax.DataConstructorReference {} -> a == b + Syntax.AbilityConstructorReference {} -> a == b + Syntax.HashQualifier {} -> a == b + _ -> False expandSpecialCases :: [Diff.Diff [AT.Segment (Syntax.Element)]] -> [SemanticSyntaxDiff] expandSpecialCases xs = @@ -53,11 +67,28 @@ diffSyntaxText (AnnotatedText fromST) (AnnotatedText toST) = ( \next acc -> case (acc, next) of (Both xs : rest, Left seg) -> Both (seg : xs) : rest (_, Left seg) -> Both [seg] : acc - (_, Right diff) -> diff : acc + (_, Right diff) -> diff ++ acc ) - detectSpecialCase :: AT.Segment Syntax.Element -> AT.Segment Syntax.Element -> Either (AT.Segment Syntax.Element) SemanticSyntaxDiff + detectSpecialCase :: AT.Segment Syntax.Element -> AT.Segment Syntax.Element -> Either (AT.Segment Syntax.Element) [SemanticSyntaxDiff] detectSpecialCase fromSegment toSegment | fromSegment == toSegment = Left fromSegment - | AT.annotation fromSegment == AT.annotation toSegment = Right (SegmentChange (AT.segment fromSegment, AT.segment toSegment) (AT.annotation fromSegment)) - | AT.segment fromSegment == AT.segment toSegment = Right (AnnotationChange (AT.segment fromSegment) (AT.annotation fromSegment, AT.annotation toSegment)) - | otherwise = error "diffSyntaxText: found Syntax Elements in 'both' which have nothing in common." + | AT.annotation fromSegment == AT.annotation toSegment = Right [SegmentChange (AT.segment fromSegment, AT.segment toSegment) (AT.annotation fromSegment)] + -- We only emit an annotation change if it's a change in just the hash of the element (optionally the KIND of hash reference can change too). + | AT.segment fromSegment == AT.segment toSegment, + Just _fromHash <- AT.annotation fromSegment >>= elementHash, + Just _toHash <- AT.annotation toSegment >>= elementHash = + Right [AnnotationChange (AT.segment fromSegment) (AT.annotation fromSegment, AT.annotation toSegment)] + | otherwise = + -- the annotation changed, but it's not a recognized hash change. + -- This can happen in certain special cases, e.g. a paren changed from being a syntax element into being part + -- of a unit. + -- We just emit both as old/new segments. + Right [Old [fromSegment], New [toSegment]] + where + elementHash :: Syntax.Element -> Maybe Syntax.UnisonHash + elementHash = \case + Syntax.TypeReference hash -> Just hash + Syntax.TermReference hash -> Just hash + Syntax.DataConstructorReference hash -> Just hash + Syntax.AbilityConstructorReference hash -> Just hash + _ -> Nothing diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index 7ceef3c0fe..a9c28438f9 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -16,7 +16,6 @@ import Data.ByteString.Char8 (unpack) import Data.ByteString.Char8 qualified as C8 import Data.ByteString.Lazy qualified as Lazy import Data.ByteString.Lazy.UTF8 qualified as BLU -import Data.NanoID (customNanoID, defaultAlphabet, unNanoID) import Data.OpenApi (Info (..), License (..), OpenApi, URL (..)) import Data.OpenApi.Lens qualified as OpenApi import Data.Proxy (Proxy (..)) @@ -36,7 +35,6 @@ import Network.Wai.Handler.Warp setBeforeMainLoop, setHost, setPort, - withApplicationSettings, ) import Network.Wai.Middleware.Cors (cors, corsMethods, corsOrigins, simpleCorsResourcePolicy) import Servant @@ -47,7 +45,7 @@ import Servant serve, throwError, ) -import Servant qualified as Servant +import Servant qualified import Servant.API ( Accept (..), Capture, @@ -83,7 +81,8 @@ import System.Directory (canonicalizePath, doesFileExist) import System.Environment (getExecutablePath) import System.FilePath (()) import System.FilePath qualified as FilePath -import System.Random.MWC (createSystemRandom) +import U.Codebase.Branch qualified as V2 +import U.Codebase.Causal qualified as Causal import U.Codebase.HashTags (CausalHash) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase @@ -117,16 +116,13 @@ import Unison.Server.Local.Endpoints.Projects (ListProjectBranchesEndpoint, List import Unison.Server.Local.Endpoints.UCM (UCMAPI, ucmServer) import Unison.Server.NameSearch (NameSearch (..)) import Unison.Server.NameSearch.FromNames qualified as Names -import Unison.Server.Types (TermDefinition (..), TermDiffResponse (..), TypeDefinition (..), TypeDiffResponse (..), mungeString, setCacheControl) +import Unison.Server.Types (RequiredQueryParam, TermDefinition (..), TermDiffResponse (..), TypeDefinition (..), TypeDiffResponse (..), mungeString, setCacheControl) import Unison.ShortHash qualified as ShortHash import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.Pretty qualified as Pretty --- | Fail the route with a reasonable error if the query param is missing. -type RequiredQueryParam = Servant.QueryParam' '[Servant.Required, Servant.Strict] - -- HTML content type data HTML = HTML @@ -142,11 +138,8 @@ type OpenApiJSON = "openapi.json" :> Get '[JSON] OpenApi type UnisonAndDocsAPI = UnisonLocalAPI :<|> OpenApiJSON :<|> Raw -type LooseCodeAPI = CodebaseServerAPI - type UnisonLocalAPI = ("projects" :> ProjectsAPI) - :<|> ("non-project-code" :> LooseCodeAPI) :<|> ("ucm" :> UCMAPI) type CodebaseServerAPI = @@ -234,9 +227,8 @@ data DefinitionReference deriving stock (Show) data Service - = LooseCodeUI Path.Absolute (Maybe DefinitionReference) - | -- (Project branch names, perspective within project, definition reference) - ProjectBranchUI (ProjectAndBranch ProjectName ProjectBranchName) Path.Path (Maybe DefinitionReference) + = -- (Project branch names, perspective within project, definition reference) + ProjectBranchUI (ProjectAndBranch ProjectName ProjectBranchName) Path.Absolute (Maybe DefinitionReference) | Api deriving stock (Show) @@ -295,14 +287,12 @@ data URISegment urlFor :: Service -> BaseUrl -> Text urlFor service baseUrl = case service of - LooseCodeUI perspective def -> - tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "non-project-code"] <> path (Path.unabsolute perspective) def) ProjectBranchUI (ProjectAndBranch projectName branchName) perspective def -> tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "projects", DontEscape $ into @Text projectName, DontEscape $ into @Text branchName] <> path perspective def) Api -> tShow baseUrl <> "/" <> toUrlPath [DontEscape "api"] where - path :: Path.Path -> Maybe DefinitionReference -> [URISegment] - path ns def = + path :: Path.Absolute -> Maybe DefinitionReference -> [URISegment] + path (Path.Absolute ns) def = let nsPath = namespacePath ns in case definitionPath def of Just defPath -> case nsPath of @@ -405,14 +395,6 @@ app :: app env rt codebase uiPath expectedToken allowCorsHost = corsPolicy allowCorsHost $ serve appAPI $ server env rt codebase uiPath expectedToken --- | The Token is used to help prevent multiple users on a machine gain access to --- each others codebases. -genToken :: IO Strict.ByteString -genToken = do - g <- createSystemRandom - n <- customNanoID defaultAlphabet 16 g - pure $ unNanoID n - data Waiter a = Waiter { notify :: a -> IO (), waitFor :: IO a @@ -475,21 +457,23 @@ startServer env opts rt codebase onStart = do envUI <- canonicalizePath $ fromMaybe (FilePath.takeDirectory exePath "ui") (codebaseUIPath opts) token <- case token opts of Just t -> return $ C8.pack t - _ -> genToken + Nothing -> return $ C8.pack "codebase" let baseUrl = BaseUrl (fromMaybe "http://127.0.0.1" (host opts)) token let settings = defaultSettings - & maybe id setPort (port opts) - & maybe id (setHost . fromString) (host opts) - let a = app env rt codebase envUI token (allowCorsHost opts) + & setPort (fromMaybe 5858 $ port opts) + & (setHost . fromString) (fromMaybe "127.0.0.1" $ host opts) + let app' = app env rt codebase envUI token (allowCorsHost opts) case port opts of - Nothing -> withApplicationSettings settings (pure a) (onStart . baseUrl) - Just p -> do + Nothing -> withPort settings baseUrl app' 5858 + Just p -> withPort settings baseUrl app' p + where + withPort settings baseUrl app' p = do started <- mkWaiter let settings' = setBeforeMainLoop (notify started ()) settings result <- race - (runSettings settings' a) + (runSettings settings' app') (waitFor started *> onStart (baseUrl p)) case result of Left () -> throwIO $ ErrorCall "Server exited unexpectedly!" @@ -518,16 +502,30 @@ serveIndex path = do serveUI :: FilePath -> Server WebUI serveUI path _ = serveIndex path --- Apply cors if there is allow-cors-host defined +{- + Allows CORS requests from UCM Desktop: + * Mac/Linux: tauri://localhost + * Windows: https://tauri.localhost, http://tauri.localhost +-} corsPolicy :: Maybe String -> Middleware -corsPolicy = maybe id \allowCorsHost -> - cors $ - const $ - Just - simpleCorsResourcePolicy - { corsMethods = ["GET", "OPTIONS"], - corsOrigins = Just ([C8.pack allowCorsHost], True) - } +corsPolicy allowCorsHost = + case allowCorsHost of + Just host -> + corsPolicy_ (host : tauriHosts) + Nothing -> + corsPolicy_ tauriHosts + where + tauriHosts = + ["tauri://localhost", "https://tauri.localhost", "http://tauri.localhost"] + + corsPolicy_ hosts = + cors $ + const $ + Just + simpleCorsResourcePolicy + { corsMethods = ["GET", "OPTIONS"], + corsOrigins = Just (fmap C8.pack hosts, True) + } server :: BackendEnv -> @@ -560,18 +558,6 @@ serveOpenAPI = pure openAPI hoistWithAuth :: forall api. (HasServer api '[]) => Proxy api -> ByteString -> ServerT api Handler -> ServerT (Authed api) Handler hoistWithAuth api expectedToken server token = hoistServer @api @Handler @Handler api (\h -> handleAuth expectedToken token *> h) server -serveLooseCode :: - Codebase IO Symbol Ann -> - Rt.Runtime Symbol -> - ServerT LooseCodeAPI (Backend IO) -serveLooseCode codebase rt = - (\root rel name -> setCacheControl <$> NamespaceListing.serve codebase (Left <$> root) rel name) - :<|> (\namespaceName mayRoot renderWidth -> setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Left <$> mayRoot) renderWidth) - :<|> (\mayRoot relativePath rawHqns renderWidth suff -> setCacheControl <$> serveDefinitions rt codebase (Left <$> mayRoot) relativePath rawHqns renderWidth suff) - :<|> (\mayRoot relativePath limit renderWidth query -> setCacheControl <$> serveFuzzyFind codebase (Left <$> mayRoot) relativePath limit renderWidth query) - :<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTermSummary codebase shortHash mayName (Left <$> mayRoot) relativeTo renderWidth) - :<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTypeSummary codebase shortHash mayName (Left <$> mayRoot) relativeTo renderWidth) - serveProjectsCodebaseServerAPI :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> @@ -587,35 +573,39 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do :<|> serveTypeSummaryEndpoint where projectAndBranchName = ProjectAndBranch projectName branchName - namespaceListingEndpoint _rootParam rel name = do - root <- resolveProjectRoot codebase projectAndBranchName - setCacheControl <$> NamespaceListing.serve codebase (Just . Right $ root) rel name - namespaceDetailsEndpoint namespaceName _rootParam renderWidth = do - root <- resolveProjectRoot codebase projectAndBranchName - setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just . Right $ root) renderWidth - - serveDefinitionsEndpoint _rootParam relativePath rawHqns renderWidth suff = do - root <- resolveProjectRoot codebase projectAndBranchName - setCacheControl <$> serveDefinitions rt codebase (Just . Right $ root) relativePath rawHqns renderWidth suff - - serveFuzzyFindEndpoint _rootParam relativePath limit renderWidth query = do - root <- resolveProjectRoot codebase projectAndBranchName - setCacheControl <$> serveFuzzyFind codebase (Just . Right $ root) relativePath limit renderWidth query - - serveTermSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do - root <- resolveProjectRoot codebase projectAndBranchName - setCacheControl <$> serveTermSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth - - serveTypeSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do - root <- resolveProjectRoot codebase projectAndBranchName - setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth - -resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO CausalHash + namespaceListingEndpoint rel name = do + root <- resolveProjectRootHash codebase projectAndBranchName + setCacheControl <$> NamespaceListing.serve codebase (Right root) rel name + namespaceDetailsEndpoint namespaceName renderWidth = do + root <- resolveProjectRootHash codebase projectAndBranchName + setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Right root) renderWidth + + serveDefinitionsEndpoint relativePath rawHqns renderWidth suff = do + root <- resolveProjectRootHash codebase projectAndBranchName + setCacheControl <$> serveDefinitions rt codebase (Right root) relativePath rawHqns renderWidth suff + + serveFuzzyFindEndpoint relativePath limit renderWidth query = do + root <- resolveProjectRootHash codebase projectAndBranchName + setCacheControl <$> serveFuzzyFind codebase (Right root) relativePath limit renderWidth query + + serveTermSummaryEndpoint shortHash mayName relativeTo renderWidth = do + root <- resolveProjectRootHash codebase projectAndBranchName + setCacheControl <$> serveTermSummary codebase shortHash mayName (Right root) relativeTo renderWidth + + serveTypeSummaryEndpoint shortHash mayName relativeTo renderWidth = do + root <- resolveProjectRootHash codebase projectAndBranchName + setCacheControl <$> serveTypeSummary codebase shortHash mayName (Right root) relativeTo renderWidth + +resolveProjectRoot :: Codebase IO v a -> ProjectAndBranch ProjectName ProjectBranchName -> Backend IO (V2.CausalBranch Sqlite.Transaction) resolveProjectRoot codebase projectAndBranchName@(ProjectAndBranch projectName branchName) = do - mayCH <- liftIO . Codebase.runTransaction codebase $ Backend.causalHashForProjectBranchName @IO projectAndBranchName - case mayCH of + mayCB <- liftIO . Codebase.runTransaction codebase $ Codebase.getShallowProjectRootByNames projectAndBranchName + case mayCB of Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName) - Just ch -> pure ch + Just cb -> pure cb + +resolveProjectRootHash :: Codebase IO v a -> ProjectAndBranch ProjectName ProjectBranchName -> Backend IO CausalHash +resolveProjectRootHash codebase projectAndBranchName = do + resolveProjectRoot codebase projectAndBranchName <&> Causal.causalHash serveProjectDiffTermsEndpoint :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ProjectName -> ProjectBranchName -> ProjectBranchName -> Name -> Name -> Backend IO TermDiffResponse serveProjectDiffTermsEndpoint codebase rt projectName oldBranchRef newBranchRef oldTerm newTerm = do @@ -636,11 +626,11 @@ serveProjectDiffTermsEndpoint codebase rt projectName oldBranchRef newBranchRef where width = Pretty.Width 80 -contextForProjectBranch :: (Codebase IO v a) -> ProjectName -> ProjectBranchName -> Backend IO (PrettyPrintEnvDecl, NameSearch Sqlite.Transaction) +contextForProjectBranch :: Codebase IO v a -> ProjectName -> ProjectBranchName -> Backend IO (PrettyPrintEnvDecl, NameSearch Sqlite.Transaction) contextForProjectBranch codebase projectName branchName = do - projectRootHash <- resolveProjectRoot codebase (ProjectAndBranch projectName branchName) + projectRootHash <- resolveProjectRootHash codebase (ProjectAndBranch projectName branchName) projectRootBranch <- liftIO $ Codebase.expectBranchForHash codebase projectRootHash - hashLength <- liftIO $ Codebase.runTransaction codebase $ Codebase.hashLength + hashLength <- liftIO $ Codebase.runTransaction codebase Codebase.hashLength let names = Branch.toNames (Branch.head projectRootBranch) let pped = PPED.makePPED (PPE.hqNamer hashLength names) (PPE.suffixifyByHash names) let nameSearch = Names.makeNameSearch hashLength names @@ -684,7 +674,7 @@ serveUnisonLocal :: Server UnisonLocalAPI serveUnisonLocal env codebase rt = hoistServer (Proxy @UnisonLocalAPI) (backendHandler env) $ - serveProjectsAPI codebase rt :<|> serveLooseCode codebase rt :<|> (setCacheControl <$> ucmServer codebase) + serveProjectsAPI codebase rt :<|> (setCacheControl <$> ucmServer codebase) backendHandler :: BackendEnv -> Backend IO a -> Handler a backendHandler env m = diff --git a/unison-share-api/src/Unison/Server/Doc.hs b/unison-share-api/src/Unison/Server/Doc.hs index cd4c811ad3..7a9ad22ab0 100644 --- a/unison-share-api/src/Unison/Server/Doc.hs +++ b/unison-share-api/src/Unison/Server/Doc.hs @@ -90,7 +90,7 @@ data DocG specialForm | UntitledSection [(DocG specialForm)] | Column [(DocG specialForm)] | Group (DocG specialForm) - deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable) + deriving stock (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) deriving anyclass (ToJSON) deriving instance (ToSchema specialForm) => ToSchema (DocG specialForm) @@ -98,13 +98,13 @@ deriving instance (ToSchema specialForm) => ToSchema (DocG specialForm) type UnisonHash = Text data Ref a = Term a | Type a - deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable) + deriving stock (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) deriving anyclass (ToJSON) instance (ToSchema a) => ToSchema (Ref a) data MediaSource = MediaSource {mediaSourceUrl :: Text, mediaSourceMimeType :: Maybe Text} - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving anyclass (ToJSON, ToSchema) data RenderedSpecialForm @@ -124,7 +124,7 @@ data RenderedSpecialForm | LaTeXInline Text | Svg Text | RenderError (RenderError SyntaxText) - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving anyclass (ToJSON, ToSchema) data EvaluatedSpecialForm v @@ -146,11 +146,11 @@ data EvaluatedSpecialForm v | ELaTeXInline Text | ESvg Text | ERenderError (RenderError (Term v ())) - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) -- `Src folded unfolded` data Src = Src SyntaxText SyntaxText - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving anyclass (ToJSON, ToSchema) -- | Evaluate the doc, then render it. @@ -333,11 +333,13 @@ evalDoc terms typeOf eval types tm = DD.Doc2SpecialFormExample n (DD.Doc2Example vs body) -> pure $ EExample ex where - ex = Term.lam' (ABT.annotation body) (drop (fromIntegral n) vs) body + annotatedVs = ((),) <$> vs + ex = Term.lam' (ABT.annotation body) (drop (fromIntegral n) annotatedVs) body DD.Doc2SpecialFormExampleBlock n (DD.Doc2Example vs body) -> pure $ EExampleBlock ex where - ex = Term.lam' (ABT.annotation body) (drop (fromIntegral n) vs) body + annotatedVs = ((),) <$> vs + ex = Term.lam' (ABT.annotation body) (drop (fromIntegral n) annotatedVs) body -- Link (Either Link.Type Doc2.Term) DD.Doc2SpecialFormLink e -> @@ -445,7 +447,7 @@ evalDoc terms typeOf eval types tm = data RenderError trm = InvalidTerm trm - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving anyclass (ToJSON) deriving anyclass instance (ToSchema trm) => ToSchema (RenderError trm) @@ -453,20 +455,20 @@ deriving anyclass instance (ToSchema trm) => ToSchema (RenderError trm) data EvaluatedSrc v = EvaluatedSrcDecl (EvaluatedDecl v) | EvaluatedSrcTerm (EvaluatedTerm v) - deriving stock (Show, Eq, Generic) + deriving stock (Show, Ord, Eq, Generic) data EvaluatedDecl v = MissingDecl Reference | BuiltinDecl Reference | FoundDecl Reference (DD.Decl v ()) - deriving stock (Show, Eq, Generic) + deriving stock (Show, Ord, Eq, Generic) data EvaluatedTerm v = MissingTerm Reference | BuiltinTypeSig Reference (Type v ()) | MissingBuiltinTypeSig Reference | FoundTerm Reference (Type v ()) (Term v ()) - deriving stock (Show, Eq, Generic) + deriving stock (Show, Eq, Ord, Generic) -- Determines all dependencies which will be required to render a doc. dependencies :: (Ord v) => EvaluatedDoc v -> Set LD.LabeledDependency diff --git a/unison-share-api/src/Unison/Server/Local.hs b/unison-share-api/src/Unison/Server/Local.hs index f5c3525f46..04a6d9f411 100644 --- a/unison-share-api/src/Unison/Server/Local.hs +++ b/unison-share-api/src/Unison/Server/Local.hs @@ -41,11 +41,11 @@ relocateToNameRoot perspective query rootBranch = do -- Since the project root is lower down we need to strip the part of the prefix -- which is now redundant. pure . Right $ (projectRoot, query <&> \n -> fromMaybe n $ Path.unprefixName (Path.Absolute remainder) n) - -- The namesRoot is _inside_ of the project containing the query + -- The namesRoot is _inside (or equal to)_ the project containing the query (_sharedPrefix, remainder, Path.Empty) -> do -- Since the project is higher up, we need to prefix the query -- with the remainder of the path - pure $ Right (projectRoot, query <&> Path.prefixNameIfRel (Path.AbsolutePath' $ Path.Absolute remainder)) + pure $ Right (projectRoot, query <&> Path.prefixNameIfRel (Path.RelativePath' $ Path.Relative remainder)) -- The namesRoot and project root are disjoint, this shouldn't ever happen. (_, _, _) -> pure $ Left (DisjointProjectAndPerspective perspective projectRoot) diff --git a/unison-share-api/src/Unison/Server/Local/Definitions.hs b/unison-share-api/src/Unison/Server/Local/Definitions.hs index b1f5b03d52..11a2623154 100644 --- a/unison-share-api/src/Unison/Server/Local/Definitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Definitions.hs @@ -20,7 +20,7 @@ import Unison.Codebase.Path (Path) import Unison.Codebase.Runtime qualified as Rt import Unison.DataDeclaration qualified as DD import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.NamesWithHistory qualified as NS import Unison.NamesWithHistory qualified as Names @@ -81,7 +81,7 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings -- ppe which returns names fully qualified to the current perspective, not to the codebase root. let biases = maybeToList $ HQ.toName query hqLength <- liftIO $ Codebase.runTransaction codebase $ Codebase.hashLength - (localNamesOnly, unbiasedPPED) <- namesAtPathFromRootBranchHash codebase (Just shallowRoot) namesRoot + (localNamesOnly, unbiasedPPED) <- namesAtPathFromRootBranchHash codebase shallowRoot namesRoot let pped = PPED.biasTo biases unbiasedPPED let nameSearch = makeNameSearch hqLength localNamesOnly (DefinitionResults terms types misses) <- liftIO $ Codebase.runTransaction codebase do diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs index 5cc218b7eb..7d082b8149 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs @@ -3,22 +3,16 @@ module Unison.Server.Local.Endpoints.Current where -import Control.Monad.Except import Data.Aeson import Data.OpenApi (ToSchema (..)) import Servant ((:>)) import Servant.Docs (ToSample (..)) -import U.Codebase.Sqlite.DbId -import U.Codebase.Sqlite.Project qualified as Project -import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch -import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path -import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..)) -import Unison.NameSegment (NameSegment) +import Unison.Codebase.ProjectPath qualified as PP +import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.Prelude -import Unison.Project.Util (pattern BranchesNameSegment, pattern ProjectsNameSegment, pattern UUIDNameSegment) import Unison.Server.Backend import Unison.Server.Types (APIGet) @@ -40,7 +34,7 @@ instance ToSample Current where Current (Just $ UnsafeProjectName "@unison/base") (Just $ UnsafeProjectBranchName "main") - (Path.Absolute $ Path.unsafeParseText ".__projects._53393e4b_1f61_467c_a488_b6068c727daa.branches._f0aec0e3_249f_4004_b836_572fea3981c1") + (Path.Absolute $ Path.unsafeParseText "my.path") ) ] @@ -52,31 +46,11 @@ instance ToJSON Current where "path" .= path ] -serveCurrent :: MonadIO m => Codebase m v a -> Backend m Current +serveCurrent :: (MonadIO m) => Codebase m v a -> Backend m Current serveCurrent = lift . getCurrentProjectBranch -getCurrentProjectBranch :: MonadIO m => Codebase m v a -> m Current +getCurrentProjectBranch :: (MonadIO m) => Codebase m v a -> m Current getCurrentProjectBranch codebase = do - segments <- Codebase.runTransaction codebase Queries.expectMostRecentNamespace - let absolutePath = toPath segments - case toIds segments of - ProjectAndBranch (Just projectId) branchId -> - Codebase.runTransaction codebase do - project <- Queries.expectProject projectId - branch <- traverse (Queries.expectProjectBranch projectId) branchId - pure $ Current (Just $ Project.name project) (ProjectBranch.name <$> branch) absolutePath - ProjectAndBranch _ _ -> - pure $ Current Nothing Nothing absolutePath - where - toIds :: [NameSegment] -> ProjectAndBranch (Maybe ProjectId) (Maybe ProjectBranchId) - toIds segments = - case segments of - ProjectsNameSegment : UUIDNameSegment projectId : BranchesNameSegment : UUIDNameSegment branchId : _ -> - ProjectAndBranch {project = Just $ ProjectId projectId, branch = Just $ ProjectBranchId branchId} - ProjectsNameSegment : UUIDNameSegment projectId : _ -> - ProjectAndBranch {project = Just $ ProjectId projectId, branch = Nothing} - _ -> - ProjectAndBranch {project = Nothing, branch = Nothing} - - toPath :: [NameSegment] -> Path.Absolute - toPath = Path.Absolute . Path.fromList + pp <- Codebase.runTransaction codebase Codebase.expectCurrentProjectPath + let (PP.ProjectPath projName branchName path) = PP.toNames pp + pure $ Current (Just projName) (Just branchName) path diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/DefinitionSummary.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/DefinitionSummary.hs index 3de04b5054..93e3648678 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/DefinitionSummary.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/DefinitionSummary.hs @@ -67,7 +67,6 @@ type TermSummaryAPI = -- It's propagated through to the response as-is. -- If missing, the short hash will be used instead. :> QueryParam "name" Name - :> QueryParam "rootBranch" ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParam "renderWidth" Width :> APIGet TermSummary @@ -98,11 +97,11 @@ serveTermSummary :: Codebase IO Symbol Ann -> Referent -> Maybe Name -> - Maybe (Either ShortCausalHash CausalHash) -> + Either ShortCausalHash CausalHash -> Maybe Path.Path -> Maybe Width -> Backend IO TermSummary -serveTermSummary codebase referent mayName mayRoot relativeTo mayWidth = do +serveTermSummary codebase referent mayName root relativeTo mayWidth = do let shortHash = Referent.toShortHash referent let displayName = maybe (HQ.HashOnly shortHash) HQ.NameOnly mayName let relativeToPath = fromMaybe Path.empty relativeTo @@ -111,7 +110,7 @@ serveTermSummary codebase referent mayName mayRoot relativeTo mayWidth = do (root, sig) <- Backend.hoistBackend (Codebase.runTransaction codebase) do - root <- Backend.normaliseRootCausalHash mayRoot + root <- Backend.normaliseRootCausalHash root sig <- lift (Backend.loadReferentType codebase referent) pure (root, sig) case sig of @@ -126,7 +125,7 @@ serveTermSummary codebase referent mayName mayRoot relativeTo mayWidth = do namesPerspective <- Ops.namesPerspectiveForRootAndPath (V2Causal.valueHash root) (coerce . Path.toList $ fromMaybe Path.Empty relativeTo) PPESqlite.ppedForReferences namesPerspective deps False -> do - (_localNames, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just root) relativeToPath + (_localNames, ppe) <- Backend.namesAtPathFromRootBranchHash codebase root relativeToPath pure ppe let formattedTermSig = Backend.formatSuffixedType ppe width typeSig let summary = mkSummary termReference formattedTermSig @@ -150,7 +149,6 @@ type TypeSummaryAPI = -- It's propagated through to the response as-is. -- If missing, the short hash will be used instead. :> QueryParam "name" Name - :> QueryParam "rootBranch" ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParam "renderWidth" Width :> APIGet TypeSummary @@ -181,7 +179,7 @@ serveTypeSummary :: Codebase IO Symbol Ann -> Reference -> Maybe Name -> - Maybe (Either ShortCausalHash CausalHash) -> + Either ShortCausalHash CausalHash -> Maybe Path.Path -> Maybe Width -> Backend IO TypeSummary diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs index 5aaa434463..cb05dc5d50 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs @@ -4,7 +4,6 @@ module Unison.Server.Local.Endpoints.FuzzyFind where -import Control.Monad.Except import Data.Aeson import Data.OpenApi (ToSchema) import Servant @@ -47,7 +46,6 @@ import Unison.Util.Pretty (Width) type FuzzyFindAPI = "find" - :> QueryParam "rootBranch" SCH.ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParam "limit" Int :> QueryParam "renderWidth" Width @@ -142,18 +140,18 @@ serveFuzzyFind :: forall m. (MonadIO m) => Codebase m Symbol Ann -> - Maybe (Either SCH.ShortCausalHash CausalHash) -> + Either SCH.ShortCausalHash CausalHash -> Maybe Path.Path -> Maybe Int -> Maybe Width -> Maybe String -> Backend.Backend m [(FZF.Alignment, FoundResult)] -serveFuzzyFind codebase mayRoot relativeTo limit typeWidth query = do +serveFuzzyFind codebase root relativeTo limit typeWidth query = do let path = fromMaybe Path.empty relativeTo rootCausal <- Backend.hoistBackend (Codebase.runTransaction codebase) do - Backend.normaliseRootCausalHash mayRoot - (localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just rootCausal) path + Backend.normaliseRootCausalHash root + (localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase rootCausal path let alignments :: ( [ ( FZF.Alignment, UnisonName, diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/GetDefinitions.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/GetDefinitions.hs index 49a67357ea..86cb6288d6 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/GetDefinitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/GetDefinitions.hs @@ -44,7 +44,6 @@ import Unison.Util.Pretty (Width) type DefinitionsAPI = "getDefinition" - :> QueryParam "rootBranch" ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParams "names" (HQ.HashQualified Name) :> QueryParam "renderWidth" Width @@ -96,16 +95,6 @@ instance ToParam (QueryParam "namespace" Path.Path) where ) Normal -instance ToParam (QueryParam "rootBranch" ShortCausalHash) where - toParam _ = - DocQueryParam - "rootBranch" - ["#abc123"] - ( "The hash or hash prefix of the namespace root. " - <> "If left absent, the most recent root will be used." - ) - Normal - instance ToParam (QueryParams "names" (HQ.HashQualified Name)) where toParam _ = DocQueryParam @@ -120,15 +109,15 @@ instance ToSample DefinitionDisplayResults where serveDefinitions :: Rt.Runtime Symbol -> Codebase IO Symbol Ann -> - Maybe (Either ShortCausalHash CausalHash) -> + Either ShortCausalHash CausalHash -> Maybe Path.Path -> [HQ.HashQualified Name] -> Maybe Width -> Maybe Suffixify -> Backend.Backend IO DefinitionDisplayResults -serveDefinitions rt codebase mayRoot relativePath hqns width suff = +serveDefinitions rt codebase root relativePath hqns width suff = do - rootCausalHash <- Backend.hoistBackend (Codebase.runTransaction codebase) . Backend.normaliseRootCausalHash $ mayRoot + rootCausalHash <- Backend.hoistBackend (Codebase.runTransaction codebase) . Backend.normaliseRootCausalHash $ root hqns & foldMapM ( Local.prettyDefinitionsForHQName diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs index bcb6ca5fa1..c0e2d94841 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs @@ -4,7 +4,6 @@ module Unison.Server.Local.Endpoints.NamespaceDetails where -import Control.Monad.Except import Data.Set qualified as Set import Servant (Capture, QueryParam, (:>)) import Servant.Docs (DocCapture (..), ToCapture (..)) @@ -33,7 +32,6 @@ import Unison.Util.Pretty (Width) type NamespaceDetailsAPI = "namespaces" :> Capture "namespace" Path.Path - :> QueryParam "rootBranch" ShortCausalHash :> QueryParam "renderWidth" Width :> APIGet NamespaceDetails @@ -47,23 +45,21 @@ namespaceDetails :: Rt.Runtime Symbol -> Codebase IO Symbol Ann -> Path.Path -> - Maybe (Either ShortCausalHash CausalHash) -> + Either ShortCausalHash CausalHash -> Maybe Width -> Backend IO NamespaceDetails -namespaceDetails runtime codebase namespacePath mayRoot _mayWidth = do +namespaceDetails runtime codebase namespacePath root _mayWidth = do (rootCausal, namespaceCausal, shallowBranch) <- Backend.hoistBackend (Codebase.runTransaction codebase) do rootCausalHash <- - case mayRoot of - Nothing -> Backend.resolveRootBranchHashV2 Nothing - Just (Left sch) -> Backend.resolveRootBranchHashV2 (Just sch) - Just (Right ch) -> lift $ Backend.resolveCausalHashV2 (Just ch) - -- lift (Backend.resolveCausalHashV2 rootCausalHash) - namespaceCausal <- lift $ Codebase.getShallowCausalAtPath namespacePath (Just rootCausalHash) + case root of + (Left sch) -> Backend.resolveRootBranchHashV2 sch + (Right ch) -> lift $ Codebase.expectCausalBranchByCausalHash ch + namespaceCausal <- lift $ Codebase.getShallowCausalAtPath namespacePath rootCausalHash shallowBranch <- lift $ V2Causal.value namespaceCausal pure (rootCausalHash, namespaceCausal, shallowBranch) namespaceDetails <- do - (_localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just rootCausal) namespacePath + (_localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase rootCausal namespacePath let mayReadmeRef = Backend.findDocInBranch readmeNames shallowBranch renderedReadme <- for mayReadmeRef \readmeRef -> do -- Local server currently ignores eval errors. diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs index fe5e5ee06a..c60357548d 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs @@ -4,7 +4,6 @@ module Unison.Server.Local.Endpoints.NamespaceListing (serve, NamespaceListingAPI, NamespaceListing (..), NamespaceObject (..), NamedNamespace (..), NamedPatch (..), KindExpression (..)) where -import Control.Monad.Except import Data.Aeson import Data.OpenApi (ToSchema) import Servant @@ -47,7 +46,6 @@ import Unison.Var (Var) type NamespaceListingAPI = "list" - :> QueryParam "rootBranch" ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParam "namespace" Path.Path :> APIGet NamespaceListing @@ -192,12 +190,12 @@ backendListEntryToNamespaceObject ppe typeWidth = \case serve :: Codebase IO Symbol Ann -> - Maybe (Either ShortCausalHash CausalHash) -> + Either ShortCausalHash CausalHash -> Maybe Path.Path -> Maybe Path.Path -> Backend.Backend IO NamespaceListing -serve codebase maySCH mayRelativeTo mayNamespaceName = do - rootCausal <- Backend.hoistBackend (Codebase.runTransaction codebase) $ Backend.normaliseRootCausalHash maySCH +serve codebase root mayRelativeTo mayNamespaceName = do + rootCausal <- Backend.hoistBackend (Codebase.runTransaction codebase) $ Backend.normaliseRootCausalHash root -- Relative and Listing Path resolution -- @@ -217,7 +215,7 @@ serve codebase maySCH mayRelativeTo mayNamespaceName = do let path = relativeToPath <> namespacePath (listingCausal, listingBranch) <- (lift . Codebase.runTransaction codebase) do - listingCausal <- Codebase.getShallowCausalAtPath path (Just rootCausal) + listingCausal <- Codebase.getShallowCausalAtPath path rootCausal listingBranch <- V2Causal.value listingCausal pure (listingCausal, listingBranch) -- TODO: Currently the ppe is just used to render the types returned from the namespace diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/UCM.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/UCM.hs index d657a23e13..09ed27a12b 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/UCM.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/UCM.hs @@ -11,5 +11,5 @@ import Unison.Server.Local.Endpoints.Current (Current, CurrentEndpoint, serveCur type UCMAPI = CurrentEndpoint -ucmServer :: MonadIO m => Codebase m v a -> Backend m Current +ucmServer :: (MonadIO m) => Codebase m v a -> Backend m Current ucmServer codebase = serveCurrent codebase diff --git a/unison-share-api/src/Unison/Server/NameSearch.hs b/unison-share-api/src/Unison/Server/NameSearch.hs index 2336d3241b..5e61cd8c30 100644 --- a/unison-share-api/src/Unison/Server/NameSearch.hs +++ b/unison-share-api/src/Unison/Server/NameSearch.hs @@ -12,7 +12,7 @@ import Control.Lens import Data.List qualified as List import Data.Set qualified as Set import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.NamesWithHistory (SearchType (..)) import Unison.Prelude diff --git a/unison-share-api/src/Unison/Server/NameSearch/FromNames.hs b/unison-share-api/src/Unison/Server/NameSearch/FromNames.hs index a78fc6f6f8..40a4ad4d29 100644 --- a/unison-share-api/src/Unison/Server/NameSearch/FromNames.hs +++ b/unison-share-api/src/Unison/Server/NameSearch/FromNames.hs @@ -1,6 +1,6 @@ module Unison.Server.NameSearch.FromNames where -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Names (Names) import Unison.NamesWithHistory qualified as Names import Unison.Reference (Reference) diff --git a/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs b/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs index 527c8bd634..8095d5bdce 100644 --- a/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs +++ b/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs @@ -17,7 +17,7 @@ import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.LabeledDependency qualified as LD import Unison.Name (Name) import Unison.Name qualified as Name diff --git a/unison-share-api/src/Unison/Server/Orphans.hs b/unison-share-api/src/Unison/Server/Orphans.hs index 7451d2f183..bab2d26fef 100644 --- a/unison-share-api/src/Unison/Server/Orphans.hs +++ b/unison-share-api/src/Unison/Server/Orphans.hs @@ -26,7 +26,7 @@ import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.Hash (Hash (..)) import Unison.Hash qualified as Hash import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment.Internal (NameSegment (NameSegment)) @@ -37,7 +37,7 @@ import Unison.Referent qualified as Referent import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as SH import Unison.Syntax.HashQualified qualified as HQ (parseText) -import Unison.Syntax.HashQualified' qualified as HQ' (parseText) +import Unison.Syntax.HashQualifiedPrime qualified as HQ' (parseText) import Unison.Syntax.Name qualified as Name (parseTextEither, toText) import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.Pretty (Width (..)) @@ -155,6 +155,15 @@ instance (ToJSON b, ToJSON a) => ToJSON (DisplayObject b a) where MissingObject sh -> object ["tag" Aeson..= String "MissingObject", "contents" Aeson..= sh] UserObject a -> object ["tag" Aeson..= String "UserObject", "contents" Aeson..= a] +instance (FromJSON a, FromJSON b) => FromJSON (DisplayObject b a) where + parseJSON = withObject "DisplayObject" \o -> do + tag <- o .: "tag" + case tag of + "BuiltinObject" -> BuiltinObject <$> o .: "contents" + "MissingObject" -> MissingObject <$> o .: "contents" + "UserObject" -> UserObject <$> o .: "contents" + _ -> fail $ "Invalid tag: " <> Text.unpack tag + deriving instance (ToSchema b, ToSchema a) => ToSchema (DisplayObject b a) -- [21/10/07] Hello, this is Mitchell. Name refactor in progress. Changing internal representation from a flat text to a diff --git a/unison-share-api/src/Unison/Server/SearchResult'.hs b/unison-share-api/src/Unison/Server/SearchResult'.hs deleted file mode 100644 index d928811ed5..0000000000 --- a/unison-share-api/src/Unison/Server/SearchResult'.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Unison.Server.SearchResult' where - -import Data.Set qualified as Set -import Unison.Codebase.Editor.DisplayObject (DisplayObject) -import Unison.Codebase.Editor.DisplayObject qualified as DT -import Unison.DataDeclaration (Decl) -import Unison.DataDeclaration qualified as DD -import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' -import Unison.LabeledDependency (LabeledDependency) -import Unison.LabeledDependency qualified as LD -import Unison.Name (Name) -import Unison.Prelude -import Unison.Reference (Reference) -import Unison.Referent (Referent) -import Unison.Type (Type) -import Unison.Type qualified as Type - -data SearchResult' v a - = Tm' (TermResult' v a) - | Tp' (TypeResult' v a) - deriving (Eq, Show) - -data TermResult' v a - = TermResult' - (HQ.HashQualified Name) - (Maybe (Type v a)) - Referent - (Set (HQ'.HashQualified Name)) - deriving (Eq, Show) - -data TypeResult' v a - = TypeResult' - (HQ.HashQualified Name) - (DisplayObject () (Decl v a)) - Reference - (Set (HQ'.HashQualified Name)) - deriving (Eq, Show) - -pattern Tm :: - HQ.HashQualified Name -> - Maybe (Type v a) -> - Referent -> - Set (HQ'.HashQualified Name) -> - SearchResult' v a -pattern Tm n t r as = Tm' (TermResult' n t r as) - -pattern Tp :: - HQ.HashQualified Name -> - DisplayObject () (Decl v a) -> - Reference -> - Set (HQ'.HashQualified Name) -> - SearchResult' v a -pattern Tp n t r as = Tp' (TypeResult' n t r as) - -tmReferent :: SearchResult' v a -> Maybe Referent -tmReferent = \case Tm _ _ r _ -> Just r; _ -> Nothing - -tpReference :: SearchResult' v a -> Maybe Reference -tpReference = \case Tp _ _ r _ -> Just r; _ -> Nothing - -foldResult' :: (TermResult' v a -> b) -> (TypeResult' v a -> b) -> SearchResult' v a -> b -foldResult' f g = \case - Tm' tm -> f tm - Tp' tp -> g tp - --- todo: comment me out, is this actually useful, given what we saw in ShowDefinitionI? --- namely, that it doesn't include the Term's deps, just the Decl's and the --- result Term/Type names. -labeledDependencies :: (Ord v) => SearchResult' v a -> Set LabeledDependency -labeledDependencies = \case - Tm' (TermResult' _ t r _) -> - Set.insert (LD.referent r) $ maybe mempty (Set.map LD.typeRef . Type.dependencies) t - Tp' (TypeResult' _ d r _) -> - maybe mempty (DD.labeledDeclDependenciesIncludingSelf r) (DT.toMaybe d) diff --git a/unison-share-api/src/Unison/Server/SearchResult.hs b/unison-share-api/src/Unison/Server/SearchResult.hs index c30c16634a..9dd8d09046 100644 --- a/unison-share-api/src/Unison/Server/SearchResult.hs +++ b/unison-share-api/src/Unison/Server/SearchResult.hs @@ -2,7 +2,7 @@ module Unison.Server.SearchResult where import Data.Set qualified as Set import Unison.HashQualified (HashQualified) -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.Names (Names (..)) diff --git a/unison-share-api/src/Unison/Server/SearchResultPrime.hs b/unison-share-api/src/Unison/Server/SearchResultPrime.hs new file mode 100644 index 0000000000..b24c9f2c8a --- /dev/null +++ b/unison-share-api/src/Unison/Server/SearchResultPrime.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Server.SearchResultPrime where + +import Data.Set qualified as Set +import Unison.Codebase.Editor.DisplayObject (DisplayObject) +import Unison.Codebase.Editor.DisplayObject qualified as DT +import Unison.DataDeclaration (Decl) +import Unison.DataDeclaration qualified as DD +import Unison.HashQualified qualified as HQ +import Unison.HashQualifiedPrime qualified as HQ' +import Unison.LabeledDependency (LabeledDependency) +import Unison.LabeledDependency qualified as LD +import Unison.Name (Name) +import Unison.Prelude +import Unison.Reference (Reference) +import Unison.Referent (Referent) +import Unison.Type (Type) +import Unison.Type qualified as Type + +data SearchResult' v a + = Tm' (TermResult' v a) + | Tp' (TypeResult' v a) + deriving (Eq, Show) + +data TermResult' v a + = TermResult' + (HQ.HashQualified Name) + (Maybe (Type v a)) + Referent + (Set (HQ'.HashQualified Name)) + deriving (Eq, Show) + +data TypeResult' v a + = TypeResult' + (HQ.HashQualified Name) + (DisplayObject () (Decl v a)) + Reference + (Set (HQ'.HashQualified Name)) + deriving (Eq, Show) + +pattern Tm :: + HQ.HashQualified Name -> + Maybe (Type v a) -> + Referent -> + Set (HQ'.HashQualified Name) -> + SearchResult' v a +pattern Tm n t r as = Tm' (TermResult' n t r as) + +pattern Tp :: + HQ.HashQualified Name -> + DisplayObject () (Decl v a) -> + Reference -> + Set (HQ'.HashQualified Name) -> + SearchResult' v a +pattern Tp n t r as = Tp' (TypeResult' n t r as) + +tmReferent :: SearchResult' v a -> Maybe Referent +tmReferent = \case Tm _ _ r _ -> Just r; _ -> Nothing + +tpReference :: SearchResult' v a -> Maybe Reference +tpReference = \case Tp _ _ r _ -> Just r; _ -> Nothing + +foldResult' :: (TermResult' v a -> b) -> (TypeResult' v a -> b) -> SearchResult' v a -> b +foldResult' f g = \case + Tm' tm -> f tm + Tp' tp -> g tp + +-- todo: comment me out, is this actually useful, given what we saw in ShowDefinitionI? +-- namely, that it doesn't include the Term's deps, just the Decl's and the +-- result Term/Type names. +labeledDependencies :: (Ord v) => SearchResult' v a -> Set LabeledDependency +labeledDependencies = \case + Tm' (TermResult' _ t r _) -> + Set.insert (LD.referent r) $ maybe mempty (Set.map LD.typeRef . Type.dependencies) t + Tp' (TypeResult' _ d r _) -> + maybe mempty (DD.labeledDeclDependenciesIncludingSelf r) (DT.toMaybe d) diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 48f9ace2bc..21799f4337 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -20,6 +20,7 @@ import Data.OpenApi.Lens qualified as OpenApi import Data.Text qualified as Text import Data.Text.Lazy qualified as Text.Lazy import Data.Text.Lazy.Encoding qualified as Text +import Servant qualified import Servant.API ( Capture, FromHttpApiData (..), @@ -41,7 +42,7 @@ import Unison.Codebase.Path qualified as Path import Unison.Core.Project (ProjectBranchName) import Unison.Hash qualified as Hash import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Prelude import Unison.Project (ProjectAndBranch, ProjectName) @@ -104,7 +105,7 @@ data ExactName name ref = ExactName { name :: name, ref :: ref } - deriving stock (Show, Eq, Ord) + deriving stock (Show, Eq, Functor, Ord) instance ToParamSchema (ExactName Name ShortHash) where toParamSchema _ = @@ -197,14 +198,14 @@ data TermDefinitionDiff = TermDefinitionDiff right :: TermDefinition, diff :: DisplayObjectDiff } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) data TypeDefinitionDiff = TypeDefinitionDiff { left :: TypeDefinition, right :: TypeDefinition, diff :: DisplayObjectDiff } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) newtype Suffixify = Suffixify {suffixified :: Bool} deriving (Eq, Ord, Show, Generic) @@ -217,7 +218,7 @@ data TermDefinition = TermDefinition signature :: Syntax.SyntaxText, termDocs :: [(HashQualifiedName, UnisonHash, Doc)] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Ord, Generic) data TypeDefinition = TypeDefinition { typeNames :: [HashQualifiedName], @@ -226,14 +227,14 @@ data TypeDefinition = TypeDefinition typeDefinition :: DisplayObject Syntax.SyntaxText Syntax.SyntaxText, typeDocs :: [(HashQualifiedName, UnisonHash, Doc)] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Ord, Generic) data DefinitionDisplayResults = DefinitionDisplayResults { termDefinitions :: Map UnisonHash TermDefinition, typeDefinitions :: Map UnisonHash TypeDefinition, missingDefinitions :: [HashQualifiedName] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Ord, Generic) instance Semigroup DefinitionDisplayResults where DefinitionDisplayResults terms1 types1 missing1 <> DefinitionDisplayResults terms2 types2 missing2 = @@ -259,7 +260,7 @@ data SemanticSyntaxDiff SegmentChange (String, String) (Maybe Syntax.Element) | -- (shared segment) (fromAnnotation, toAnnotation) AnnotationChange String (Maybe Syntax.Element, Maybe Syntax.Element) - deriving (Eq, Show, Generic) + deriving (Eq, Show, Ord, Generic) deriving instance ToSchema SemanticSyntaxDiff @@ -302,7 +303,7 @@ instance ToJSON SemanticSyntaxDiff where data DisplayObjectDiff = DisplayObjectDiff (DisplayObject [SemanticSyntaxDiff] [SemanticSyntaxDiff]) | MismatchedDisplayObjects (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) - deriving stock (Show, Eq, Generic) + deriving stock (Show, Eq, Ord, Generic) deriving instance ToSchema DisplayObjectDiff @@ -323,7 +324,7 @@ data NamedTerm = NamedTerm termType :: Maybe Syntax.SyntaxText, termTag :: TermTag } - deriving (Eq, Generic, Show) + deriving (Eq, Ord, Generic, Show) instance ToJSON NamedTerm where toJSON (NamedTerm n h typ tag) = @@ -349,7 +350,7 @@ data NamedType = NamedType typeHash :: ShortHash, typeTag :: TypeTag } - deriving (Eq, Generic, Show) + deriving (Eq, Ord, Generic, Show) instance ToJSON NamedType where toJSON (NamedType n h tag) = @@ -473,7 +474,7 @@ data TermDiffResponse = TermDiffResponse newTerm :: TermDefinition, diff :: DisplayObjectDiff } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) deriving instance ToSchema TermDiffResponse @@ -511,7 +512,7 @@ data TypeDiffResponse = TypeDiffResponse newType :: TypeDefinition, diff :: DisplayObjectDiff } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) deriving instance ToSchema TypeDiffResponse @@ -540,3 +541,6 @@ instance ToJSON TypeDiffResponse where "oldType" .= oldType, "newType" .= newType ] + +-- | Servant utility for a query param that's required, providing a useful error message if it's missing. +type RequiredQueryParam = Servant.QueryParam' '[Servant.Required, Servant.Strict] diff --git a/unison-share-api/src/Unison/Sync/API.hs b/unison-share-api/src/Unison/Sync/API.hs index 754931f8b1..5cafebdfc3 100644 --- a/unison-share-api/src/Unison/Sync/API.hs +++ b/unison-share-api/src/Unison/Sync/API.hs @@ -11,8 +11,6 @@ api = Proxy type API = "path" :> "get" :> GetCausalHashByPathEndpoint - :<|> "path" :> "fast-forward" :> FastForwardPathEndpoint - :<|> "path" :> "update" :> UpdatePathEndpoint :<|> "entities" :> "download" :> DownloadEntitiesEndpoint :<|> "entities" :> "upload" :> UploadEntitiesEndpoint @@ -20,14 +18,6 @@ type GetCausalHashByPathEndpoint = ReqBody '[JSON] GetCausalHashByPathRequest :> Post '[JSON] GetCausalHashByPathResponse -type FastForwardPathEndpoint = - ReqBody '[JSON] FastForwardPathRequest - :> Post '[JSON] FastForwardPathResponse - -type UpdatePathEndpoint = - ReqBody '[JSON] UpdatePathRequest - :> Post '[JSON] UpdatePathResponse - type DownloadEntitiesEndpoint = ReqBody '[JSON] DownloadEntitiesRequest :> Post '[JSON] DownloadEntitiesResponse diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index ccd680135f..35d7030cc8 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -48,17 +48,6 @@ module Unison.Sync.Types UploadEntitiesResponse (..), UploadEntitiesError (..), - -- ** Fast-forward path - FastForwardPathRequest (..), - FastForwardPathResponse (..), - FastForwardPathError (..), - - -- ** Update path - UpdatePathRequest (..), - UpdatePathResponse (..), - UpdatePathError (..), - HashMismatch (..), - -- * Common/shared error types HashMismatchForEntity (..), InvalidParentage (..), @@ -203,7 +192,7 @@ entityDependencies = \case C Causal {namespaceHash, parents} -> Set.insert namespaceHash parents data TermComponent text hash = TermComponent [(LocalIds text hash, ByteString)] - deriving stock (Show, Eq, Ord) + deriving stock (Show, Eq, Functor, Ord) instance Bifoldable TermComponent where bifoldMap = bifoldMapDefault @@ -252,7 +241,7 @@ decodeComponentPiece = Aeson.withObject "Component Piece" \obj -> do pure (localIDs, bytes) data DeclComponent text hash = DeclComponent [(LocalIds text hash, ByteString)] - deriving stock (Show, Eq, Ord) + deriving stock (Show, Eq, Functor, Ord) instance Bifoldable DeclComponent where bifoldMap = bifoldMapDefault @@ -280,7 +269,7 @@ data LocalIds text hash = LocalIds { texts :: [text], hashes :: [hash] } - deriving stock (Show, Eq, Ord) + deriving stock (Show, Eq, Functor, Ord) instance Bifoldable LocalIds where bifoldMap = bifoldMapDefault @@ -381,7 +370,7 @@ data Namespace text hash = Namespace childLookup :: [(hash, hash)], -- (namespace hash, causal hash) bytes :: LocalBranchBytes } - deriving stock (Eq, Ord, Show) + deriving stock (Eq, Functor, Ord, Show) instance Bifoldable Namespace where bifoldMap = bifoldMapDefault @@ -751,111 +740,9 @@ instance FromJSON HashMismatchForEntity where <*> obj .: "computed" ------------------------------------------------------------------------------------------------------------------------- --- Fast-forward path - --- | A non-empty list of causal hashes, latest first, that show the lineage from wherever the client wants to --- fast-forward to back to wherever the (client believes the) server is (including the server head, in a separate --- field). --- --- For example, if the client wants to update --- --- @ --- A -> B -> C --- @ --- --- to --- --- @ --- A -> B -> C -> D -> E -> F --- @ --- --- then it would send hashes --- --- @ --- expectedHash = C --- hashes = [D, E, F] --- @ --- --- Note that if the client wants to begin a history at a new path on the server, it would use the "update path" endpoint --- instead. -data FastForwardPathRequest = FastForwardPathRequest - { -- | The causal that the client believes exists at `path` - expectedHash :: Hash32, - -- | The sequence of causals to fast-forward with, starting from the oldest new causal to the newest new causal - hashes :: NonEmpty Hash32, - -- | The path to fast-forward - path :: Path - } - deriving stock (Show) - -instance ToJSON FastForwardPathRequest where - toJSON FastForwardPathRequest {expectedHash, hashes, path} = - object - [ "expected_hash" .= expectedHash, - "hashes" .= hashes, - "path" .= path - ] - -instance FromJSON FastForwardPathRequest where - parseJSON = - Aeson.withObject "FastForwardPathRequest" \o -> do - expectedHash <- o .: "expected_hash" - hashes <- o .: "hashes" - path <- o .: "path" - pure FastForwardPathRequest {expectedHash, hashes, path} - -data FastForwardPathResponse - = FastForwardPathSuccess - | FastForwardPathFailure FastForwardPathError - deriving stock (Show) - -data FastForwardPathError - = FastForwardPathError'MissingDependencies (NeedDependencies Hash32) - | FastForwardPathError'NoWritePermission Path - | -- | This wasn't a fast-forward. Here's a JWT to download the causal head, if you want it. - FastForwardPathError'NotFastForward HashJWT - | -- | There was no history at this path; the client should use the "update path" endpoint instead. - FastForwardPathError'NoHistory - | -- | This wasn't a fast-forward. You said the first hash was a parent of the second hash, but I disagree. - FastForwardPathError'InvalidParentage InvalidParentage - | FastForwardPathError'InvalidRepoInfo Text RepoInfo - | FastForwardPathError'UserNotFound - deriving stock (Show) - data InvalidParentage = InvalidParentage {parent :: Hash32, child :: Hash32} deriving stock (Show) -instance ToJSON FastForwardPathResponse where - toJSON = \case - FastForwardPathSuccess -> jsonUnion "success" (Object mempty) - (FastForwardPathFailure (FastForwardPathError'MissingDependencies deps)) -> jsonUnion "missing_dependencies" deps - (FastForwardPathFailure (FastForwardPathError'NoWritePermission path)) -> jsonUnion "no_write_permission" path - (FastForwardPathFailure (FastForwardPathError'NotFastForward hashJwt)) -> jsonUnion "not_fast_forward" hashJwt - (FastForwardPathFailure FastForwardPathError'NoHistory) -> jsonUnion "no_history" (Object mempty) - (FastForwardPathFailure (FastForwardPathError'InvalidParentage invalidParentage)) -> - jsonUnion "invalid_parentage" invalidParentage - (FastForwardPathFailure (FastForwardPathError'InvalidRepoInfo msg repoInfo)) -> - jsonUnion "invalid_repo_info" (msg, repoInfo) - (FastForwardPathFailure FastForwardPathError'UserNotFound) -> - jsonUnion "user_not_found" (Object mempty) - -instance FromJSON FastForwardPathResponse where - parseJSON = - Aeson.withObject "FastForwardPathResponse" \o -> - o .: "type" >>= Aeson.withText "type" \case - "success" -> pure FastForwardPathSuccess - "missing_dependencies" -> FastForwardPathFailure . FastForwardPathError'MissingDependencies <$> o .: "payload" - "no_write_permission" -> FastForwardPathFailure . FastForwardPathError'NoWritePermission <$> o .: "payload" - "not_fast_forward" -> FastForwardPathFailure . FastForwardPathError'NotFastForward <$> o .: "payload" - "no_history" -> pure (FastForwardPathFailure FastForwardPathError'NoHistory) - "invalid_parentage" -> FastForwardPathFailure . FastForwardPathError'InvalidParentage <$> o .: "payload" - "invalid_repo_info" -> do - (msg, repoInfo) <- o .: "payload" - pure (FastForwardPathFailure (FastForwardPathError'InvalidRepoInfo msg repoInfo)) - "user_not_found" -> pure (FastForwardPathFailure FastForwardPathError'UserNotFound) - t -> failText $ "Unexpected FastForwardPathResponse type: " <> t - instance ToJSON InvalidParentage where toJSON (InvalidParentage parent child) = object ["parent" .= parent, "child" .= child] @@ -863,89 +750,6 @@ instance FromJSON InvalidParentage where parseJSON = Aeson.withObject "InvalidParentage" \o -> InvalidParentage <$> o .: "parent" <*> o .: "child" ------------------------------------------------------------------------------------------------------------------------- --- Update path - -data UpdatePathRequest = UpdatePathRequest - { path :: Path, - expectedHash :: Maybe Hash32, -- Nothing requires empty history at destination - newHash :: Hash32 - } - deriving stock (Show, Eq, Ord) - -instance ToJSON UpdatePathRequest where - toJSON (UpdatePathRequest path expectedHash newHash) = - object - [ "path" .= path, - "expected_hash" .= expectedHash, - "new_hash" .= newHash - ] - -instance FromJSON UpdatePathRequest where - parseJSON = Aeson.withObject "UpdatePathRequest" \obj -> do - path <- obj .: "path" - expectedHash <- obj .: "expected_hash" - newHash <- obj .: "new_hash" - pure UpdatePathRequest {..} - -data UpdatePathResponse - = UpdatePathSuccess - | UpdatePathFailure UpdatePathError - deriving stock (Show, Eq, Ord) - -data UpdatePathError - = UpdatePathError'HashMismatch HashMismatch - | UpdatePathError'InvalidRepoInfo Text RepoInfo -- err msg, repo info - | UpdatePathError'MissingDependencies (NeedDependencies Hash32) - | UpdatePathError'NoWritePermission Path - | UpdatePathError'UserNotFound - deriving stock (Show, Eq, Ord) - -instance ToJSON UpdatePathResponse where - toJSON = \case - UpdatePathSuccess -> jsonUnion "success" (Object mempty) - UpdatePathFailure (UpdatePathError'HashMismatch hm) -> jsonUnion "hash_mismatch" hm - UpdatePathFailure (UpdatePathError'MissingDependencies md) -> jsonUnion "missing_dependencies" md - UpdatePathFailure (UpdatePathError'NoWritePermission path) -> jsonUnion "no_write_permission" path - UpdatePathFailure (UpdatePathError'InvalidRepoInfo errMsg repoInfo) -> jsonUnion "invalid_repo_info" (errMsg, repoInfo) - UpdatePathFailure UpdatePathError'UserNotFound -> jsonUnion "user_not_found" (Object mempty) - -instance FromJSON UpdatePathResponse where - parseJSON v = - v & Aeson.withObject "UpdatePathResponse" \obj -> - obj .: "type" >>= Aeson.withText "type" \case - "success" -> pure UpdatePathSuccess - "hash_mismatch" -> UpdatePathFailure . UpdatePathError'HashMismatch <$> obj .: "payload" - "missing_dependencies" -> UpdatePathFailure . UpdatePathError'MissingDependencies <$> obj .: "payload" - "no_write_permission" -> UpdatePathFailure . UpdatePathError'NoWritePermission <$> obj .: "payload" - "invalid_repo_info" -> do - (errMsg, repoInfo) <- obj .: "payload" - pure (UpdatePathFailure (UpdatePathError'InvalidRepoInfo errMsg repoInfo)) - "user_not_found" -> pure (UpdatePathFailure UpdatePathError'UserNotFound) - t -> failText $ "Unexpected UpdatePathResponse type: " <> t - -data HashMismatch = HashMismatch - { path :: Path, - expectedHash :: Maybe Hash32, - actualHash :: Maybe Hash32 - } - deriving stock (Show, Eq, Ord) - -instance ToJSON HashMismatch where - toJSON (HashMismatch path expectedHash actualHash) = - object - [ "path" .= path, - "expected_hash" .= expectedHash, - "actual_hash" .= actualHash - ] - -instance FromJSON HashMismatch where - parseJSON = Aeson.withObject "HashMismatch" \obj -> do - path <- obj .: "path" - expectedHash <- obj .: "expected_hash" - actualHash <- obj .: "actual_hash" - pure HashMismatch {..} - ------------------------------------------------------------------------------------------------------------------------ -- Common/shared error types diff --git a/unison-share-api/src/Unison/Util/Find.hs b/unison-share-api/src/Unison/Util/Find.hs index 22923d7b03..792d439b24 100644 --- a/unison-share-api/src/Unison/Util/Find.hs +++ b/unison-share-api/src/Unison/Util/Find.hs @@ -15,7 +15,7 @@ import Data.Text qualified as Text -- https://www.stackage.org/haddock/lts-13.9/regex-tdfa-1.2.3.1/Text-Regex-TDFA.html import Text.Regex.TDFA qualified as RE import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.Names (Names) diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index 3741a18615..52cb824d14 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -41,7 +41,7 @@ library Unison.Server.Orphans Unison.Server.QueryResult Unison.Server.SearchResult - Unison.Server.SearchResult' + Unison.Server.SearchResultPrime Unison.Server.Syntax Unison.Server.Types Unison.Sync.API @@ -84,7 +84,6 @@ library ghc-options: -Wall build-depends: Diff - , NanoID , aeson >=2.0.0.0 , async , base @@ -99,18 +98,14 @@ library , fuzzyfind , http-media , http-types - , jose - , jwt , lens , lucid , memory , mtl - , mwc-random , nonempty-containers , openapi3 , regex-tdfa , servant - , servant-auth , servant-docs , servant-openapi3 , servant-server @@ -127,13 +122,12 @@ library , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-runtime , unison-share-projects-api , unison-sqlite , unison-syntax - , unison-util-base32hex , unison-util-relation , unliftio - , unordered-containers , uri-encode , utf8-string , vector diff --git a/unison-share-projects-api/package.yaml b/unison-share-projects-api/package.yaml index 39545662ed..10694036b6 100644 --- a/unison-share-projects-api/package.yaml +++ b/unison-share-projects-api/package.yaml @@ -11,7 +11,6 @@ library: dependencies: - aeson - base - - containers - jose - jwt - lens @@ -21,7 +20,6 @@ dependencies: - unison-hash - unison-hash-orphans-aeson - unison-prelude - - unordered-containers ghc-options: -Wall diff --git a/unison-share-projects-api/src/Unison/Share/API/Hash.hs b/unison-share-projects-api/src/Unison/Share/API/Hash.hs index 1d975300a2..dfa1d1f44c 100644 --- a/unison-share-projects-api/src/Unison/Share/API/Hash.hs +++ b/unison-share-projects-api/src/Unison/Share/API/Hash.hs @@ -1,4 +1,9 @@ {-# LANGUAGE RecordWildCards #-} +-- Manipulating JWT claims with addClaim etc. directly is deprecated, so we'll need to fix that eventually. +-- The new way appears to be to define custom types with JSON instances and use those to encode/decode the JWT; +-- see https://github.com/frasertweedale/hs-jose/issues/116 +-- https://github.com/unisonweb/unison/issues/5153 +{-# OPTIONS_GHC -Wno-deprecations #-} -- | Hash-related types in the Share API. module Unison.Share.API.Hash diff --git a/unison-share-projects-api/unison-share-projects-api.cabal b/unison-share-projects-api/unison-share-projects-api.cabal index 3460047cc3..1ed58ed848 100644 --- a/unison-share-projects-api/unison-share-projects-api.cabal +++ b/unison-share-projects-api/unison-share-projects-api.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -54,7 +54,6 @@ library build-depends: aeson , base - , containers , jose , jwt , lens @@ -64,5 +63,4 @@ library , unison-hash , unison-hash-orphans-aeson , unison-prelude - , unordered-containers default-language: Haskell2010 diff --git a/unison-src/builtin-tests/base.md b/unison-src/builtin-tests/base.md index d4717fdcc1..572869b922 100644 --- a/unison-src/builtin-tests/base.md +++ b/unison-src/builtin-tests/base.md @@ -4,8 +4,8 @@ otherwise it may reuse a previously cached codebase. Thus, make sure the contents of this file define the contents of the cache (e.g. don't pull `latest`.) -```ucm -.> pull @unison/base/releases/2.5.0 .base -.> builtins.mergeio -.> undo +``` ucm +scratch/main> pull @unison/base/releases/2.5.0 .base +scratch/main> builtins.mergeio +scratch/main> undo ``` diff --git a/unison-src/builtin-tests/interpreter-tests.output.md b/unison-src/builtin-tests/interpreter-tests.output.md index 9257063d78..87de1b4977 100644 --- a/unison-src/builtin-tests/interpreter-tests.output.md +++ b/unison-src/builtin-tests/interpreter-tests.output.md @@ -4,7 +4,19 @@ If you want to add or update tests, you can create a branch of that project, and Before merging the PR on Github, we'll merge your branch on Share and restore `runtime_tests_version` to /main or maybe a release. -```ucm +``` ucm :hide :error +scratch/main> this is a hack to trigger an error, in order to swallow any error on the next line. + +scratch/main> we delete the project to avoid any merge conflicts or complaints from ucm. + +scratch/main> delete.project runtime-tests +``` + +``` ucm :hide +scratch/main> clone @unison/runtime-tests/releases/0.0.1 runtime-tests/selected +``` + +``` ucm runtime-tests/selected> run tests () @@ -12,5 +24,4 @@ runtime-tests/selected> run tests runtime-tests/selected> run tests.interpreter.only () - ``` diff --git a/unison-src/builtin-tests/interpreter-tests.sh b/unison-src/builtin-tests/interpreter-tests.sh index 969c3ec754..f792b5a2fd 100755 --- a/unison-src/builtin-tests/interpreter-tests.sh +++ b/unison-src/builtin-tests/interpreter-tests.sh @@ -1,11 +1,13 @@ -#!/bin/bash +#!/usr/bin/env bash set -ex -ucm=$(stack exec -- which unison) -echo "$ucm" +if [ -z "$1" ]; then + ucm=$(stack exec -- which unison) +else + ucm="$1" +fi -runtime_tests_version="@unison/runtime-tests/main" -echo $runtime_tests_version +runtime_tests_version="@unison/runtime-tests/releases/0.0.1" codebase=${XDG_CACHE_HOME:-"$HOME/.cache"}/unisonlanguage/runtime-tests.unison @@ -13,5 +15,4 @@ runtime_tests_version="$runtime_tests_version" \ envsubst '$runtime_tests_version' \ < unison-src/builtin-tests/interpreter-tests.tpl.md \ > unison-src/builtin-tests/interpreter-tests.md -echo "$ucm" transcript.fork -C $codebase -S $codebase unison-src/builtin-tests/interpreter-tests.md time "$ucm" transcript.fork -C $codebase -S $codebase unison-src/builtin-tests/interpreter-tests.md diff --git a/unison-src/builtin-tests/interpreter-tests.tpl.md b/unison-src/builtin-tests/interpreter-tests.tpl.md index 2d09efdc0e..5ad0d23052 100644 --- a/unison-src/builtin-tests/interpreter-tests.tpl.md +++ b/unison-src/builtin-tests/interpreter-tests.tpl.md @@ -4,16 +4,16 @@ If you want to add or update tests, you can create a branch of that project, and Before merging the PR on Github, we'll merge your branch on Share and restore `runtime_tests_version` to /main or maybe a release. -```ucm:hide:error -.> this is a hack to trigger an error, in order to swallow any error on the next line. -.> we delete the project to avoid any merge conflicts or complaints from ucm. -.> delete.project runtime-tests +``` ucm :hide:error +scratch/main> this is a hack to trigger an error, in order to swallow any error on the next line. +scratch/main> we delete the project to avoid any merge conflicts or complaints from ucm. +scratch/main> delete.project runtime-tests ``` -```ucm:hide -.> clone ${runtime_tests_version} runtime-tests/selected +``` ucm :hide +scratch/main> clone ${runtime_tests_version} runtime-tests/selected ``` -```ucm +``` ucm runtime-tests/selected> run tests runtime-tests/selected> run tests.interpreter.only ``` diff --git a/unison-src/builtin-tests/jit-tests.output.md b/unison-src/builtin-tests/jit-tests.output.md index 55c9234d59..94225ebd14 100644 --- a/unison-src/builtin-tests/jit-tests.output.md +++ b/unison-src/builtin-tests/jit-tests.output.md @@ -4,7 +4,19 @@ If you want to add or update tests, you can create a branch of that project, and Before merging the PR on Github, we'll merge your branch on Share and restore `runtime_tests_version` to /main or maybe a release. -```ucm +``` ucm :hide :error +scratch/main> this is a hack to trigger an error, in order to swallow any error on the next line. + +scratch/main> we delete the project to avoid any merge conflicts or complaints from ucm. + +scratch/main> delete.project runtime-tests +``` + +``` ucm :hide +scratch/main> clone @unison/runtime-tests/releases/0.0.1 runtime-tests/selected +``` + +``` ucm runtime-tests/selected> run.native tests () @@ -12,12 +24,13 @@ runtime-tests/selected> run.native tests runtime-tests/selected> run.native tests.jit.only () - ``` + Per Dan: It's testing a flaw in how we were sending code from a scratch file to the native runtime, when that happened multiple times. Related to the verifiable refs and recursive functions. -```unison + +``` unison foo = do go : Nat ->{Exception} () go = cases @@ -26,41 +39,39 @@ foo = do go 1000 ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: foo : '{Exception} () - ``` -```ucm -.> run.native foo + +``` ucm +scratch/main> run.native foo () -.> run.native foo +scratch/main> run.native foo () - ``` + This can also only be tested by separately running this test, because it is exercising the protocol that ucm uses to talk to the jit during an exception. -```ucm +``` ucm :error runtime-tests/selected> run.native testBug 💔💥 - + I've encountered a call to builtin.bug with the following value: - - "testing" + "testing" ``` diff --git a/unison-src/builtin-tests/jit-tests.sh b/unison-src/builtin-tests/jit-tests.sh index d4d9356ab1..1cba258c06 100755 --- a/unison-src/builtin-tests/jit-tests.sh +++ b/unison-src/builtin-tests/jit-tests.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env sh set -ex # the first arg is the path to the unison executable @@ -8,10 +8,7 @@ if [ -z "$1" ]; then exit 1 fi -# call unison with all its args quoted -ucm=("$@") - -runtime_tests_version="@unison/runtime-tests/main" +runtime_tests_version="@unison/runtime-tests/releases/0.0.1" echo $runtime_tests_version codebase=${XDG_CACHE_HOME:-"$HOME/.cache"}/unisonlanguage/runtime-tests.unison @@ -27,4 +24,5 @@ runtime_tests_version="$runtime_tests_version" \ < unison-src/builtin-tests/jit-tests.tpl.md \ > unison-src/builtin-tests/jit-tests.md -time "${ucm[@]}" transcript.fork -C $codebase -S $codebase unison-src/builtin-tests/jit-tests.md +# call unison with all its args quoted +time "$@" transcript.fork -C $codebase -S $codebase unison-src/builtin-tests/jit-tests.md diff --git a/unison-src/builtin-tests/jit-tests.tpl.md b/unison-src/builtin-tests/jit-tests.tpl.md index b24a7c7c7c..b0d06a24a9 100644 --- a/unison-src/builtin-tests/jit-tests.tpl.md +++ b/unison-src/builtin-tests/jit-tests.tpl.md @@ -4,16 +4,16 @@ If you want to add or update tests, you can create a branch of that project, and Before merging the PR on Github, we'll merge your branch on Share and restore `runtime_tests_version` to /main or maybe a release. -```ucm:hide:error -.> this is a hack to trigger an error, in order to swallow any error on the next line. -.> we delete the project to avoid any merge conflicts or complaints from ucm. -.> delete.project runtime-tests +``` ucm :hide:error +scratch/main> this is a hack to trigger an error, in order to swallow any error on the next line. +scratch/main> we delete the project to avoid any merge conflicts or complaints from ucm. +scratch/main> delete.project runtime-tests ``` -```ucm:hide -.> clone ${runtime_tests_version} runtime-tests/selected +``` ucm :hide +scratch/main> clone ${runtime_tests_version} runtime-tests/selected ``` -```ucm +``` ucm runtime-tests/selected> run.native tests runtime-tests/selected> run.native tests.jit.only ``` @@ -21,7 +21,7 @@ runtime-tests/selected> run.native tests.jit.only Per Dan: It's testing a flaw in how we were sending code from a scratch file to the native runtime, when that happened multiple times. Related to the verifiable refs and recursive functions. -```unison +``` unison foo = do go : Nat ->{Exception} () go = cases @@ -30,15 +30,15 @@ foo = do go 1000 ``` -```ucm -.> run.native foo -.> run.native foo +``` ucm +scratch/main> run.native foo +scratch/main> run.native foo ``` This can also only be tested by separately running this test, because it is exercising the protocol that ucm uses to talk to the jit during an exception. -```ucm:error +``` ucm :error runtime-tests/selected> run.native testBug ``` diff --git a/unison-src/tests/fix5507.md b/unison-src/tests/fix5507.md new file mode 100755 index 0000000000..bd5e3f4fa8 --- /dev/null +++ b/unison-src/tests/fix5507.md @@ -0,0 +1,28 @@ +```ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +```unison :hide +Nat.toBytesLittleEndian : Nat -> Bytes +Nat.toBytesLittleEndian = encodeNat64le +``` + +```ucm :hide +scratch/main> add +``` + +`Nat.toBytesLittleEndian` gets inlined, but it should still be found in the code cache when this is compiled and re-loaded. + +```unison :hide +main : '{IO} () +main = do + _ = Nat.toBytesLittleEndian 3 + match Code.lookup (termLink Nat.toBytesLittleEndian) with + Some _code -> () + None -> bug "code cache was empty" +``` + +```ucm :hide +scratch/main> add +scratch/main> compile main fix5507 +``` diff --git a/unison-src/tests/fix5507.sh b/unison-src/tests/fix5507.sh new file mode 100755 index 0000000000..26aac5c3ef --- /dev/null +++ b/unison-src/tests/fix5507.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env sh +set -ex + +# the first arg is the path to the unison executable +if [ -z "$1" ]; then + echo "Usage: $0 " + exit 1 +fi + +# call unison with all its args quoted +"$@" transcript unison-src/tests/fix5507.md \ + && "$@" run.compiled fix5507.uc diff --git a/unison-src/tests/type-application.u b/unison-src/tests/type-application.u index 87b673809d..345bcc2aee 100644 --- a/unison-src/tests/type-application.u +++ b/unison-src/tests/type-application.u @@ -3,6 +3,7 @@ structural ability Foo where foo : {Foo} Nat structural type Wrap a = Wrap Nat +structural type C = C (Wrap {}) -- constrain Wrap kind blah : Wrap {Foo} -> Nat blah = cases diff --git a/unison-src/transcripts-manual/benchmarks.md b/unison-src/transcripts-manual/benchmarks.md index 0a8ff9358c..c1ae19d148 100644 --- a/unison-src/transcripts-manual/benchmarks.md +++ b/unison-src/transcripts-manual/benchmarks.md @@ -1,96 +1,96 @@ -```ucm:hide -.> pull unison.public.base.releases.M4d base -.> pull runarorama.public.sort.data sort +``` ucm :hide +scratch/main> pull unison.public.base.releases.M4d base +scratch/main> pull runarorama.public.sort.data sort ``` -```unison:hide +``` unison :hide benchmarkFilePath = FilePath "unison-src/transcripts-manual/benchmarks/output.bench.txt" archiveFilePath = FilePath "unison-src/transcripts-manual/benchmarks/output" timeit : Text -> '{IO,Exception} a ->{IO,Exception} a -timeit label a = +timeit label a = before = !realtime r = !a after = !realtime elapsed = Duration.between before after elapsedText = Duration.toText elapsed - go file = + go file = putText file ("\n" ++ label ++ " " ++ Int.toText (Duration.countMicroseconds elapsed) ++ " # " ++ elapsedText) printLine ("\n\n ******** \n") printLine (label ++ " took " ++ elapsedText) bracket '(FilePath.open benchmarkFilePath FileMode.Append) Handle.close go r -prepare = do - -- if benchmarkFilePath exists, move it to blah-.txt for archive purposes +prepare = do + -- if benchmarkFilePath exists, move it to blah-.txt for archive purposes use Text ++ if FilePath.exists benchmarkFilePath then createDirectory archiveFilePath now = OffsetDateTime.toText (atUTC !realtime) - timestamped = FilePath.toText archiveFilePath ++ "/" ++ now ++ "-bench.txt" + timestamped = FilePath.toText archiveFilePath ++ "/" ++ now ++ "-bench.txt" renameFile benchmarkFilePath (FilePath timestamped) - else + else () ``` -```ucm:hide -.> add -.> run prepare +``` ucm :hide +scratch/main> add +scratch/main> run prepare ``` ## Benchmarks -```ucm -.> load unison-src/transcripts-manual/benchmarks/each.u -.> run main +``` ucm +scratch/main> load unison-src/transcripts-manual/benchmarks/each.u +scratch/main> run main ``` -```ucm -.> load unison-src/transcripts-manual/benchmarks/listmap.u -.> run main +``` ucm +scratch/main> load unison-src/transcripts-manual/benchmarks/listmap.u +scratch/main> run main ``` -```ucm -.> load unison-src/transcripts-manual/benchmarks/listfilter.u -.> run main +``` ucm +scratch/main> load unison-src/transcripts-manual/benchmarks/listfilter.u +scratch/main> run main ``` -```ucm -.> load unison-src/transcripts-manual/benchmarks/random.u -.> run main +``` ucm +scratch/main> load unison-src/transcripts-manual/benchmarks/random.u +scratch/main> run main ``` -```ucm -.> load unison-src/transcripts-manual/benchmarks/simpleloop.u -.> run main +``` ucm +scratch/main> load unison-src/transcripts-manual/benchmarks/simpleloop.u +scratch/main> run main ``` -```ucm -.> load unison-src/transcripts-manual/benchmarks/fibonacci.u -.> run main +``` ucm +scratch/main> load unison-src/transcripts-manual/benchmarks/fibonacci.u +scratch/main> run main ``` -```ucm -.> load unison-src/transcripts-manual/benchmarks/map.u -.> run main +``` ucm +scratch/main> load unison-src/transcripts-manual/benchmarks/map.u +scratch/main> run main ``` -```ucm -.> load unison-src/transcripts-manual/benchmarks/natmap.u -.> run main +``` ucm +scratch/main> load unison-src/transcripts-manual/benchmarks/natmap.u +scratch/main> run main ``` -```ucm -.> load unison-src/transcripts-manual/benchmarks/stm.u -.> run main +``` ucm +scratch/main> load unison-src/transcripts-manual/benchmarks/stm.u +scratch/main> run main ``` -```ucm -.> load unison-src/transcripts-manual/benchmarks/tmap.u -.> run main +``` ucm +scratch/main> load unison-src/transcripts-manual/benchmarks/tmap.u +scratch/main> run main ``` -```ucm -.> load unison-src/transcripts-manual/benchmarks/array-sort.u -.> run main -``` \ No newline at end of file +``` ucm +scratch/main> load unison-src/transcripts-manual/benchmarks/array-sort.u +scratch/main> run main +``` diff --git a/unison-src/transcripts-manual/docs.to-html.md b/unison-src/transcripts-manual/docs.to-html.md new file mode 100644 index 0000000000..8b1fa6b688 --- /dev/null +++ b/unison-src/transcripts-manual/docs.to-html.md @@ -0,0 +1,19 @@ +``` ucm +test-html-docs/main> builtins.mergeio lib.builtins +``` + +``` unison +{{A doc directly in the namespace.}} +some.ns.direct = 1 + +{{A doc pretty deeply nested in the namespace.}} +some.ns.pretty.deeply.nested = 2 + +{{A doc outside the namespace.}} +some.outside = 3 +``` + +``` ucm +test-html-docs/main> add +test-html-docs/main> docs.to-html some.ns unison-src/transcripts-manual/docs.to-html +``` diff --git a/unison-src/transcripts-manual/docs.to-html.output.md b/unison-src/transcripts-manual/docs.to-html.output.md new file mode 100644 index 0000000000..45528703fa --- /dev/null +++ b/unison-src/transcripts-manual/docs.to-html.output.md @@ -0,0 +1,48 @@ +``` ucm +test-html-docs/main> builtins.mergeio lib.builtins + + Done. +``` + +``` unison +{{A doc directly in the namespace.}} +some.ns.direct = 1 + +{{A doc pretty deeply nested in the namespace.}} +some.ns.pretty.deeply.nested = 2 + +{{A doc outside the namespace.}} +some.outside = 3 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + some.ns.direct : Nat + some.ns.direct.doc : Doc2 + some.ns.pretty.deeply.nested : Nat + some.ns.pretty.deeply.nested.doc : Doc2 + some.outside : Nat + some.outside.doc : Doc2 +``` + +``` ucm +test-html-docs/main> add + + ⍟ I've added these definitions: + + some.ns.direct : Nat + some.ns.direct.doc : Doc2 + some.ns.pretty.deeply.nested : Nat + some.ns.pretty.deeply.nested.doc : Doc2 + some.outside : Nat + some.outside.doc : Doc2 + +test-html-docs/main> docs.to-html some.ns unison-src/transcripts-manual/docs.to-html +``` diff --git a/unison-src/transcripts-manual/docs.to-html/direct/doc.html b/unison-src/transcripts-manual/docs.to-html/direct/doc.html new file mode 100644 index 0000000000..0e9f37a540 --- /dev/null +++ b/unison-src/transcripts-manual/docs.to-html/direct/doc.html @@ -0,0 +1 @@ +
A doc directly in the namespace.
\ No newline at end of file diff --git a/unison-src/transcripts-manual/docs.to-html/pretty/deeply/nested/doc.html b/unison-src/transcripts-manual/docs.to-html/pretty/deeply/nested/doc.html new file mode 100644 index 0000000000..1e5a75f500 --- /dev/null +++ b/unison-src/transcripts-manual/docs.to-html/pretty/deeply/nested/doc.html @@ -0,0 +1 @@ +
A doc pretty deeply nested in the namespace.
\ No newline at end of file diff --git a/unison-src/transcripts-manual/gen-racket-libs.md b/unison-src/transcripts-manual/gen-racket-libs.md index 811ec14f50..261c8688b1 100644 --- a/unison-src/transcripts-manual/gen-racket-libs.md +++ b/unison-src/transcripts-manual/gen-racket-libs.md @@ -1,17 +1,16 @@ - When we start out, `./scheme-libs/racket` contains a bunch of library files that we'll need. They define the Unison builtins for Racket. Next, we'll download the jit project and generate a few Racket files from it. -```ucm -jit-setup/main> lib.install @unison/internal/releases/0.0.17 +``` ucm +jit-setup/main> lib.install @unison/internal/releases/0.0.25 ``` -```unison +``` unison go = generateSchemeBoot "scheme-libs/racket" ``` -```ucm +``` ucm jit-setup/main> run go ``` @@ -20,12 +19,11 @@ complement of unison libraries for a given combination of ucm version and @unison/internal version. To set up racket to use these files, we need to create a package with -them. This is accomplished by running. +them. This is accomplished by running: - raco pkg install -t dir unison + raco pkg install -t dir scheme-libs/racket/unison -in the directory where the `unison` directory is located. Then the -runtime executable can be built with +After, the runtime executable can be built with raco exe scheme-libs/racket/unison-runtime.rkt diff --git a/unison-src/transcripts-manual/gen-racket-libs.output.md b/unison-src/transcripts-manual/gen-racket-libs.output.md index 241a9cdc59..d3bbb3946f 100644 --- a/unison-src/transcripts-manual/gen-racket-libs.output.md +++ b/unison-src/transcripts-manual/gen-racket-libs.output.md @@ -1,39 +1,21 @@ - When we start out, `./scheme-libs/racket` contains a bunch of library files that we'll need. They define the Unison builtins for Racket. Next, we'll download the jit project and generate a few Racket files from it. -```ucm -.> project.create-empty jit-setup - - 🎉 I've created the project jit-setup. - - 🎨 Type `ui` to explore this project's code in your browser. - 🔭 Discover libraries at https://share.unison-lang.org - 📖 Use `help-topic projects` to learn more about projects. - - Write your first Unison code with UCM: - - 1. Open scratch.u. - 2. Write some Unison code and save the file. - 3. In UCM, type `add` to save it to your new project. - - 🎉 🥳 Happy coding! - -jit-setup/main> pull @unison/internal/releases/0.0.17 lib.jit +``` ucm +jit-setup/main> lib.install @unison/internal/releases/0.0.25 - Downloaded 15091 entities. + Downloaded 14942 entities. - ✅ - - Successfully pulled into lib.jit, which was empty. + I installed @unison/internal/releases/0.0.25 as + unison_internal_0_0_25. ``` -```unison +``` unison go = generateSchemeBoot "scheme-libs/racket" ``` -```ucm +``` ucm Loading changes detected in scratch.u. @@ -46,7 +28,7 @@ go = generateSchemeBoot "scheme-libs/racket" go : '{IO, Exception} () ``` -```ucm +``` ucm jit-setup/main> run go () @@ -57,18 +39,24 @@ complement of unison libraries for a given combination of ucm version and @unison/internal version. To set up racket to use these files, we need to create a package with -them. This is accomplished by running. +them. This is accomplished by running: - raco pkg install -t dir unison +``` +raco pkg install -t dir scheme-libs/racket/unison +``` -in the directory where the `unison directory is located. Then the -runtime executable can be built with +After, the runtime executable can be built with - raco exe scheme-libs/racket/unison-runtime.rkt +``` +raco exe scheme-libs/racket/unison-runtime.rkt +``` and a distributable directory can be produced with: - raco distribute scheme-libs/racket/unison-runtime +``` +raco distribute scheme-libs/racket/unison-runtime +``` At that point, should contain the executable and all dependencies necessary to run it. + diff --git a/unison-src/transcripts-manual/remote-tab-completion.md b/unison-src/transcripts-manual/remote-tab-completion.md index da783b9de7..c144ed5634 100644 --- a/unison-src/transcripts-manual/remote-tab-completion.md +++ b/unison-src/transcripts-manual/remote-tab-completion.md @@ -2,6 +2,6 @@ Note: this makes a network call to share to get completions -```ucm -.> debug.tab-complete pull unison.pub +``` ucm +scratch/main> debug.tab-complete pull unison.pub ``` diff --git a/unison-src/transcripts-manual/remote-tab-completion.output.md b/unison-src/transcripts-manual/remote-tab-completion.output.md index 27906fa2f6..a662ebd566 100644 --- a/unison-src/transcripts-manual/remote-tab-completion.output.md +++ b/unison-src/transcripts-manual/remote-tab-completion.output.md @@ -2,7 +2,7 @@ Note: this makes a network call to share to get completions -```ucm +``` ucm .> debug.tab-complete pull unison.pub unison.public diff --git a/unison-src/transcripts-manual/rewrites.md b/unison-src/transcripts-manual/rewrites.md index 15a5a06387..f77c87502a 100644 --- a/unison-src/transcripts-manual/rewrites.md +++ b/unison-src/transcripts-manual/rewrites.md @@ -1,15 +1,14 @@ - -```ucm:hide -.> builtins.mergeio -.> load unison-src/transcripts-using-base/base.u -.> add +``` ucm :hide +scratch/main> builtins.mergeio +scratch/main> load unison-src/transcripts-using-base/base.u +scratch/main> add ``` ## Structural find and replace Here's a scratch file with some rewrite rules: -```unison:hide +``` unison :hide ex1 = List.map (x -> x + 1) [1,2,3,4,5,6,7] eitherToOptional e a = @@ -36,25 +35,25 @@ rule2 x = @rewrite signature Optional ==> Optional2 Let's rewrite these: -```ucm -.> rewrite rule1 -.> rewrite eitherToOptional +``` ucm +scratch/main> rewrite rule1 +scratch/main> rewrite eitherToOptional ``` -```ucm:hide -.> load -.> add +``` ucm :hide +scratch/main> load +scratch/main> add ``` After adding to the codebase, here's the rewritten source: -```ucm -.> view ex1 Either.mapRight rule1 +``` ucm +scratch/main> view ex1 Either.mapRight rule1 ``` Another example, showing that we can rewrite to definitions that only exist in the file: -```unison:hide +``` unison :hide unique ability Woot1 where woot1 : () -> Nat unique ability Woot2 where woot2 : () -> Nat @@ -74,24 +73,24 @@ blah2 = 456 Let's apply the rewrite `woot1to2`: -```ucm -.> rewrite woot1to2 +``` ucm +scratch/main> rewrite woot1to2 ``` -```ucm:hide -.> load -.> add +``` ucm :hide +scratch/main> load +scratch/main> add ``` After adding the rewritten form to the codebase, here's the rewritten `Woot1` to `Woot2`: -```ucm -.> view wootEx +``` ucm +scratch/main> view wootEx ``` This example shows that rewrite rules can to refer to term definitions that only exist in the file: -```unison:hide +``` unison :hide foo1 = b = "b" 123 @@ -110,21 +109,21 @@ sameFileEx = foo1 ``` -```ucm:hide -.> rewrite rule -.> load -.> add +``` ucm :hide +scratch/main> rewrite rule +scratch/main> load +scratch/main> add ``` After adding the rewritten form to the codebase, here's the rewritten definitions: -```ucm -.> view foo1 foo2 sameFileEx +``` ucm +scratch/main> view foo1 foo2 sameFileEx ``` ## Capture avoidance -```unison:hide +``` unison :hide bar1 = b = "bar" 123 @@ -144,19 +143,19 @@ sameFileEx = In the above example, `bar2` is locally bound by the rule, so when applied, it should not refer to the `bar2` top level binding. -```ucm -.> rewrite rule +``` ucm +scratch/main> rewrite rule ``` Instead, it should be an unbound free variable, which doesn't typecheck: -```ucm:error -.> load +``` ucm :error +scratch/main> load ``` In this example, the `a` is locally bound by the rule, so it shouldn't capture the `a = 39494` binding which is in scope at the point of the replacement: -```unison:hide +``` unison :hide bar2 = a = 39494 233 @@ -166,33 +165,33 @@ rule a = @rewrite term 233 ==> a ``` -```ucm -.> rewrite rule +``` ucm +scratch/main> rewrite rule ``` The `a` introduced will be freshened to not capture the `a` in scope, so it remains as an unbound variable and is a type error: -```ucm:error -.> load +``` ucm :error +scratch/main> load ``` ## Structural find -```unison:hide +``` unison :hide eitherEx = Left ("hello", "there") ``` -```ucm:hide -.> add +``` ucm :hide +scratch/main> add ``` -```unison:hide +``` unison :hide findEitherEx x = @rewrite term Left ("hello", x) ==> Left ("hello" Text.++ x) findEitherFailure = @rewrite signature a . Either Failure a ==> () ``` -```ucm -.> sfind findEitherEx -.> sfind findEitherFailure -.> find 1-5 +``` ucm +scratch/main> sfind findEitherEx +scratch/main> sfind findEitherFailure +scratch/main> find 1-5 ``` diff --git a/unison-src/transcripts-manual/rewrites.output.md b/unison-src/transcripts-manual/rewrites.output.md index a4764c7735..d591c74597 100644 --- a/unison-src/transcripts-manual/rewrites.output.md +++ b/unison-src/transcripts-manual/rewrites.output.md @@ -1,9 +1,16 @@ +``` ucm :hide +scratch/main> builtins.mergeio + +scratch/main> load unison-src/transcripts-using-base/base.u + +scratch/main> add +``` ## Structural find and replace Here's a scratch file with some rewrite rules: -```unison +``` unison :hide ex1 = List.map (x -> x + 1) [1,2,3,4,5,6,7] eitherToOptional e a = @@ -30,26 +37,26 @@ rule2 x = @rewrite signature Optional ==> Optional2 Let's rewrite these: -```ucm -.> rewrite rule1 +``` ucm +scratch/main> rewrite rule1 ☝️ - + I found and replaced matches in these definitions: ex1 - + The rewritten file has been added to the top of scratch.u -.> rewrite eitherToOptional +scratch/main> rewrite eitherToOptional ☝️ - + I found and replaced matches in these definitions: Either.mapRight - - The rewritten file has been added to the top of scratch.u + The rewritten file has been added to the top of scratch.u ``` -```unison:added-by-ucm scratch.u + +``` unison :added-by-ucm scratch.u -- | Rewrote using: -- | Modified definition(s): ex1 @@ -74,12 +81,12 @@ rule1 f x = term x + 1 ==> Nat.increment x term a -> f a ==> f -type Optional2 a = Some2 a | None2 +type Optional2 a = None2 | Some2 a rule2 x = @rewrite signature Optional ==> Optional2 ``` -```unison:added-by-ucm scratch.u +``` unison :added-by-ucm scratch.u -- | Rewrote using: -- | Modified definition(s): Either.mapRight @@ -104,24 +111,30 @@ rule1 f x = term x + 1 ==> Nat.increment x term a -> f a ==> f -type Optional2 a = Some2 a | None2 +type Optional2 a = None2 | Some2 a rule2 x = @rewrite signature Optional ==> Optional2 ``` +``` ucm :hide +scratch/main> load + +scratch/main> add +``` + After adding to the codebase, here's the rewritten source: -```ucm -.> view ex1 Either.mapRight rule1 +``` ucm +scratch/main> view ex1 Either.mapRight rule1 Either.mapRight : (a ->{g} b) -> Optional a ->{g} Optional b Either.mapRight f = cases None -> None Some a -> Some (f a) - + ex1 : [Nat] ex1 = List.map Nat.increment [1, 2, 3, 4, 5, 6, 7] - + rule1 : (i ->{g} o) -> Nat @@ -133,11 +146,11 @@ After adding to the codebase, here's the rewritten source: @rewrite term x + 1 ==> Nat.increment x term a -> f a ==> f - ``` + Another example, showing that we can rewrite to definitions that only exist in the file: -```unison +``` unison :hide unique ability Woot1 where woot1 : () -> Nat unique ability Woot2 where woot2 : () -> Nat @@ -157,17 +170,17 @@ blah2 = 456 Let's apply the rewrite `woot1to2`: -```ucm -.> rewrite woot1to2 +``` ucm +scratch/main> rewrite woot1to2 ☝️ - + I found and replaced matches in these definitions: wootEx - - The rewritten file has been added to the top of scratch.u + The rewritten file has been added to the top of scratch.u ``` -```unison:added-by-ucm scratch.u + +``` unison :added-by-ucm scratch.u -- | Rewrote using: -- | Modified definition(s): wootEx @@ -183,7 +196,7 @@ woot1to2 x = wootEx : Nat ->{Woot2} Nat wootEx a = - _ = !Woot2.woot2 + _ = Woot2.woot2() blah2 blah = 123 @@ -191,20 +204,26 @@ blah = 123 blah2 = 456 ``` +``` ucm :hide +scratch/main> load + +scratch/main> add +``` + After adding the rewritten form to the codebase, here's the rewritten `Woot1` to `Woot2`: -```ucm -.> view wootEx +``` ucm +scratch/main> view wootEx wootEx : Nat ->{Woot2} Nat wootEx a = - _ = !woot2 + _ = woot2() blah2 - ``` + This example shows that rewrite rules can to refer to term definitions that only exist in the file: -```unison +``` unison :hide foo1 = b = "b" 123 @@ -223,30 +242,38 @@ sameFileEx = foo1 ``` +``` ucm :hide +scratch/main> rewrite rule + +scratch/main> load + +scratch/main> add +``` + After adding the rewritten form to the codebase, here's the rewritten definitions: -```ucm -.> view foo1 foo2 sameFileEx +``` ucm +scratch/main> view foo1 foo2 sameFileEx foo1 : Nat foo1 = b = "b" 123 - + foo2 : Nat foo2 = a = "a" 233 - + sameFileEx : Nat sameFileEx = _ = "ex" foo2 - ``` + ## Capture avoidance -```unison +``` unison :hide bar1 = b = "bar" 123 @@ -266,17 +293,17 @@ sameFileEx = In the above example, `bar2` is locally bound by the rule, so when applied, it should not refer to the `bar2` top level binding. -```ucm -.> rewrite rule +``` ucm +scratch/main> rewrite rule ☝️ - + I found and replaced matches in these definitions: sameFileEx - - The rewritten file has been added to the top of scratch.u + The rewritten file has been added to the top of scratch.u ``` -```unison:added-by-ucm scratch.u + +``` unison :added-by-ucm scratch.u -- | Rewrote using: -- | Modified definition(s): sameFileEx @@ -300,28 +327,28 @@ sameFileEx = Instead, it should be an unbound free variable, which doesn't typecheck: -```ucm -.> load +``` ucm :error +scratch/main> load Loading changes detected in scratch.u. I couldn't figure out what bar21 refers to here: - + 19 | bar21 - + I also don't know what type it should be. - + Some common causes of this error include: * Your current namespace is too deep to contain the definition in its subtree * The definition is part of a library which hasn't been added to this project * You have a typo in the name - ``` + In this example, the `a` is locally bound by the rule, so it shouldn't capture the `a = 39494` binding which is in scope at the point of the replacement: -```unison +``` unison :hide bar2 = a = 39494 233 @@ -331,17 +358,17 @@ rule a = @rewrite term 233 ==> a ``` -```ucm -.> rewrite rule +``` ucm +scratch/main> rewrite rule ☝️ - + I found and replaced matches in these definitions: bar2 - - The rewritten file has been added to the top of scratch.u + The rewritten file has been added to the top of scratch.u ``` -```unison:added-by-ucm scratch.u + +``` unison :added-by-ucm scratch.u -- | Rewrote using: -- | Modified definition(s): bar2 @@ -357,63 +384,67 @@ rule a = The `a` introduced will be freshened to not capture the `a` in scope, so it remains as an unbound variable and is a type error: -```ucm -.> load +``` ucm :error +scratch/main> load Loading changes detected in scratch.u. I couldn't figure out what a1 refers to here: - + 6 | a1 - + I also don't know what type it should be. - + Some common causes of this error include: * Your current namespace is too deep to contain the definition in its subtree * The definition is part of a library which hasn't been added to this project * You have a typo in the name - ``` + ## Structural find -```unison +``` unison :hide eitherEx = Left ("hello", "there") ``` -```unison +``` ucm :hide +scratch/main> add +``` + +``` unison :hide findEitherEx x = @rewrite term Left ("hello", x) ==> Left ("hello" Text.++ x) findEitherFailure = @rewrite signature a . Either Failure a ==> () ``` -```ucm -.> sfind findEitherEx +``` ucm +scratch/main> sfind findEitherEx 🔎 - + These definitions from the current namespace (excluding `lib`) have matches: - + 1. eitherEx - + Tip: Try `edit 1` to bring this into your scratch file. -.> sfind findEitherFailure +scratch/main> sfind findEitherFailure 🔎 - + These definitions from the current namespace (excluding `lib`) have matches: - + 1. catch 2. printText 3. reraise 4. toEither 5. toEither.handler - + Tip: Try `edit 1` or `edit 1-5` to bring these into your scratch file. -.> find 1-5 +scratch/main> find 1-5 1. Exception.catch : '{g, Exception} a ->{g} Either Failure a 2. Exception.reraise : Either Failure a ->{Exception} a @@ -422,6 +453,4 @@ findEitherFailure = @rewrite signature a . Either Failure a ==> () 4. Exception.toEither.handler : Request {Exception} a -> Either Failure a 5. printText : Text ->{IO} Either Failure () - - ``` diff --git a/unison-src/transcripts-manual/scheme.md b/unison-src/transcripts-manual/scheme.md index 1c1427280f..5a65057371 100644 --- a/unison-src/transcripts-manual/scheme.md +++ b/unison-src/transcripts-manual/scheme.md @@ -1,12 +1,12 @@ This transcript executes very slowly, because the compiler has an entire copy of base (and other stuff) within it. -```ucm:hide -.> builtins.merge -.> pull.without-history unison.public.base.trunk base +``` ucm :hide +scratch/main> builtins.merge +scratch/main> pull.without-history unison.public.base.trunk base ``` -```unison +``` unison stdOut = stdHandle StdOut print txt = @@ -54,8 +54,8 @@ multiAddUp : '{IO,Exception} () multiAddUp = repeat 35 '(printAddUp 3000000) ``` -```ucm -.> add -.> run singleAddUp -.> run.native multiAddUp +``` ucm +scratch/main> add +scratch/main> run singleAddUp +scratch/main> run.native multiAddUp ``` diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md index 7287a7ddba..fc9e320c04 100644 --- a/unison-src/transcripts-round-trip/main.md +++ b/unison-src/transcripts-round-trip/main.md @@ -1,100 +1,93 @@ This transcript verifies that the pretty-printer produces code that can be successfully parsed, for a variety of examples. Terms or types that fail to round-trip can be added to either `reparses-with-same-hash.u` or `reparses.u` as regression tests. -```ucm:hide -.> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +scratch/a1> builtins.mergeio lib.builtins +scratch/a2> builtins.mergeio lib.builtins ``` -```ucm:hide -.> copy.namespace builtin a1.lib.builtin -.> copy.namespace builtin a2.lib.builtin -.> load unison-src/transcripts-round-trip/reparses-with-same-hash.u -.a1> add +``` ucm :hide +scratch/a1> load unison-src/transcripts-round-trip/reparses-with-same-hash.u +scratch/a1> add ``` -```unison +``` unison x = () ``` -```ucm:hide -.a1> find +``` ucm :hide +scratch/a1> find ``` So we can see the pretty-printed output: -```ucm -.a1> edit 1-1000 +``` ucm +scratch/a1> edit.new 1-1000 ``` -```ucm:hide -.a1> delete.namespace.force lib.builtin +``` ucm :hide +scratch/a1> delete.namespace.force lib.builtins ``` -```ucm:hide -.a2> load +``` ucm :hide +scratch/a2> load ``` -```ucm:hide -.a2> add -.a2> delete.namespace.force lib.builtin +``` ucm :hide +scratch/a2> add +scratch/a2> delete.namespace.force lib.builtins ``` This diff should be empty if the two namespaces are equivalent. If it's nonempty, the diff will show us the hashes that differ. -```ucm:error -.> diff.namespace a1 a2 -``` - -```ucm:hide -.> undo -.> undo +``` ucm :error +scratch/main> diff.namespace /a1: /a2: ``` Now check that definitions in 'reparses.u' at least parse on round trip: -```ucm:hide -.a3> copy.namespace .builtin lib.builtin -.a3> load unison-src/transcripts-round-trip/reparses.u -.a3> add +``` ucm :hide +scratch/a3> builtins.mergeio lib.builtins +scratch/a3> load unison-src/transcripts-round-trip/reparses.u +scratch/a3> add ``` This just makes 'roundtrip.u' the latest scratch file. -```unison:hide +``` unison :hide x = () ``` -```ucm:hide -.a3> find +``` ucm :hide +scratch/a3> find ``` -```ucm -.a3> edit 1-5000 +``` ucm +scratch/a3> edit.new 1-5000 ``` -```ucm:hide -.> move.namespace a3 a3_old -.a3> copy.namespace .builtin lib.builtin -.a3> load -.a3> add -.a3> delete.namespace.force lib.builtin -.a3_old> delete.namespace.force lib.builtin +``` ucm :hide +scratch/a3_new> builtins.mergeio lib.builtins +scratch/a3_new> load +scratch/a3_new> add +scratch/a3> delete.namespace.force lib.builtins +scratch/a3_new> delete.namespace.force lib.builtins ``` These are currently all expected to have different hashes on round trip. -```ucm -.> diff.namespace a3 a3_old +``` ucm +scratch/main> diff.namespace /a3_new: /a3: ``` ## Other regression tests not covered by above -### Comment out builtins in the edit command +### Builtins should appear commented out in the edit.new command Regression test for https://github.com/unisonweb/unison/pull/3548 -```ucm:hide -.> alias.term ##Nat.+ plus -.> edit plus -.> load -.> undo +``` ucm +scratch/regressions> alias.term ##Nat.+ plus +scratch/regressions> edit.new plus +scratch/regressions> load ``` diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index fdeb756531..967044686b 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -1,36 +1,53 @@ This transcript verifies that the pretty-printer produces code that can be successfully parsed, for a variety of examples. Terms or types that fail to round-trip can be added to either `reparses-with-same-hash.u` or `reparses.u` as regression tests. -```unison -x = () +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins + +scratch/a1> builtins.mergeio lib.builtins + +scratch/a2> builtins.mergeio lib.builtins +``` + +``` ucm :hide +scratch/a1> load unison-src/transcripts-round-trip/reparses-with-same-hash.u + +scratch/a1> add ``` -```ucm +``` unison +x = () +``` +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: x : () +``` +``` ucm :hide +scratch/a1> find ``` + So we can see the pretty-printed output: -```ucm -.a1> edit 1-1000 +``` ucm +scratch/a1> edit.new 1-1000 ☝️ - - I added 105 definitions to the top of scratch.u - + + I added 111 definitions to the top of scratch.u + You can edit them there, then run `update` to replace the definitions currently in this namespace. - ``` -```unison:added-by-ucm scratch.u + +````` unison :added-by-ucm scratch.u structural ability Abort where abort : {Abort} a structural ability Ask a where ask : {Ask a} a @@ -73,13 +90,13 @@ structural ability Zoink where Abort.toDefault! : a -> '{g, Abort} a ->{g} a Abort.toDefault! default thunk = h x = Abort.toDefault! (handler_1778 default x) thunk - handle !thunk with h + handle thunk() with h Abort.toOptional : '{g, Abort} a -> '{g} Optional a Abort.toOptional thunk = do toOptional! thunk Abort.toOptional! : '{g, Abort} a ->{g} Optional a -Abort.toOptional! thunk = toDefault! None do Some !thunk +Abort.toOptional! thunk = toDefault! None do Some thunk() catchAll : x -> Nat catchAll x = 99 @@ -87,7 +104,7 @@ catchAll x = 99 Decode.remainder : '{Ask (Optional Bytes)} Bytes Decode.remainder = do match ask with None -> Bytes.empty - Some b -> b Bytes.++ !Decode.remainder + Some b -> b Bytes.++ Decode.remainder() ex1 : Nat ex1 = @@ -122,6 +139,46 @@ ex3a = a = do qux3 + qux3 () +fixity : '('()) +fixity = + do + use Nat * + + (===) = (==) + f <| x = f x + (<<) f g x = f (g x) + (>>) f g x = g (f x) + id x = x + (do + (%) = Nat.mod + ($) = (+) + c = 1 * (2 + 3) * 4 + plus = 1 + 2 + 3 + plus2 = 1 + (2 + 3) + d = true && (false || true) + z = true || false && true + e = 1 + 2 >= 3 + 4 + f = 9 % 2 === 0 + g = 0 == 9 % 2 + h = 2 * (10 $ 20) + i1 = 1 * 2 $ (3 * 4) $ 5 + i2 = (1 * 2 $ 3) * 4 $ 5 + oo = (2 * 10 $ 20) * 30 $ 40 + ffffffffffffffffffff x = x + 1 + gg x = x * 2 + j = 10 |> ffffffffffffffffffff |> gg |> gg |> gg |> gg |> gg + k = ffffffffffffffffffff << gg << ffffffffffffffffffff <| 10 + l = 10 |> (ffffffffffffffffffff >> gg >> ffffffffffffffffffff) + zzz = 1 + 2 * 3 < 4 + 5 * 6 && 7 + 8 * 9 > 10 + 11 * 12 + zz = + (1 * 2 + 3 * 3 < 4 + 5 * 6 && 7 + 8 * 9 > 10 + 11 * 12) + === (1 + 3 * 3 < 4 + 5 * 6 && 7 + 8 * 9 > 10 + 11 * 12) + zzzz = + 1 * 2 + 3 * 3 < 4 + 5 * 6 + && 7 + 8 * 9 > 10 + 11 * 12 === 1 + 3 * 3 < 4 + 5 * 6 + && 7 + 8 * 9 > 10 + 11 * 12 + ()) + |> id + fix_1035 : Text fix_1035 = use Text ++ @@ -168,7 +225,7 @@ fix_2271 = # Full doc body indented ``` raw - myVal1 = 42 + myVal1 = 42 myVal2 = 43 myVal4 = 44 ``` @@ -194,7 +251,7 @@ fix_2650 = use Nat + y = 12 13 + y - !addNumbers + addNumbers() fix_2650a : tvar -> fun -> () fix_2650a tvar fun = () @@ -331,6 +388,85 @@ fix_4384e = }} }} +fix_4727 : Doc2 +fix_4727 = {{ `` 0xs900dc0ffee `` }} + +fix_4729a : Doc2 +fix_4729a = + {{ + # H1A + + ## H2A + + ``` + {{ + # H1B + + ## B2B + + + }} + ``` + + ## H2A + + + }} + +fix_4729b : Doc2 +fix_4729b = + {{ + # H1A + + ## H2A + + {{ docTable + [[{{ + # HA + + + }}, {{ + # HB + + + }}], [{{ + # a + + + }}, {{ + # b + + + }}]] }} + + ## H2A + + + }} + +fix_4729c : Doc2 +fix_4729c = + {{ + # Examples `` + docCallout + (Some + (syntax.docUntitledSection + [syntax.docSection (syntax.docParagraph [syntax.docWord "Title"]) []])) + (syntax.docUntitledSection + [ syntax.docParagraph + [ syntax.docWord "This" + , syntax.docWord "is" + , syntax.docWord "a" + , syntax.docWord "callout" + , syntax.docWord "with" + , syntax.docWord "a" + , syntax.docWord "title" + ] + ]) `` + + + }} + Fix_525.bar.quaffle : Nat Fix_525.bar.quaffle = 32 @@ -342,6 +478,16 @@ fix_525_exampleTerm quaffle = fix_525_exampleType : Id qualifiedName -> Id Fully.qualifiedName fix_525_exampleType z = Id (Dontcare () 19) +fnApplicationSyntax : Nat +fnApplicationSyntax = + use Nat + + Environment.default = do 1 + 1 + oog = do 2 + 2 + blah : Nat -> Float -> Nat + blah x y = x + 1 + _ = blah Environment.default() 1.0 + blah oog() (max 1.0 2.0) + Foo.bar.qux1 : Nat Foo.bar.qux1 = 42 @@ -421,7 +567,7 @@ nested_fences : Doc2 nested_fences = {{ ```` raw - ```unison + ``` unison r = "boopydoo" ``` ```` @@ -501,8 +647,8 @@ softhang22 = softhang2 [0, 1, 2, 3, 4, 5] cases softhang23 : 'Nat softhang23 = do - use Nat + catchAll do + use Nat + x = 1 y = 2 x + y @@ -672,41 +818,67 @@ UUID.random = do UUID 0 (0, 0) UUID.randomUUIDBytes : 'Bytes UUID.randomUUIDBytes = do - (UUID a (b, _)) = !random + (UUID a (b, _)) = random() encodeNat64be a Bytes.++ encodeNat64be b (|>) : a -> (a ->{e} b) ->{e} b a |> f = f a +````` + +``` ucm :hide +scratch/a1> delete.namespace.force lib.builtins +``` + +``` ucm :hide +scratch/a2> load +``` + +``` ucm :hide +scratch/a2> add + +scratch/a2> delete.namespace.force lib.builtins ``` This diff should be empty if the two namespaces are equivalent. If it's nonempty, the diff will show us the hashes that differ. -```ucm -.> diff.namespace a1 a2 +``` ucm :error +scratch/main> diff.namespace /a1: /a2: The namespaces are identical. - ``` + Now check that definitions in 'reparses.u' at least parse on round trip: +``` ucm :hide +scratch/a3> builtins.mergeio lib.builtins + +scratch/a3> load unison-src/transcripts-round-trip/reparses.u + +scratch/a3> add +``` + This just makes 'roundtrip.u' the latest scratch file. -```unison +``` unison :hide x = () ``` -```ucm -.a3> edit 1-5000 +``` ucm :hide +scratch/a3> find +``` + +``` ucm +scratch/a3> edit.new 1-5000 ☝️ - + I added 2 definitions to the top of scratch.u - + You can edit them there, then run `update` to replace the definitions currently in this namespace. - ``` -```unison:added-by-ucm scratch.u + +```` unison :added-by-ucm scratch.u explanationOfThisFile : Text explanationOfThisFile = """ @@ -726,23 +898,59 @@ sloppyDocEval = 1 + 1 ``` }} +```` + +``` ucm :hide +scratch/a3_new> builtins.mergeio lib.builtins + +scratch/a3_new> load + +scratch/a3_new> add + +scratch/a3> delete.namespace.force lib.builtins + +scratch/a3_new> delete.namespace.force lib.builtins ``` These are currently all expected to have different hashes on round trip. -```ucm -.> diff.namespace a3 a3_old +``` ucm +scratch/main> diff.namespace /a3_new: /a3: Updates: - + 1. sloppyDocEval : Doc2 ↓ 2. sloppyDocEval : Doc2 - ``` + ## Other regression tests not covered by above -### Comment out builtins in the edit command +### Builtins should appear commented out in the edit.new command Regression test for https://github.com/unisonweb/unison/pull/3548 +``` ucm +scratch/regressions> alias.term ##Nat.+ plus + + Done. + +scratch/regressions> edit.new plus + + ☝️ + + I added 1 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. + +scratch/regressions> load + + Loading changes detected in scratch.u. + + I loaded scratch.u and didn't find anything. +``` + +``` unison :added-by-ucm scratch.u +-- builtin plus : ##Nat -> ##Nat -> ##Nat +``` diff --git a/unison-src/transcripts-round-trip/reparses-with-same-hash.u b/unison-src/transcripts-round-trip/reparses-with-same-hash.u index 09b941ff64..948d9118b7 100644 --- a/unison-src/transcripts-round-trip/reparses-with-same-hash.u +++ b/unison-src/transcripts-round-trip/reparses-with-same-hash.u @@ -1,5 +1,4 @@ - --- A very simple example to start +-- A very simple example to start simplestPossibleExample = 1 + 1 -- Destructuring binds @@ -73,7 +72,7 @@ Abort.toDefault! default thunk = h x = Abort.toDefault! (handler_1778 default x) thunk handle (thunk ()) with h -fix_1778 = +fix_1778 = '(let abort 0) |> Abort.toOptional @@ -91,19 +90,19 @@ fix_1536 = 'let fix_2271 : Doc2 fix_2271 = {{ # Full doc body indented - + ``` raw - myVal1 = 42 + myVal1 = 42 myVal2 = 43 myVal4 = 44 ``` - + ``` raw indented1= "hi" indented2="this is two indents" ``` - - I am two spaces over + + I am two spaces over }} @@ -128,7 +127,7 @@ somethingVeryLong = let nested_fences : Doc2 nested_fences = {{ ```` raw - ```unison + ``` unison r = "boopydoo" ``` ```` }} @@ -156,7 +155,7 @@ fix_525_exampleTerm quaffle = Fix_525.bar.quaffle + 1 -- This demonstrates the same thing for types. -- exampleType's signature locally binds the 'qualifiedName' type parameter, --- so the pretty-printer should use the longer name 'Fully.qualifiedName' +-- so the pretty-printer should use the longer name 'Fully.qualifiedName' structural type Fully.qualifiedName = Dontcare () Nat structural type Id a = Id a @@ -166,10 +165,10 @@ fix_525_exampleType z = Id (Dontcare () 19) -- We'd get a type error if `exampleTerm` or `exampleType` didn't round-trip, but it typechecks okay! --- Use clauses can't introduce shadowing +-- Use clauses can't introduce shadowing use_clauses_example : Int -> Text -> Nat -use_clauses_example oo quaffle = +use_clauses_example oo quaffle = Fix_525.bar.quaffle + Fix_525.bar.quaffle + 1 use_clauses_example2 : Int -> Nat @@ -193,29 +192,29 @@ Foo'.bar.qux2 = "45" Foo.bar.qux3 = 46 Foo'.bar.qux3 = "47" -ex1 = +ex1 = a = Foo.bar.qux3 + Foo.bar.qux3 Foo.bar.qux1 + Foo.bar.qux1 + Foo.bar.qux2 -ex2 = - a = +ex2 = + a = -- use Foo.bar qux3 will get pushed in here since it's already a multiline block z = 203993 Foo.bar.qux3 + Foo.bar.qux3 Foo.bar.qux1 + Foo.bar.qux1 + Foo.bar.qux2 -ex3 = +ex3 = a = do -- use clause gets pushed in here x = Foo.bar.qux3 + Foo.bar.qux3 x + x () -ex3a = +ex3a = a = do Foo.bar.qux3 + Foo.bar.qux3 -- use clause will get pulled up to top level () --- Make sure use clauses don't show up before a soft hang +-- Make sure use clauses don't show up before a soft hang -- Regression test for https://github.com/unisonweb/unison/issues/3883 structural type UUID = UUID Nat (Nat, Nat) @@ -249,7 +248,7 @@ raw_d = """ """ --- Fix for wonky treatment of abilities with multi-segment constructor names +-- Fix for wonky treatment of abilities with multi-segment constructor names -- Regression test for https://github.com/unisonweb/unison/issues/3239 structural ability Zoink where @@ -387,14 +386,14 @@ softhang21a = handle { a } -> "lskdfjlaksjdf al;ksdjf;lkj sa;sldkfja;sldfkj a;lsdkfj asd;lfkj " { Abort.abort -> _ } -> "lskdfjlaksjdf al;ksdjf;lkj sa;sldkfja;sldfkj a;lsdkfj asd;lfkj " -softhang2 x f = 0 +softhang2 x f = 0 softhang22 = softhang2 [0,1,2,3,4,5] cases 0 -> 0 1 -> 1 n -> n + 100 -catchAll x = +catchAll x = 99 softhang23 = do @@ -416,13 +415,13 @@ softhang26 = softhang2 [1,2,3,4] cases 0 -> 1 n -> n + 1 -forkAt loc c = +forkAt loc c = x = 99 - 390439034 + 390439034 softhang27 somewhere = forkAt somewhere do x = 1 - y = 2 + y = 2 x + y softhang28 = softhang2 [0,1,2,3,4,5] cases @@ -432,13 +431,13 @@ softhang28 = softhang2 [0,1,2,3,4,5] cases -- Weirdness reported by Stew with super long lines -longlines x = +longlines x = u = 92393 x longlines_helper x = do x -longlines1 = do +longlines1 = do longlines !(longlines_helper "This has to laksdjf alsdkfj alskdjf asdf be a long enough string to force a line break") longlines2 = @@ -456,7 +455,7 @@ test3 = do -- Regression test for https://github.com/unisonweb/unison/issues/4239 -- `n` was replaced by `error` but should not be. Instead, render as if --- a second param, _, had been provided in the definition. +-- a second param, _, had been provided in the definition. (>>>>) : Nat -> Nat -> () (>>>>) n = cases _ -> bug "" @@ -472,11 +471,11 @@ fix_4352 = {{``+1``}} -- regression test to make sure we don't use soft hang between a `do` and `match` -- if there's imports that have been inserted there -structural ability Ask a where - ask : a +structural ability Ask a where + ask : a Decode.remainder : '{Ask (Optional Bytes)} Bytes -Decode.remainder = do +Decode.remainder = do use Bytes ++ match ask with None -> Bytes.empty @@ -488,7 +487,7 @@ fix_4340 = HandlerWebSocket cases 1 -> "hi sdflkj sdlfkjsdflkj sldfkj sldkfj sdf asdlkfjs dlfkj sldfkj sdf" _ -> abort -fix_4258 x y z = +fix_4258 x y z = _ = "fix_4258" () @@ -497,26 +496,26 @@ fix_4258_example = fix_4258 1 () 2 -- previously, lexer was emitting virtual semicolons inside parens, which -- led to some very odd parse errors in cases like these -stew_issue = +stew_issue = error x = () (++) a b = 0 toText a = a Debug : a -> b -> () Debug a b = () error - (Debug None '(Debug "Failed " -- virtual semicolon here was tripping up parser + (Debug None '(Debug "Failed " -- virtual semicolon here was tripping up parser 42)) -stew_issue2 = +stew_issue2 = error x = () (++) a b = 0 toText a = a Debug : a -> b -> () Debug a b = () error - (Debug None '("Failed " ++ + (Debug None '("Failed " ++ toText 42)) -stew_issue3 = +stew_issue3 = id x = x error x = () (++) a b = 0 @@ -525,7 +524,7 @@ stew_issue3 = configPath = 0 Debug a b = () error - (Debug None '("Failed to get timestamp of config file " ++ + (Debug None '("Failed to get timestamp of config file " ++ toText configPath)) fix_4384 = {{ {{ docExampleBlock 0 do 2 }} }} @@ -539,7 +538,90 @@ fix_4384c = {{ {{ docExampleBlock 0 do fix_4384d = {{ {{ docExampleBlock 0 '[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18] }} }} -fix_4384e = +fix_4384e = id : x -> x id x = x - {{ {{ docExampleBlock 0 (id id id id id id id id id id id id id id id id id id id id id (x -> 0) }} }} \ No newline at end of file + {{ {{ docExampleBlock 0 (id id id id id id id id id id id id id id id id id id id id id (x -> 0)) }} }} + +fnApplicationSyntax = + Environment.default = do 1 + 1 + oog = do 2 + 2 + blah : Nat -> Float -> Nat + blah x y = x + 1 + _ = blah Environment.default() 1.0 + blah oog() (Float.max 1.0 2.0) + +fix_4727 = {{ `` 0xs900dc0ffee `` }} + +fix_4729a = {{ + # H1A + + ## H2A + + ``` + {{ + # H1B + + ## B2B + }} + ``` + + ## H2A +}} + +fix_4729b = {{ + # H1A + + ## H2A + + {{ docTable [ + [ {{ # HA }}, {{ # HB }} ], + [ {{ ## a }}, {{ ## b }} ] + ] }} + + ## H2A +}} + +fix_4729c = {{ + # Examples + ``` + docCallout + (Some + {{ + # Title + + }}) {{ This is a callout with a title }} + ``` +}} + +fixity = do + (===) = (##Universal.==) + (<|) f x = f x + (<<) f g x = f (g x) + (>>) f g x = g (f x) + id x = x + (do + (%) = Nat.mod + ($) = (Nat.+) + c = 1 * (2 + 3) * 4 + plus = 1 Nat.+ 2 Nat.+ 3 + plus2 = 1 Nat.+ (2 Nat.+ 3) + d = true && let false || true + z = true || false && true + e = 1 + 2 >= (3 + 4) + f = 9 % 2 === 0 + g = 0 == (9 % 2) + h = 2 * (10 $ 20) + i1 = 1 * 2 $ (3 * 4) $ 5 + i2 = 1 * 2 $ 3 * 4 $ 5 + oo = (((2 * 10) $ 20) * 30) $ 40 + ffffffffffffffffffff x = x + 1 + gg x = x * 2 + j = 10 |> ffffffffffffffffffff |> gg |> gg |> gg |> gg |> gg + k = ffffffffffffffffffff << gg << ffffffffffffffffffff <| 10 + l = 10 |> (ffffffffffffffffffff >> gg >> ffffffffffffffffffff) + zzz = ((1 + (2 * 3)) < (4 + (5 * 6))) && ((((7 + (8 * 9)) > ((10 + (11 * 12)))))) + zz = (1 * 2 + 3 * 3 < (4 + 5 * 6) && ((7 + 8 * 9) > (10 + 11 * 12))) === (1 + 3 * 3 < (4 + 5 * 6) && (7 + 8 * 9 > (10 + 11 * 12))) + zzzz = 1 * 2 + 3 * 3 < 4 + 5 * 6 && 7 + 8 * 9 > 10 + 11 * 12 === 1 + 3 * 3 < 4 + 5 * 6 && 7 + 8 * 9 > 10 + 11 * 12 + () + ) |> id diff --git a/unison-src/transcripts-using-base/_base.md b/unison-src/transcripts-using-base/_base.md index 1befbcb2e9..9ce21e6118 100644 --- a/unison-src/transcripts-using-base/_base.md +++ b/unison-src/transcripts-using-base/_base.md @@ -9,28 +9,28 @@ transcripts which contain less boilerplate. ## Usage -```ucm:hide -.> builtins.mergeio -.> load unison-src/transcripts-using-base/base.u -.> add +``` ucm :hide +scratch/main> builtins.mergeio +scratch/main> load unison-src/transcripts-using-base/base.u +scratch/main> add ``` The test shows that `hex (fromHex str) == str` as expected. -```unison:hide +``` unison :hide test> hex.tests.ex1 = checks let s = "3984af9b" [hex (fromHex s) == s] ``` -```ucm:hide -.> test +``` ucm :hide +scratch/main> test ``` Lets do some basic testing of our test harness to make sure its working. -```unison +``` unison testAutoClean : '{io2.IO}[Result] testAutoClean _ = go: '{Stream Result, Exception, io2.IO, TempDirs} Text @@ -49,7 +49,7 @@ testAutoClean _ = Left (Failure _ t _) -> results :+ (Fail t) ``` -```ucm -.> add -.> io.test testAutoClean +``` ucm +scratch/main> add +scratch/main> io.test testAutoClean ``` diff --git a/unison-src/transcripts-using-base/_base.output.md b/unison-src/transcripts-using-base/_base.output.md index eeaebe564c..52910967b2 100644 --- a/unison-src/transcripts-using-base/_base.output.md +++ b/unison-src/transcripts-using-base/_base.output.md @@ -9,18 +9,30 @@ transcripts which contain less boilerplate. ## Usage +``` ucm :hide +scratch/main> builtins.mergeio + +scratch/main> load unison-src/transcripts-using-base/base.u + +scratch/main> add +``` + The test shows that `hex (fromHex str) == str` as expected. -```unison +``` unison :hide test> hex.tests.ex1 = checks let s = "3984af9b" [hex (fromHex s) == s] ``` +``` ucm :hide +scratch/main> test +``` + Lets do some basic testing of our test harness to make sure its working. -```unison +``` unison testAutoClean : '{io2.IO}[Result] testAutoClean _ = go: '{Stream Result, Exception, io2.IO, TempDirs} Text @@ -39,35 +51,33 @@ testAutoClean _ = Left (Failure _ t _) -> results :+ (Fail t) ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: testAutoClean : '{IO} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + testAutoClean : '{IO} [Result] -.> io.test testAutoClean +scratch/main> io.test testAutoClean New test results: - - ◉ testAutoClean our temporary directory should exist - ◉ testAutoClean our temporary directory should no longer exist - + + 1. testAutoClean ◉ our temporary directory should exist + ◉ our temporary directory should no longer exist + ✅ 2 test(s) passing - - Tip: Use view testAutoClean to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/all-base-hashes.md b/unison-src/transcripts-using-base/all-base-hashes.md index d7050cb774..57baf3d629 100644 --- a/unison-src/transcripts-using-base/all-base-hashes.md +++ b/unison-src/transcripts-using-base/all-base-hashes.md @@ -1,5 +1,5 @@ This transcript is intended to make visible accidental changes to the hashing algorithm. -```ucm -.> find.verbose +``` ucm +scratch/main> find.verbose ``` diff --git a/unison-src/transcripts-using-base/all-base-hashes.output.md b/unison-src/transcripts-using-base/all-base-hashes.output.md index 63c258e137..d60d5ae872 100644 --- a/unison-src/transcripts-using-base/all-base-hashes.output.md +++ b/unison-src/transcripts-using-base/all-base-hashes.output.md @@ -1,7 +1,7 @@ This transcript is intended to make visible accidental changes to the hashing algorithm. -```ucm -.> find.verbose +``` ucm +scratch/main> find.verbose 1. -- #sgesq8035ut22q779pl1g4gqsg8c81894jjonmrq1bjltphkath225up841hk8dku59tnnc4laj9nggbofamgei4klof0ldc20uj2oo <| : (i ->{g} o) -> i ->{g} o @@ -2982,6 +2982,4 @@ This transcript is intended to make visible accidental changes to the hashing al 855. -- #lcmj2envm11lrflvvcl290lplhvbccv82utoej0lg0eomhmsf2vrv8af17k6if7ff98fp1b13rkseng3fng4stlr495c8dn3gn4k400 |> : a -> (a ->{g} t) ->{g} t - - ``` diff --git a/unison-src/transcripts-using-base/binary-encoding-nats.md b/unison-src/transcripts-using-base/binary-encoding-nats.md index 711bcb3300..0cd604c8e4 100644 --- a/unison-src/transcripts-using-base/binary-encoding-nats.md +++ b/unison-src/transcripts-using-base/binary-encoding-nats.md @@ -1,4 +1,4 @@ -```unison +``` unison unique type EncDec = EncDec Text (Nat -> Bytes) (Bytes -> Optional (Nat, Bytes)) BE64 = EncDec "64 bit Big Endian" encodeNat64be decodeNat64be @@ -53,7 +53,7 @@ testABunchOfNats _ = (runTest (testNat 0)) ``` -```ucm -.> add -.> io.test testABunchOfNats +``` ucm +scratch/main> add +scratch/main> io.test testABunchOfNats ``` diff --git a/unison-src/transcripts-using-base/binary-encoding-nats.output.md b/unison-src/transcripts-using-base/binary-encoding-nats.output.md index 0227ff8e25..e9c27c3b8f 100644 --- a/unison-src/transcripts-using-base/binary-encoding-nats.output.md +++ b/unison-src/transcripts-using-base/binary-encoding-nats.output.md @@ -1,4 +1,4 @@ -```unison +``` unison unique type EncDec = EncDec Text (Nat -> Bytes) (Bytes -> Optional (Nat, Bytes)) BE64 = EncDec "64 bit Big Endian" encodeNat64be decodeNat64be @@ -53,14 +53,13 @@ testABunchOfNats _ = (runTest (testNat 0)) ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: type EncDec @@ -73,13 +72,13 @@ testABunchOfNats _ = testABunchOfNats : ∀ _. _ ->{IO} [Result] testNat : Nat -> '{IO, Stream Result} () testRoundTrip : Nat -> EncDec ->{IO, Stream Result} () - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + type EncDec BE16 : EncDec BE32 : EncDec @@ -91,81 +90,80 @@ testABunchOfNats _ = testNat : Nat -> '{IO, Stream Result} () testRoundTrip : Nat -> EncDec ->{IO, Stream Result} () -.> io.test testABunchOfNats +scratch/main> io.test testABunchOfNats New test results: - - ◉ testABunchOfNats successfully decoded 4294967295 using 64 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 4294967295 using 64 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 4294967295 using 32 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 4294967295 using 32 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 1090519040 using 64 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 1090519040 using 64 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 1090519040 using 32 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 1090519040 using 32 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 4259840 using 64 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 4259840 using 64 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 4259840 using 32 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 4259840 using 32 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 16640 using 64 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 16640 using 64 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 16640 using 32 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 16640 using 32 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 16640 using 16 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 16640 using 16 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 2255827097 using 64 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 2255827097 using 64 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 2255827097 using 32 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 2255827097 using 32 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 65 using 64 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 65 using 64 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 65 using 32 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 65 using 32 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 65 using 16 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 65 using 16 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 0 using 64 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 0 using 64 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 0 using 32 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 0 using 32 bit Little Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 0 using 16 bit Big Endian - ◉ testABunchOfNats consumed all input - ◉ testABunchOfNats successfully decoded 0 using 16 bit Little Endian - ◉ testABunchOfNats consumed all input - + + 1. testABunchOfNats ◉ successfully decoded 4294967295 using 64 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 4294967295 using 64 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 4294967295 using 32 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 4294967295 using 32 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 1090519040 using 64 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 1090519040 using 64 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 1090519040 using 32 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 1090519040 using 32 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 4259840 using 64 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 4259840 using 64 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 4259840 using 32 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 4259840 using 32 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 16640 using 64 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 16640 using 64 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 16640 using 32 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 16640 using 32 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 16640 using 16 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 16640 using 16 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 2255827097 using 64 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 2255827097 using 64 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 2255827097 using 32 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 2255827097 using 32 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 65 using 64 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 65 using 64 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 65 using 32 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 65 using 32 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 65 using 16 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 65 using 16 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 0 using 64 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 0 using 64 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 0 using 32 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 0 using 32 bit Little Endian + ◉ consumed all input + ◉ successfully decoded 0 using 16 bit Big Endian + ◉ consumed all input + ◉ successfully decoded 0 using 16 bit Little Endian + ◉ consumed all input + ✅ 68 test(s) passing - - Tip: Use view testABunchOfNats to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/codeops.md b/unison-src/transcripts-using-base/codeops.md index 4754eb0aaf..5b6bfaf28e 100644 --- a/unison-src/transcripts-using-base/codeops.md +++ b/unison-src/transcripts-using-base/codeops.md @@ -1,10 +1,9 @@ - Test for code serialization operations. Define a function, serialize it, then deserialize it back to an actual function. Also ask for its dependencies for display later. -```unison +``` unison save : a -> Bytes save x = Value.serialize (Value.value x) @@ -152,11 +151,11 @@ swapped name link = rejected ("swapped " ++ name) rco ``` -```ucm -.> add +``` ucm +scratch/main> add ``` -```unison +``` unison structural ability Zap where zap : Three Nat Nat Nat @@ -235,13 +234,13 @@ This simply runs some functions to make sure there isn't a crash. Once we gain the ability to capture output in a transcript, it can be modified to actual show that the serialization works. -```ucm -.> add -.> io.test tests -.> io.test badLoad +``` ucm +scratch/main> add +scratch/main> io.test tests +scratch/main> io.test badLoad ``` -```unison +``` unison codeTests : '{io2.IO} [Result] codeTests = '[ idempotence "idem f" (termLink f) @@ -277,12 +276,12 @@ codeTests = ] ``` -```ucm -.> add -.> io.test codeTests +``` ucm +scratch/main> add +scratch/main> io.test codeTests ``` -```unison +``` unison validateTest : Link.Term ->{IO} Result validateTest l = match Code.lookup l with None -> Fail "Couldn't look up link" @@ -308,7 +307,7 @@ vtests _ = ] ``` -```ucm -.> add -.> io.test vtests +``` ucm +scratch/main> add +scratch/main> io.test vtests ``` diff --git a/unison-src/transcripts-using-base/codeops.output.md b/unison-src/transcripts-using-base/codeops.output.md index 3f76560f4a..fa807df00f 100644 --- a/unison-src/transcripts-using-base/codeops.output.md +++ b/unison-src/transcripts-using-base/codeops.output.md @@ -1,10 +1,9 @@ - Test for code serialization operations. Define a function, serialize it, then deserialize it back to an actual function. Also ask for its dependencies for display later. -```unison +``` unison save : a -> Bytes save x = Value.serialize (Value.value x) @@ -152,14 +151,13 @@ swapped name link = rejected ("swapped " ++ name) rco ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: structural type Three a b c @@ -197,13 +195,13 @@ swapped name link = verify : Text -> [(Link.Term, Code)] ->{Throw Text} () - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + structural type Three a b c Code.get : Link.Term ->{IO, Throw Text} Code Code.load : Bytes ->{IO, Throw Text} Code @@ -239,9 +237,9 @@ swapped name link = verify : Text -> [(Link.Term, Code)] ->{Throw Text} () - ``` -```unison + +``` unison structural ability Zap where zap : Three Nat Nat Nat @@ -316,14 +314,13 @@ badLoad _ = Left _ -> [Fail "Exception"] ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: structural ability Zap @@ -337,17 +334,17 @@ badLoad _ = rotate : Three Nat Nat Nat -> Three Nat Nat Nat tests : '{IO} [Result] zapper : Three Nat Nat Nat -> Request {Zap} r -> r - ``` + This simply runs some functions to make sure there isn't a crash. Once we gain the ability to capture output in a transcript, it can be modified to actual show that the serialization works. -```ucm -.> add +``` ucm +scratch/main> add ⍟ I've added these definitions: - + structural ability Zap badLoad : '{IO} [Result] bigFun : Nat -> Nat -> Nat -> Nat @@ -360,40 +357,40 @@ to actual show that the serialization works. tests : '{IO} [Result] zapper : Three Nat Nat Nat -> Request {Zap} r -> r -.> io.test tests +scratch/main> io.test tests New test results: - - ◉ tests (ext f) passed - ◉ tests (ext h) passed - ◉ tests (ident compound) passed - ◉ tests (ident fib10) passed - ◉ tests (ident effect) passed - ◉ tests (ident zero) passed - ◉ tests (ident h) passed - ◉ tests (ident text) passed - ◉ tests (ident int) passed - ◉ tests (ident float) passed - ◉ tests (ident termlink) passed - ◉ tests (ident bool) passed - ◉ tests (ident bytes) passed - + + 1. tests ◉ (ext f) passed + ◉ (ext h) passed + ◉ (ident compound) passed + ◉ (ident fib10) passed + ◉ (ident effect) passed + ◉ (ident zero) passed + ◉ (ident h) passed + ◉ (ident text) passed + ◉ (ident int) passed + ◉ (ident float) passed + ◉ (ident termlink) passed + ◉ (ident bool) passed + ◉ (ident bytes) passed + ✅ 13 test(s) passing - - Tip: Use view tests to view the source of a test. -.> io.test badLoad + Tip: Use view 1 to view the source of a test. + +scratch/main> io.test badLoad New test results: - - ◉ badLoad serialized77 - + + 1. badLoad ◉ serialized77 + ✅ 1 test(s) passing - - Tip: Use view badLoad to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` -```unison + +``` unison codeTests : '{io2.IO} [Result] codeTests = '[ idempotence "idem f" (termLink f) @@ -429,67 +426,66 @@ codeTests = ] ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: codeTests : '{IO} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + codeTests : '{IO} [Result] -.> io.test codeTests +scratch/main> io.test codeTests New test results: - - ◉ codeTests (idem f) passed - ◉ codeTests (idem h) passed - ◉ codeTests (idem rotate) passed - ◉ codeTests (idem zapper) passed - ◉ codeTests (idem showThree) passed - ◉ codeTests (idem concatMap) passed - ◉ codeTests (idem big) passed - ◉ codeTests (idem extensionality) passed - ◉ codeTests (idem identicality) passed - ◉ codeTests (verified f) passed - ◉ codeTests (verified h) passed - ◉ codeTests (verified rotate) passed - ◉ codeTests (verified zapper) passed - ◉ codeTests (verified showThree) passed - ◉ codeTests (verified concatMap) passed - ◉ codeTests (verified big) passed - ◉ codeTests (verified extensionality) passed - ◉ codeTests (verified identicality) passed - ◉ codeTests (verified mutual0) passed - ◉ codeTests (verified mutual1) passed - ◉ codeTests (verified mutual2) passed - ◉ codeTests (rejected missing mutual0) passed - ◉ codeTests (rejected missing mutual1) passed - ◉ codeTests (rejected missing mutual2) passed - ◉ codeTests (rejected swapped zapper) passed - ◉ codeTests (rejected swapped extensionality) passed - ◉ codeTests (rejected swapped identicality) passed - ◉ codeTests (rejected swapped mututal0) passed - ◉ codeTests (rejected swapped mututal1) passed - ◉ codeTests (rejected swapped mututal2) passed - + + 1. codeTests ◉ (idem f) passed + ◉ (idem h) passed + ◉ (idem rotate) passed + ◉ (idem zapper) passed + ◉ (idem showThree) passed + ◉ (idem concatMap) passed + ◉ (idem big) passed + ◉ (idem extensionality) passed + ◉ (idem identicality) passed + ◉ (verified f) passed + ◉ (verified h) passed + ◉ (verified rotate) passed + ◉ (verified zapper) passed + ◉ (verified showThree) passed + ◉ (verified concatMap) passed + ◉ (verified big) passed + ◉ (verified extensionality) passed + ◉ (verified identicality) passed + ◉ (verified mutual0) passed + ◉ (verified mutual1) passed + ◉ (verified mutual2) passed + ◉ (rejected missing mutual0) passed + ◉ (rejected missing mutual1) passed + ◉ (rejected missing mutual2) passed + ◉ (rejected swapped zapper) passed + ◉ (rejected swapped extensionality) passed + ◉ (rejected swapped identicality) passed + ◉ (rejected swapped mututal0) passed + ◉ (rejected swapped mututal1) passed + ◉ (rejected swapped mututal2) passed + ✅ 30 test(s) passing - - Tip: Use view codeTests to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` -```unison + +``` unison validateTest : Link.Term ->{IO} Result validateTest l = match Code.lookup l with None -> Fail "Couldn't look up link" @@ -515,43 +511,41 @@ vtests _ = ] ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: validateTest : Link.Term ->{IO} Result vtests : '{IO} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + validateTest : Link.Term ->{IO} Result vtests : '{IO} [Result] -.> io.test vtests +scratch/main> io.test vtests New test results: - - ◉ vtests validated - ◉ vtests validated - ◉ vtests validated - ◉ vtests validated - ◉ vtests validated - ◉ vtests validated - ◉ vtests validated - ◉ vtests validated - + + 1. vtests ◉ validated + ◉ validated + ◉ validated + ◉ validated + ◉ validated + ◉ validated + ◉ validated + ◉ validated + ✅ 8 test(s) passing - - Tip: Use view vtests to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/doc.md b/unison-src/transcripts-using-base/doc.md index 461a4f04bb..d80e60ce58 100644 --- a/unison-src/transcripts-using-base/doc.md +++ b/unison-src/transcripts-using-base/doc.md @@ -13,7 +13,7 @@ Unison documentation is written in Unison and has some neat features: Documentation blocks start with `{{` and end with a matching `}}`. You can introduce doc blocks anywhere you'd use an expression, and you can also have anonymous documentation blocks immediately before a top-level term or type. -```unison +``` unison name = {{Alice}} d1 = {{ Hello there {{name}}! }} @@ -32,10 +32,10 @@ Notice that an anonymous documentation block `{{ ... }}` before a definition `Im You can preview what docs will look like when rendered to the console using the `display` or `docs` commands: -```ucm -.> display d1 -.> docs ImportantConstant -.> docs DayOfWeek +``` ucm +scratch/main> display d1 +scratch/main> docs ImportantConstant +scratch/main> docs DayOfWeek ``` The `docs ImportantConstant` command will look for `ImportantConstant.doc` in the file or codebase. You can do this instead of explicitly linking docs to definitions. @@ -44,38 +44,38 @@ The `docs ImportantConstant` command will look for `ImportantConstant.doc` in th First, we'll load the `syntax.u` file which has examples of all the syntax: -```ucm -.> load ./unison-src/transcripts-using-base/doc.md.files/syntax.u +``` ucm +scratch/main> load ./unison-src/transcripts-using-base/doc.md.files/syntax.u ``` -```ucm:hide -.> add +``` ucm :hide +scratch/main> add ``` Now we can review different portions of the guide. we'll show both the pretty-printed source using `view` and the rendered output using `display`: -```ucm -.> view basicFormatting -.> display basicFormatting -.> view lists -.> display lists -.> view evaluation -.> display evaluation -.> view includingSource -.> display includingSource -.> view nonUnisonCodeBlocks -.> display nonUnisonCodeBlocks -.> view otherElements -.> display otherElements +``` ucm +scratch/main> view basicFormatting +scratch/main> display basicFormatting +scratch/main> view lists +scratch/main> display lists +scratch/main> view evaluation +scratch/main> display evaluation +scratch/main> view includingSource +scratch/main> display includingSource +scratch/main> view nonUnisonCodeBlocks +scratch/main> display nonUnisonCodeBlocks +scratch/main> view otherElements +scratch/main> display otherElements ``` Lastly, it's common to build longer documents including subdocuments via `{{ subdoc }}`. We can stitch together the full syntax guide in this way: -```ucm -.> view doc.guide -.> display doc.guide +``` ucm +scratch/main> view doc.guide +scratch/main> display doc.guide ``` 🌻 THE END diff --git a/unison-src/transcripts-using-base/doc.output.md b/unison-src/transcripts-using-base/doc.output.md index 43edad9881..aca445303c 100644 --- a/unison-src/transcripts-using-base/doc.output.md +++ b/unison-src/transcripts-using-base/doc.output.md @@ -2,18 +2,18 @@ Unison documentation is written in Unison and has some neat features: -* The documentation type provides a rich vocabulary of elements that go beyond markdown, including asides, callouts, tooltips, and more. -* Docs may contain Unison code which is parsed and typechecked to ensure validity. No more out of date examples that don't compile or assume a bunch of implicit context! -* Embeded examples are live and can show the results of evaluation. This uses the same evaluation cache as Unison's scratch files, allowing Unison docs to function like well-commented spreadsheets or notebooks. -* Links to other definitions are typechecked to ensure they point to valid definitions. The links are resolved to hashes and won't be broken by name changes or moving definitions around. -* Docs can be included in other docs and you can assemble documentation programmatically, using Unison code. -* There's a powerful textual syntax for all of the above, which we'll introduce next. + - The documentation type provides a rich vocabulary of elements that go beyond markdown, including asides, callouts, tooltips, and more. + - Docs may contain Unison code which is parsed and typechecked to ensure validity. No more out of date examples that don't compile or assume a bunch of implicit context\! + - Embeded examples are live and can show the results of evaluation. This uses the same evaluation cache as Unison's scratch files, allowing Unison docs to function like well-commented spreadsheets or notebooks. + - Links to other definitions are typechecked to ensure they point to valid definitions. The links are resolved to hashes and won't be broken by name changes or moving definitions around. + - Docs can be included in other docs and you can assemble documentation programmatically, using Unison code. + - There's a powerful textual syntax for all of the above, which we'll introduce next. ## Introduction Documentation blocks start with `{{` and end with a matching `}}`. You can introduce doc blocks anywhere you'd use an expression, and you can also have anonymous documentation blocks immediately before a top-level term or type. -```unison +``` unison name = {{Alice}} d1 = {{ Hello there {{name}}! }} @@ -28,14 +28,13 @@ The 7 days of the week, defined as: unique type time.DayOfWeek = Sun | Mon | Tue | Wed | Thu | Fri | Sat ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: type time.DayOfWeek @@ -44,36 +43,36 @@ unique type time.DayOfWeek = Sun | Mon | Tue | Wed | Thu | Fri | Sat d1 : Doc2 name : Doc2 time.DayOfWeek.doc : Doc2 - ``` + Notice that an anonymous documentation block `{{ ... }}` before a definition `ImportantConstant` is just syntax sugar for `ImportantConstant.doc = {{ ... }}`. You can preview what docs will look like when rendered to the console using the `display` or `docs` commands: -```ucm -.> display d1 +``` ucm +scratch/main> display d1 Hello there Alice! -.> docs ImportantConstant +scratch/main> docs ImportantConstant An important constant, equal to `42` -.> docs DayOfWeek +scratch/main> docs DayOfWeek The 7 days of the week, defined as: - - type DayOfWeek = Sun | Mon | Tue | Wed | Thu | Fri | Sat + type DayOfWeek = Sun | Mon | Tue | Wed | Thu | Fri | Sat ``` + The `docs ImportantConstant` command will look for `ImportantConstant.doc` in the file or codebase. You can do this instead of explicitly linking docs to definitions. ## Syntax guide First, we'll load the `syntax.u` file which has examples of all the syntax: -```ucm -.> load ./unison-src/transcripts-using-base/doc.md.files/syntax.u +``` ucm +scratch/main> load ./unison-src/transcripts-using-base/doc.md.files/syntax.u Loading changes detected in ./unison-src/transcripts-using-base/doc.md.files/syntax.u. @@ -82,7 +81,7 @@ First, we'll load the `syntax.u` file which has examples of all the syntax: ./unison-src/transcripts-using-base/doc.md.files/syntax.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: basicFormatting : Doc2 @@ -93,14 +92,18 @@ First, we'll load the `syntax.u` file which has examples of all the syntax: nonUnisonCodeBlocks : Doc2 otherElements : Doc2 sqr : Nat -> Nat +``` +``` ucm :hide +scratch/main> add ``` + Now we can review different portions of the guide. we'll show both the pretty-printed source using `view` and the rendered output using `display`: -```ucm -.> view basicFormatting +```` ucm +scratch/main> view basicFormatting basicFormatting : Doc2 basicFormatting = @@ -130,32 +133,32 @@ and the rendered output using `display`: __Next up:__ {lists} }} -.> display basicFormatting +scratch/main> display basicFormatting # Basic formatting - + Paragraphs are separated by one or more blanklines. Sections have a title and 0 or more paragraphs or other section elements. - + Text can be bold, *italicized*, ~~strikethrough~~, or `monospaced` (or `monospaced`). - + You can link to Unison terms, types, and external URLs: - + * An external url * Some is a term link; Optional is a type link * A named type link and a named term link. Term links are handy for linking to other documents! - + You can use `{{ .. }}` to escape out to regular Unison syntax, for instance __not bold__. This is useful for creating documents programmatically or just including other documents. - + *Next up:* lists -.> view lists +scratch/main> view lists lists : Doc2 lists = @@ -198,10 +201,10 @@ and the rendered output using `display`: 3. Get dressed. }} -.> display lists +scratch/main> display lists # Lists - + # Bulleted lists Bulleted lists can use `+`, `-`, or `*` for the bullets @@ -213,7 +216,7 @@ and the rendered output using `display`: * C * C1 * C2 - + # Numbered lists 1. A @@ -237,7 +240,7 @@ and the rendered output using `display`: 2. Take shower. 3. Get dressed. -.> view evaluation +scratch/main> view evaluation evaluation : Doc2 evaluation = @@ -272,35 +275,35 @@ and the rendered output using `display`: ``` }} -.> display evaluation +scratch/main> display evaluation # Evaluation - + Expressions can be evaluated inline, for instance `2`. - + Blocks of code can be evaluated as well, for instance: - + id x = x id (sqr 10) ⧨ 100 - + also: - + match 1 with 1 -> "hi" _ -> "goodbye" ⧨ "hi" - + To include a typechecked snippet of code without evaluating it, you can do: - + use Nat * cube : Nat -> Nat cube x = x * x * x -.> view includingSource +scratch/main> view includingSource includingSource : Doc2 includingSource = @@ -341,40 +344,40 @@ and the rendered output using `display`: {{ docExample 1 do x -> sqr x }}. }} -.> display includingSource +scratch/main> display includingSource # Including Unison source code - + Unison definitions can be included in docs. For instance: - + structural type Optional a = Some a | None sqr : Nat -> Nat sqr x = use Nat * x * x - + Some rendering targets also support folded source: - + structural type Optional a = Some a | None sqr : Nat -> Nat sqr x = use Nat * x * x - + You can also include just a signature, inline, with `sqr : Nat -> Nat`, or you can include one or more signatures as a block: - + sqr : Nat -> Nat Nat.+ : Nat -> Nat -> Nat - + Or alternately: - + List.map : (a ->{e} b) -> [a] ->{e} [b] - + # Inline snippets You can include typechecked code snippets inline, for @@ -387,7 +390,7 @@ and the rendered output using `display`: application, you can put it in double backticks, like so: `sqr x`. This is equivalent to `sqr x`. -.> view nonUnisonCodeBlocks +scratch/main> view nonUnisonCodeBlocks nonUnisonCodeBlocks : Doc2 nonUnisonCodeBlocks = @@ -420,13 +423,13 @@ and the rendered output using `display`: ``` }} -.> display nonUnisonCodeBlocks +scratch/main> display nonUnisonCodeBlocks # Non-Unison code blocks - + Use three or more single quotes to start a block with no syntax highlighting: - + ``` raw _____ _ | | |___|_|___ ___ ___ @@ -434,22 +437,22 @@ and the rendered output using `display`: |_____|_|_|_|___|___|_|_| ``` - + You can use three or more backticks plus a language name for blocks with syntax highlighting: - + ``` Haskell -- A fenced code block which isn't parsed by Unison reverse = foldl (flip (:)) [] ``` - + ``` Scala // A fenced code block which isn't parsed by Unison def reverse[A](xs: List[A]) = xs.foldLeft(Nil : List[A])((acc,a) => a +: acc) ``` -.> view otherElements +scratch/main> view otherElements otherElements : Doc2 otherElements = @@ -506,50 +509,50 @@ and the rendered output using `display`: ] }} }} -.> display otherElements +scratch/main> display otherElements There are also asides, callouts, tables, tooltips, and more. These don't currently have special syntax; just use the `{{ }}` syntax to call these functions directly. - + docAside : Doc2 -> Doc2 - + docCallout : Optional Doc2 -> Doc2 -> Doc2 - + docBlockquote : Doc2 -> Doc2 - + docTooltip : Doc2 -> Doc2 -> Doc2 - + docTable : [[Doc2]] -> Doc2 - + This is an aside. ( Some extra detail that doesn't belong in main text. ) - + | This is an important callout, with no icon. - + | 🌻 | | This is an important callout, with an icon. The text wraps | onto multiple lines. - + > "And what is the use of a book," thought Alice, "without > pictures or conversation?" > > *Lewis Carroll, Alice's Adventures in Wonderland* - + Hover over me - + a b A longer paragraph that will split onto multiple lines, such that this row occupies multiple lines in the rendered table. Some text More text Zounds! +```` -``` Lastly, it's common to build longer documents including subdocuments via `{{ subdoc }}`. We can stitch together the full syntax guide in this way: -```ucm -.> view doc.guide +```` ucm +scratch/main> view doc.guide doc.guide : Doc2 doc.guide = @@ -569,10 +572,10 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub {{ otherElements }} }} -.> display doc.guide +scratch/main> display doc.guide # Unison computable documentation - + # Basic formatting Paragraphs are separated by one or more blanklines. @@ -595,7 +598,7 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub other documents. *Next up:* lists - + # Lists # Bulleted lists @@ -632,7 +635,7 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub * In this nested list. 2. Take shower. 3. Get dressed. - + # Evaluation Expressions can be evaluated inline, for instance `2`. @@ -658,7 +661,7 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub use Nat * cube : Nat -> Nat cube x = x * x * x - + # Including Unison source code Unison definitions can be included in docs. For instance: @@ -702,7 +705,7 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub * If your snippet expression is just a single function application, you can put it in double backticks, like so: `sqr x`. This is equivalent to `sqr x`. - + # Non-Unison code blocks Use three or more single quotes to start a block with no @@ -729,7 +732,7 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub def reverse[A](xs: List[A]) = xs.foldLeft(Nil : List[A])((acc,a) => a +: acc) ``` - + There are also asides, callouts, tables, tooltips, and more. These don't currently have special syntax; just use the `{{ }}` syntax to call these functions directly. @@ -766,6 +769,6 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub row occupies multiple lines in the rendered table. Some text More text Zounds! +```` -``` 🌻 THE END diff --git a/unison-src/transcripts-using-base/failure-tests.md b/unison-src/transcripts-using-base/failure-tests.md index 049b4fcbb1..bb11bfc323 100644 --- a/unison-src/transcripts-using-base/failure-tests.md +++ b/unison-src/transcripts-using-base/failure-tests.md @@ -6,7 +6,7 @@ Exception ability directly, and the last is code validation. I don't have an easy way to test the last at the moment, but the other two are tested here. -```unison +``` unison test1 : '{IO, Exception} [Result] test1 = do _ = fromUtf8 0xsee @@ -18,14 +18,14 @@ test2 = do [Ok "test2"] ``` -```ucm -.> add +``` ucm +scratch/main> add ``` -```ucm:error -.> io.test test1 +``` ucm :error +scratch/main> io.test test1 ``` -```ucm:error -.> io.test test2 +``` ucm :error +scratch/main> io.test test2 ``` diff --git a/unison-src/transcripts-using-base/failure-tests.output.md b/unison-src/transcripts-using-base/failure-tests.output.md index d59d3d7bc8..5087b2d934 100644 --- a/unison-src/transcripts-using-base/failure-tests.output.md +++ b/unison-src/transcripts-using-base/failure-tests.output.md @@ -6,7 +6,7 @@ Exception ability directly, and the last is code validation. I don't have an easy way to test the last at the moment, but the other two are tested here. -```unison +``` unison test1 : '{IO, Exception} [Result] test1 = do _ = fromUtf8 0xsee @@ -18,55 +18,53 @@ test2 = do [Ok "test2"] ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: test1 : '{IO, Exception} [Result] test2 : '{IO, Exception} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + test1 : '{IO, Exception} [Result] test2 : '{IO, Exception} [Result] - ``` -```ucm -.> io.test test1 + +``` ucm :error +scratch/main> io.test test1 💔💥 - + The program halted with an unhandled exception: - + Failure (typeLink IOFailure) - "Cannot decode byte '\\xee': Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" + "Cannot decode byte '\\xee': Data.Text.Encoding: Invalid UTF-8 stream" (Any ()) - + Stack trace: ##raise - ``` -```ucm -.> io.test test2 + +``` ucm :error +scratch/main> io.test test2 💔💥 - + The program halted with an unhandled exception: - + Failure (typeLink RuntimeFailure) "builtin.bug" (Any "whoa") - + Stack trace: ##raise - ``` diff --git a/unison-src/transcripts-using-base/fix1709.md b/unison-src/transcripts-using-base/fix1709.md deleted file mode 100644 index bc254f3b24..0000000000 --- a/unison-src/transcripts-using-base/fix1709.md +++ /dev/null @@ -1,15 +0,0 @@ -```unison -id x = x - -id2 x = - z = 384849 - id x -``` - -```ucm -.scratch> add -``` - -```unison -> id2 "hi" -``` diff --git a/unison-src/transcripts-using-base/fix1709.output.md b/unison-src/transcripts-using-base/fix1709.output.md deleted file mode 100644 index 953121aa2c..0000000000 --- a/unison-src/transcripts-using-base/fix1709.output.md +++ /dev/null @@ -1,54 +0,0 @@ -```unison -id x = x - -id2 x = - z = 384849 - id x -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⊡ Previously added definitions will be ignored: id - - ⍟ These new definitions are ok to `add`: - - id2 : x -> x - -``` -```ucm - ☝️ The namespace .scratch is empty. - -.scratch> add - - ⍟ I've added these definitions: - - id : x -> x - id2 : x -> x - -``` -```unison -> id2 "hi" -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > id2 "hi" - ⧩ - "hi" - -``` diff --git a/unison-src/transcripts-using-base/fix2049.output.md b/unison-src/transcripts-using-base/fix2049.output.md index e69de29bb2..8b13789179 100644 --- a/unison-src/transcripts-using-base/fix2049.output.md +++ b/unison-src/transcripts-using-base/fix2049.output.md @@ -0,0 +1 @@ + diff --git a/unison-src/transcripts-using-base/fix2158-1.md b/unison-src/transcripts-using-base/fix2158-1.md index 16721569e5..9b97784678 100644 --- a/unison-src/transcripts-using-base/fix2158-1.md +++ b/unison-src/transcripts-using-base/fix2158-1.md @@ -1,13 +1,13 @@ This transcript tests an ability check failure regression. -```unison +``` unison structural ability Async t g where fork : '{Async t g, g} a -> t a await : t a -> a Async.parMap : (a ->{Async t g, g} b) -> [a] ->{Async t g} [b] -Async.parMap f as = - tasks = List.map (a -> fork '(f a)) as +Async.parMap f as = + tasks = List.map (a -> fork '(f a)) as List.map await tasks ``` diff --git a/unison-src/transcripts-using-base/fix2158-1.output.md b/unison-src/transcripts-using-base/fix2158-1.output.md index e8014f284a..d3d4ce972e 100644 --- a/unison-src/transcripts-using-base/fix2158-1.output.md +++ b/unison-src/transcripts-using-base/fix2158-1.output.md @@ -1,32 +1,31 @@ This transcript tests an ability check failure regression. -```unison +``` unison structural ability Async t g where fork : '{Async t g, g} a -> t a await : t a -> a Async.parMap : (a ->{Async t g, g} b) -> [a] ->{Async t g} [b] -Async.parMap f as = - tasks = List.map (a -> fork '(f a)) as +Async.parMap f as = + tasks = List.map (a -> fork '(f a)) as List.map await tasks ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: structural ability Async t g Async.parMap : (a ->{g, Async t g} b) -> [a] ->{Async t g} [b] - ``` + The issue was that certain ability processing was happing in less optimal order. `g` appears both as an ability used and as a parameter to `Async`. However, the latter occurrence is more strict. Unifying @@ -36,6 +35,6 @@ some subtyping. However, the ability handling was just processing rows in whatever order they occurred, and during inference it happened that `g` -occurred in the row before `Async t g. Processing the stricter parts +occurred in the row before `Async t g`. Processing the stricter parts first is better, becauase it can solve things more precisely and avoid ambiguities relating to subtyping. diff --git a/unison-src/transcripts-using-base/fix2297.md b/unison-src/transcripts-using-base/fix2297.md index 26c2108d2a..bddfae0199 100644 --- a/unison-src/transcripts-using-base/fix2297.md +++ b/unison-src/transcripts-using-base/fix2297.md @@ -1,7 +1,7 @@ This tests a case where a function was somehow discarding abilities. -```unison:error +``` unison :error structural ability Trivial where trivial : () diff --git a/unison-src/transcripts-using-base/fix2297.output.md b/unison-src/transcripts-using-base/fix2297.output.md index 575c5a73af..69dae77fac 100644 --- a/unison-src/transcripts-using-base/fix2297.output.md +++ b/unison-src/transcripts-using-base/fix2297.output.md @@ -1,7 +1,6 @@ This tests a case where a function was somehow discarding abilities. - -```unison +``` unison :error structural ability Trivial where trivial : () @@ -25,13 +24,10 @@ wat = handleTrivial testAction -- Somehow this completely forgets about Excepti > handleTrivial testAction ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. The expression in red needs the {IO} ability, but this location does not have access to any abilities. - - 19 | wat = handleTrivial testAction -- Somehow this completely forgets about Exception and IO - + 19 | wat = handleTrivial testAction -- Somehow this completely forgets about Exception and IO ``` diff --git a/unison-src/transcripts-using-base/fix2358.md b/unison-src/transcripts-using-base/fix2358.md index 915a350607..2a262f2882 100644 --- a/unison-src/transcripts-using-base/fix2358.md +++ b/unison-src/transcripts-using-base/fix2358.md @@ -1,7 +1,6 @@ - Tests a former error due to bad calling conventions on delay.impl -```unison +``` unison timingApp2 : '{IO, Exception} () timingApp2 _ = printLine "Hello" @@ -9,6 +8,6 @@ timingApp2 _ = printLine "World" ``` -```ucm -.> run timingApp2 +``` ucm +scratch/main> run timingApp2 ``` diff --git a/unison-src/transcripts-using-base/fix2358.output.md b/unison-src/transcripts-using-base/fix2358.output.md index 61a3dd8052..73f94c3761 100644 --- a/unison-src/transcripts-using-base/fix2358.output.md +++ b/unison-src/transcripts-using-base/fix2358.output.md @@ -1,7 +1,6 @@ - Tests a former error due to bad calling conventions on delay.impl -```unison +``` unison timingApp2 : '{IO, Exception} () timingApp2 _ = printLine "Hello" @@ -9,22 +8,20 @@ timingApp2 _ = printLine "World" ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: timingApp2 : '{IO, Exception} () - ``` -```ucm -.> run timingApp2 - () +``` ucm +scratch/main> run timingApp2 + () ``` diff --git a/unison-src/transcripts-using-base/fix3166.md b/unison-src/transcripts-using-base/fix3166.md index 5c6a9e3124..bacaa4aa40 100644 --- a/unison-src/transcripts-using-base/fix3166.md +++ b/unison-src/transcripts-using-base/fix3166.md @@ -1,7 +1,7 @@ This file tests some obscure issues involved with abilities and over-applied functions. -```unison +``` unison Stream.fromList : [a] -> '{Stream a} () Stream.fromList l _ = _ = List.map (x -> emit x) l @@ -31,7 +31,7 @@ increment n = 1 + n Stream.toList s2 ``` -```unison +``` unison structural ability E where eff : () -> () @@ -51,7 +51,7 @@ foo _ = > h foo 337 ``` -```unison +``` unison structural ability Over where over : Nat ->{Over} (Nat -> Nat) diff --git a/unison-src/transcripts-using-base/fix3166.output.md b/unison-src/transcripts-using-base/fix3166.output.md index 4787e17672..a370eeb8e4 100644 --- a/unison-src/transcripts-using-base/fix3166.output.md +++ b/unison-src/transcripts-using-base/fix3166.output.md @@ -1,7 +1,7 @@ This file tests some obscure issues involved with abilities and over-applied functions. -```unison +``` unison Stream.fromList : [a] -> '{Stream a} () Stream.fromList l _ = _ = List.map (x -> emit x) l @@ -31,14 +31,13 @@ increment n = 1 + n Stream.toList s2 ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: Stream.fromList : [a] -> '{Stream a} () @@ -49,20 +48,20 @@ increment n = 1 + n -> Request {Stream a} r -> '{Stream b} r increment : Nat -> Nat - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 19 | > Stream.toList (Stream.map increment (Stream.fromList [1,2,3])) ⧩ [2, 3, 4] - + 22 | s1 = do emit 10 ⧩ [100, 200, 300, 400] - ``` -```unison + +``` unison structural ability E where eff : () -> () @@ -82,30 +81,29 @@ foo _ = > h foo 337 ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: structural ability E foo : '{E} (Nat -> Nat) h : '{E} (Nat -> r) -> Nat -> r hh : Request {E} (Nat -> r) -> Nat -> r - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 17 | > h foo 337 ⧩ 7 - ``` -```unison + +``` unison structural ability Over where over : Nat ->{Over} (Nat -> Nat) @@ -126,26 +124,24 @@ hmm = > hmm ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: structural ability Over delegated : ∀ _. _ -> Nat -> Nat hd : Request {g, Over} x -> x hmm : Nat - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 18 | > hmm ⧩ 16794 - ``` diff --git a/unison-src/transcripts-using-base/fix3542.md b/unison-src/transcripts-using-base/fix3542.md index 98487e8240..4d15f90e1b 100644 --- a/unison-src/transcripts-using-base/fix3542.md +++ b/unison-src/transcripts-using-base/fix3542.md @@ -1,4 +1,4 @@ -```unison +``` unison arrayList v n = do use ImmutableByteArray read8 ma = Scope.bytearrayOf v n diff --git a/unison-src/transcripts-using-base/fix3542.output.md b/unison-src/transcripts-using-base/fix3542.output.md index e2d1e7c6a9..df71ed5a37 100644 --- a/unison-src/transcripts-using-base/fix3542.output.md +++ b/unison-src/transcripts-using-base/fix3542.output.md @@ -1,4 +1,4 @@ -```unison +``` unison arrayList v n = do use ImmutableByteArray read8 ma = Scope.bytearrayOf v n @@ -13,23 +13,21 @@ arrayList v n = do > Scope.run '(catch (arrayList 7 8)) ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: arrayList : Nat -> Nat -> '{Exception, Scope s} [Nat] - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 12 | > Scope.run '(catch (arrayList 7 8)) ⧩ Right [7, 7, 7, 7, 7, 7, 7, 7] - ``` diff --git a/unison-src/transcripts-using-base/fix3939.md b/unison-src/transcripts-using-base/fix3939.md index 7ec695e6c7..3595bfb929 100644 --- a/unison-src/transcripts-using-base/fix3939.md +++ b/unison-src/transcripts-using-base/fix3939.md @@ -1,12 +1,12 @@ -```unison +``` unison {{ A simple doc. }} meh = 9 ``` -```ucm -.> add -.> find meh -.> docs 1 +``` ucm +scratch/main> add +scratch/main> find meh +scratch/main> docs 1 ``` diff --git a/unison-src/transcripts-using-base/fix3939.output.md b/unison-src/transcripts-using-base/fix3939.output.md index 99197263c4..c9e6d16bc6 100644 --- a/unison-src/transcripts-using-base/fix3939.output.md +++ b/unison-src/transcripts-using-base/fix3939.output.md @@ -1,40 +1,37 @@ -```unison +``` unison {{ A simple doc. }} meh = 9 ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: meh : Nat meh.doc : Doc2 - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + meh : Nat meh.doc : Doc2 -.> find meh +scratch/main> find meh 1. meh : Nat 2. meh.doc : Doc2 - -.> docs 1 +scratch/main> docs 1 A simple doc. - ``` diff --git a/unison-src/transcripts-using-base/fix4746.md b/unison-src/transcripts-using-base/fix4746.md index c391953994..bc79eddbe9 100644 --- a/unison-src/transcripts-using-base/fix4746.md +++ b/unison-src/transcripts-using-base/fix4746.md @@ -1,7 +1,7 @@ Test case for a variable capture problem during let floating. The encloser wasn't accounting for variables bound by matches. -```unison +``` unison ability Issue t where one : '{Issue t} () -> {Issue t} () two : '{Issue t} () -> {Issue t} () diff --git a/unison-src/transcripts-using-base/fix4746.output.md b/unison-src/transcripts-using-base/fix4746.output.md index fd158585e3..8a93ee1c0b 100644 --- a/unison-src/transcripts-using-base/fix4746.output.md +++ b/unison-src/transcripts-using-base/fix4746.output.md @@ -1,7 +1,7 @@ Test case for a variable capture problem during let floating. The encloser wasn't accounting for variables bound by matches. -```unison +``` unison ability Issue t where one : '{Issue t} () -> {Issue t} () two : '{Issue t} () -> {Issue t} () @@ -35,26 +35,24 @@ run s = () ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: ability Issue t run : '{Issue t} () -> '{Stream Text} () works : Nat -> Nat x : '{Issue t} () ->{Issue t} () - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 26 | > Stream.toList <| run do ⧩ ["one", "two", "three", "done"] - ``` diff --git a/unison-src/transcripts-using-base/fix5129.md b/unison-src/transcripts-using-base/fix5129.md new file mode 100644 index 0000000000..fc7fd4d230 --- /dev/null +++ b/unison-src/transcripts-using-base/fix5129.md @@ -0,0 +1,45 @@ +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +Checks for some bad type checking behavior. Some ability subtyping was +too lenient when higher-order functions were involved. + +``` unison :error +foreach : (a ->{g} ()) -> [a] ->{g} () +foreach f = cases + [] -> () + x +: xs -> + f x + foreach f xs + +forkIt : '{IO} () ->{IO} () +forkIt e = + _ = IO.forkComp e + () + +thunk : '{IO,Exception} () +thunk = do + raise (Failure (typeLink MiscFailure) "thunk" (Any ())) + +go = do + foreach forkIt [thunk] +``` + +This comes from issue #3513 + +``` unison :error +(<<) : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c +(<<) f g x = f (g x) + +catchAll.impl : '{IO, Exception} a ->{IO} Either Failure a +catchAll.impl thunk = + handle tryEval do catch thunk + with + cases + { x } -> x + {Exception.raise f -> _} -> Left f + +fancyTryEval : '{g, IO, Exception} a ->{g, IO, Exception} a +fancyTryEval = reraise << catchAll.impl +``` diff --git a/unison-src/transcripts-using-base/fix5129.output.md b/unison-src/transcripts-using-base/fix5129.output.md new file mode 100644 index 0000000000..ce5c89a5de --- /dev/null +++ b/unison-src/transcripts-using-base/fix5129.output.md @@ -0,0 +1,72 @@ +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +Checks for some bad type checking behavior. Some ability subtyping was +too lenient when higher-order functions were involved. + +``` unison :error +foreach : (a ->{g} ()) -> [a] ->{g} () +foreach f = cases + [] -> () + x +: xs -> + f x + foreach f xs + +forkIt : '{IO} () ->{IO} () +forkIt e = + _ = IO.forkComp e + () + +thunk : '{IO,Exception} () +thunk = do + raise (Failure (typeLink MiscFailure) "thunk" (Any ())) + +go = do + foreach forkIt [thunk] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found an ability mismatch when checking the application + + 18 | foreach forkIt [thunk] + + + When trying to match [Unit ->{𝕖75, IO, Exception} Unit] with + [Unit ->{IO} Unit] the left hand side contained extra + abilities: {𝕖75, Exception} + +``` + +This comes from issue \#3513 + +``` unison :error +(<<) : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c +(<<) f g x = f (g x) + +catchAll.impl : '{IO, Exception} a ->{IO} Either Failure a +catchAll.impl thunk = + handle tryEval do catch thunk + with + cases + { x } -> x + {Exception.raise f -> _} -> Left f + +fancyTryEval : '{g, IO, Exception} a ->{g, IO, Exception} a +fancyTryEval = reraise << catchAll.impl +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + The expression in red + + needs the abilities: {g76} + but was assumed to only require: {IO, Exception} + + This is likely a result of using an un-annotated function as an argument with concrete abilities. Try adding an annotation to the function definition whose body is red. + + 13 | fancyTryEval = reraise << catchAll.impl +``` diff --git a/unison-src/transcripts-using-base/fix5178.md b/unison-src/transcripts-using-base/fix5178.md new file mode 100644 index 0000000000..e03d38eed5 --- /dev/null +++ b/unison-src/transcripts-using-base/fix5178.md @@ -0,0 +1,20 @@ +``` unison +foo = {{ +@source{Stream.emit} +}} +``` + +``` ucm +scratch/main> add +``` + +Viewing `foo` via `scratch/main> ui` shows the correct source, but `display foo` gives us an error message (but not an error – this is incorrectly considered a successful result) + +I think there are two separate issues here: + +1. this message should be considered an error, not success; and +2. this should actually work like `ui` and give us the source of the ability member, not complain about there being no such term in the codebase. + +``` ucm :error :bug +scratch/main> display foo +``` diff --git a/unison-src/transcripts-using-base/fix5178.output.md b/unison-src/transcripts-using-base/fix5178.output.md new file mode 100644 index 0000000000..c01343f2db --- /dev/null +++ b/unison-src/transcripts-using-base/fix5178.output.md @@ -0,0 +1,43 @@ +``` unison +foo = {{ +@source{Stream.emit} +}} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : Doc2 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : Doc2 +``` + +Viewing `foo` via `scratch/main> ui` shows the correct source, but `display foo` gives us an error message (but not an error – this is incorrectly considered a successful result) + +I think there are two separate issues here: + +1. this message should be considered an error, not success; and +2. this should actually work like `ui` and give us the source of the ability member, not complain about there being no such term in the codebase. + +``` ucm :error :bug +scratch/main> display foo + + -- The name #rfi1v9429f is assigned to the reference + ShortHash {prefix = + "rfi1v9429f9qluv533l2iba77aadttilrpmnhljfapfnfa6sru2nr8ibpqvib9nc4s4nb9s1as45upsfqfqe6ivqi2p82b2vd866it8", + cycle = Nothing, cid = Nothing}, which is missing from the + codebase. + Tip: You might need to repair the codebase manually. +``` diff --git a/unison-src/transcripts-using-base/hashing.md b/unison-src/transcripts-using-base/hashing.md index 99f7db2477..ebef9fa745 100644 --- a/unison-src/transcripts-using-base/hashing.md +++ b/unison-src/transcripts-using-base/hashing.md @@ -2,8 +2,8 @@ Unison has cryptographic builtins for hashing and computing [HMACs](https://en.wikipedia.org/wiki/HMAC) (hash-based message authentication codes). This transcript shows their usage and has some test cases. -```ucm -.> ls builtin.Bytes +``` ucm +scratch/main> ls builtin.Bytes ``` Notice the `fromBase16` and `toBase16` functions. Here's some convenience functions for converting `Bytes` to and from base-16 `Text`. @@ -11,7 +11,7 @@ Notice the `fromBase16` and `toBase16` functions. Here's some convenience functi Here's a few usage examples: -```unison +``` unison ex1 = fromHex "2947db" |> crypto.hashBytes Sha3_512 |> hex @@ -42,13 +42,13 @@ ex5 = crypto.hmac Sha2_256 mysecret f |> hex And here's the full API: -```ucm -.> find-in builtin.crypto +``` ucm +scratch/main> find-in builtin.crypto ``` Note that the universal versions of `hash` and `hmac` are currently unimplemented and will bomb at runtime: -```unison +``` unison > hash Sha3_256 (fromHex "3849238492") ``` @@ -56,7 +56,7 @@ Note that the universal versions of `hash` and `hmac` are currently unimplemente Here are some test vectors (taken from [here](https://www.di-mgt.com.au/sha_testvectors.html) and [here](https://en.wikipedia.org/wiki/BLAKE_(hash_function))) for the various hashing algorithms: -```unison:hide +``` unison :hide ex alg input expected = checks [hashBytes alg (ascii input) == fromHex expected] test> sha3_512.tests.ex1 = @@ -188,19 +188,19 @@ test> crypto.hash.numTests = checks (List.map t (range 0 20)) ``` -```ucm:hide -.> add +``` ucm :hide +scratch/main> add ``` -```ucm -.> test +``` ucm +scratch/main> test ``` ## HMAC tests These test vectors are taken from [RFC 4231](https://tools.ietf.org/html/rfc4231#section-4.3). -```unison +``` unison ex' alg secret msg expected = checks [hmacBytes alg (fromHex secret) (ascii msg) == fromHex expected] test> hmac_sha2_256.tests.ex1 = @@ -231,7 +231,7 @@ test> hmac_sha2_512.tests.ex2 = Test vectors here pulled from [Wikipedia's writeup](https://en.wikipedia.org/wiki/MD5). -```unison +``` unison ex alg input expected = checks [hashBytes alg (ascii input) == fromHex expected] test> md5.tests.ex1 = @@ -250,10 +250,10 @@ test> md5.tests.ex3 = "e4d909c290d0fb1ca068ffaddf22cbd0" ``` -```ucm:hide -.> add +``` ucm :hide +scratch/main> add ``` -```ucm -.> test +``` ucm +scratch/main> test ``` diff --git a/unison-src/transcripts-using-base/hashing.output.md b/unison-src/transcripts-using-base/hashing.output.md index fee4fa0a27..4bf5506a8b 100644 --- a/unison-src/transcripts-using-base/hashing.output.md +++ b/unison-src/transcripts-using-base/hashing.output.md @@ -2,8 +2,8 @@ Unison has cryptographic builtins for hashing and computing [HMACs](https://en.wikipedia.org/wiki/HMAC) (hash-based message authentication codes). This transcript shows their usage and has some test cases. -```ucm -.> ls builtin.Bytes +``` ucm +scratch/main> ls builtin.Bytes 1. ++ (Bytes -> Bytes -> Bytes) 2. at (Nat -> Bytes -> Optional Nat) @@ -37,15 +37,15 @@ Unison has cryptographic builtins for hashing and computing [HMACs](https://en.w 30. toBase64UrlUnpadded (Bytes -> Bytes) 31. toList (Bytes -> [Nat]) 32. zlib/ (2 terms) - ``` + Notice the `fromBase16` and `toBase16` functions. Here's some convenience functions for converting `Bytes` to and from base-16 `Text`. ## API overview Here's a few usage examples: -```unison +``` unison ex1 = fromHex "2947db" |> crypto.hashBytes Sha3_512 |> hex @@ -74,14 +74,13 @@ ex5 = crypto.hmac Sha2_256 mysecret f |> hex > ex5 ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: ex1 : Text @@ -92,35 +91,35 @@ ex5 = crypto.hmac Sha2_256 mysecret f |> hex f : x -> x (also named id) mysecret : Bytes - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 22 | > ex1 ⧩ "f3c342040674c50ab45cb1874b6dbc81447af5958201ed4127e03b56725664d7cc44b88b9afadb371898fcaf5d0adeff60837ef93b514f99da43539d79820c99" - + 23 | > ex2 ⧩ "84bb437497f26fc33c51e57e64c37958c3918d50dfe75b91c661a85c2f8f8304" - + 24 | > ex3 ⧩ "c692fc54df921f7fa51aad9178327c5a097784b02212d571fb40facdfff881fd" - + 25 | > ex4 ⧩ "764a6e91271bce6ce8d8f49d551ba0e586a1e20d8bc2df0dff3117fcd9a11d9a" - + 26 | > ex5 ⧩ "abd0e845a5544ced19b1c05df18a05c10b252a355957b18b99b33970d5217de6" - ``` + And here's the full API: -```ucm -.> find-in builtin.crypto +``` ucm +scratch/main> find-in builtin.crypto 1. type CryptoFailure 2. Ed25519.sign.impl : Bytes @@ -150,36 +149,34 @@ And here's the full API: -> Bytes -> Bytes -> Either Failure Boolean - - ``` + Note that the universal versions of `hash` and `hmac` are currently unimplemented and will bomb at runtime: -```unison +``` unison > hash Sha3_256 (fromHex "3849238492") ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. ✅ - + scratch.u changed. - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 1 | > hash Sha3_256 (fromHex "3849238492") ⧩ 0xs1259de8ec2c8b925dce24f591ed5cc1d1a5dc01cf88cf8f2343fc9728e124af4 - ``` + ## Hashing tests -Here are some test vectors (taken from [here](https://www.di-mgt.com.au/sha_testvectors.html) and [here](https://en.wikipedia.org/wiki/BLAKE_(hash_function))) for the various hashing algorithms: +Here are some test vectors (taken from [here](https://www.di-mgt.com.au/sha_testvectors.html) and [here](https://en.wikipedia.org/wiki/BLAKE_\(hash_function\))) for the various hashing algorithms: -```unison +``` unison :hide ex alg input expected = checks [hashBytes alg (ascii input) == fromHex expected] test> sha3_512.tests.ex1 = @@ -311,48 +308,51 @@ test> crypto.hash.numTests = checks (List.map t (range 0 20)) ``` -```ucm -.> test +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> test Cached test results (`help testcache` to learn more) - - ◉ blake2b_512.tests.ex1 Passed - ◉ blake2b_512.tests.ex2 Passed - ◉ blake2b_512.tests.ex3 Passed - ◉ blake2s_256.tests.ex1 Passed - ◉ crypto.hash.numTests Passed - ◉ sha1.tests.ex1 Passed - ◉ sha1.tests.ex2 Passed - ◉ sha1.tests.ex3 Passed - ◉ sha1.tests.ex4 Passed - ◉ sha2_256.tests.ex1 Passed - ◉ sha2_256.tests.ex2 Passed - ◉ sha2_256.tests.ex3 Passed - ◉ sha2_256.tests.ex4 Passed - ◉ sha2_512.tests.ex1 Passed - ◉ sha2_512.tests.ex2 Passed - ◉ sha2_512.tests.ex3 Passed - ◉ sha2_512.tests.ex4 Passed - ◉ sha3_256.tests.ex1 Passed - ◉ sha3_256.tests.ex2 Passed - ◉ sha3_256.tests.ex3 Passed - ◉ sha3_256.tests.ex4 Passed - ◉ sha3_512.tests.ex1 Passed - ◉ sha3_512.tests.ex2 Passed - ◉ sha3_512.tests.ex3 Passed - ◉ sha3_512.tests.ex4 Passed - + + 1. blake2b_512.tests.ex1 ◉ Passed + 2. blake2b_512.tests.ex2 ◉ Passed + 3. blake2b_512.tests.ex3 ◉ Passed + 4. blake2s_256.tests.ex1 ◉ Passed + 5. crypto.hash.numTests ◉ Passed + 6. sha1.tests.ex1 ◉ Passed + 7. sha1.tests.ex2 ◉ Passed + 8. sha1.tests.ex3 ◉ Passed + 9. sha1.tests.ex4 ◉ Passed + 10. sha2_256.tests.ex1 ◉ Passed + 11. sha2_256.tests.ex2 ◉ Passed + 12. sha2_256.tests.ex3 ◉ Passed + 13. sha2_256.tests.ex4 ◉ Passed + 14. sha2_512.tests.ex1 ◉ Passed + 15. sha2_512.tests.ex2 ◉ Passed + 16. sha2_512.tests.ex3 ◉ Passed + 17. sha2_512.tests.ex4 ◉ Passed + 18. sha3_256.tests.ex1 ◉ Passed + 19. sha3_256.tests.ex2 ◉ Passed + 20. sha3_256.tests.ex3 ◉ Passed + 21. sha3_256.tests.ex4 ◉ Passed + 22. sha3_512.tests.ex1 ◉ Passed + 23. sha3_512.tests.ex2 ◉ Passed + 24. sha3_512.tests.ex3 ◉ Passed + 25. sha3_512.tests.ex4 ◉ Passed + ✅ 25 test(s) passing - - Tip: Use view blake2b_512.tests.ex1 to view the source of a - test. + Tip: Use view 1 to view the source of a test. ``` + ## HMAC tests These test vectors are taken from [RFC 4231](https://tools.ietf.org/html/rfc4231#section-4.3). -```unison +``` unison ex' alg secret msg expected = checks [hmacBytes alg (fromHex secret) (ascii msg) == fromHex expected] test> hmac_sha2_256.tests.ex1 = @@ -379,14 +379,13 @@ test> hmac_sha2_512.tests.ex2 = "164b7a7bfcf819e2e395fbe73b56e0a387bd64222e831fd610270cd7ea2505549758bf75c05a994a6d034f65f8f0e6fdcaeab1a34d4a6b4b636e070a38bce737" ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: ex' : HashAlgorithm @@ -398,32 +397,32 @@ test> hmac_sha2_512.tests.ex2 = hmac_sha2_256.tests.ex2 : [Result] hmac_sha2_512.tests.ex1 : [Result] hmac_sha2_512.tests.ex2 : [Result] - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 4 | ex' Sha2_256 ✅ Passed Passed - + 9 | ex' Sha2_512 ✅ Passed Passed - + 15 | ex' Sha2_256 ✅ Passed Passed - + 21 | ex' Sha2_512 ✅ Passed Passed - ``` + ## MD5 tests Test vectors here pulled from [Wikipedia's writeup](https://en.wikipedia.org/wiki/MD5). -```unison +``` unison ex alg input expected = checks [hashBytes alg (ascii input) == fromHex expected] test> md5.tests.ex1 = @@ -442,14 +441,13 @@ test> md5.tests.ex3 = "e4d909c290d0fb1ca068ffaddf22cbd0" ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⊡ Previously added definitions will be ignored: ex ⍟ These new definitions are ok to `add`: @@ -457,60 +455,62 @@ test> md5.tests.ex3 = md5.tests.ex1 : [Result] md5.tests.ex2 : [Result] md5.tests.ex3 : [Result] - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 4 | ex Md5 ✅ Passed Passed - + 9 | ex Md5 ✅ Passed Passed - + 14 | ex Md5 ✅ Passed Passed +``` +``` ucm :hide +scratch/main> add ``` -```ucm -.> test + +``` ucm +scratch/main> test Cached test results (`help testcache` to learn more) - - ◉ blake2b_512.tests.ex1 Passed - ◉ blake2b_512.tests.ex2 Passed - ◉ blake2b_512.tests.ex3 Passed - ◉ blake2s_256.tests.ex1 Passed - ◉ crypto.hash.numTests Passed - ◉ md5.tests.ex1 Passed - ◉ md5.tests.ex2 Passed - ◉ md5.tests.ex3 Passed - ◉ sha1.tests.ex1 Passed - ◉ sha1.tests.ex2 Passed - ◉ sha1.tests.ex3 Passed - ◉ sha1.tests.ex4 Passed - ◉ sha2_256.tests.ex1 Passed - ◉ sha2_256.tests.ex2 Passed - ◉ sha2_256.tests.ex3 Passed - ◉ sha2_256.tests.ex4 Passed - ◉ sha2_512.tests.ex1 Passed - ◉ sha2_512.tests.ex2 Passed - ◉ sha2_512.tests.ex3 Passed - ◉ sha2_512.tests.ex4 Passed - ◉ sha3_256.tests.ex1 Passed - ◉ sha3_256.tests.ex2 Passed - ◉ sha3_256.tests.ex3 Passed - ◉ sha3_256.tests.ex4 Passed - ◉ sha3_512.tests.ex1 Passed - ◉ sha3_512.tests.ex2 Passed - ◉ sha3_512.tests.ex3 Passed - ◉ sha3_512.tests.ex4 Passed - + + 1. blake2b_512.tests.ex1 ◉ Passed + 2. blake2b_512.tests.ex2 ◉ Passed + 3. blake2b_512.tests.ex3 ◉ Passed + 4. blake2s_256.tests.ex1 ◉ Passed + 5. crypto.hash.numTests ◉ Passed + 6. md5.tests.ex1 ◉ Passed + 7. md5.tests.ex2 ◉ Passed + 8. md5.tests.ex3 ◉ Passed + 9. sha1.tests.ex1 ◉ Passed + 10. sha1.tests.ex2 ◉ Passed + 11. sha1.tests.ex3 ◉ Passed + 12. sha1.tests.ex4 ◉ Passed + 13. sha2_256.tests.ex1 ◉ Passed + 14. sha2_256.tests.ex2 ◉ Passed + 15. sha2_256.tests.ex3 ◉ Passed + 16. sha2_256.tests.ex4 ◉ Passed + 17. sha2_512.tests.ex1 ◉ Passed + 18. sha2_512.tests.ex2 ◉ Passed + 19. sha2_512.tests.ex3 ◉ Passed + 20. sha2_512.tests.ex4 ◉ Passed + 21. sha3_256.tests.ex1 ◉ Passed + 22. sha3_256.tests.ex2 ◉ Passed + 23. sha3_256.tests.ex3 ◉ Passed + 24. sha3_256.tests.ex4 ◉ Passed + 25. sha3_512.tests.ex1 ◉ Passed + 26. sha3_512.tests.ex2 ◉ Passed + 27. sha3_512.tests.ex3 ◉ Passed + 28. sha3_512.tests.ex4 ◉ Passed + ✅ 28 test(s) passing - - Tip: Use view blake2b_512.tests.ex1 to view the source of a - test. + Tip: Use view 1 to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/io.output.md b/unison-src/transcripts-using-base/io.output.md index f74a437365..3113905f23 100644 --- a/unison-src/transcripts-using-base/io.output.md +++ b/unison-src/transcripts-using-base/io.output.md @@ -9,20 +9,20 @@ You can skip the section which is just needed to make the transcript self-contai TempDirs/autoCleaned is an ability/hanlder which allows you to easily create a scratch directory which will automatically get cleaned up. -```unison +``` unison ``` ## Basic File Functions ### Creating/Deleting/Renaming Directories -Tests: createDirectory, - isDirectory, - fileExists, +Tests: createDirectory, + isDirectory, + fileExists, renameDirectory, deleteDirectory -```unison +``` unison testCreateRename : '{io2.IO} [Result] testCreateRename _ = test = 'let @@ -47,28 +47,28 @@ testCreateRename _ = runTest test ``` -```ucm +``` ucm I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: - + testCreateRename : '{IO} [Result] ``` -```ucm +``` ucm .> add ⍟ I've added these definitions: - + testCreateRename : '{IO} [Result] .> io.test testCreateRename New test results: - + ◉ testCreateRename create a foo directory ◉ testCreateRename directory should exist ◉ testCreateRename foo should no longer exist @@ -76,9 +76,9 @@ testCreateRename _ = ◉ testCreateRename bar should now exist ◉ testCreateRename removeDirectory works recursively ◉ testCreateRename removeDirectory works recursively - + ✅ 7 test(s) passing - + Tip: Use view testCreateRename to view the source of a test. ``` @@ -88,7 +88,7 @@ Tests: openFile closeFile isFileOpen -```unison +``` unison testOpenClose : '{io2.IO} [Result] testOpenClose _ = test = 'let @@ -102,33 +102,33 @@ testOpenClose _ = runTest test ``` -```ucm +``` ucm I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: - + testOpenClose : '{IO} [Result] ``` -```ucm +``` ucm .> add ⍟ I've added these definitions: - + testOpenClose : '{IO} [Result] .> io.test testOpenClose New test results: - + ◉ testOpenClose file should be open ◉ testOpenClose file should be closed - + ✅ 2 test(s) passing - + Tip: Use view testOpenClose to view the source of a test. ``` @@ -142,7 +142,7 @@ Tests: openFile seekHandle getBytes -```unison +``` unison testSeek : '{io2.IO} [Result] testSeek _ = test = 'let @@ -191,54 +191,54 @@ testAppend _ = runTest test ``` -```ucm +``` ucm I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: - + testAppend : '{IO} [Result] testSeek : '{IO} [Result] ``` -```ucm +``` ucm .> add ⍟ I've added these definitions: - + testAppend : '{IO} [Result] testSeek : '{IO} [Result] .> io.test testSeek New test results: - + ◉ testSeek seeked ◉ testSeek readable file should be seekable ◉ testSeek shouldn't be the EOF ◉ testSeek we should be at position 0 ◉ testSeek we should be at position 1 ◉ testSeek should be able to read our temporary file after seeking - + ✅ 6 test(s) passing - + Tip: Use view testSeek to view the source of a test. .> io.test testAppend New test results: - + ◉ testAppend should be able to read our temporary file - + ✅ 1 test(s) passing - + Tip: Use view testAppend to view the source of a test. ``` ### SystemTime -```unison +``` unison testSystemTime : '{io2.IO} [Result] testSystemTime _ = test = 'let @@ -248,32 +248,32 @@ testSystemTime _ = runTest test ``` -```ucm +``` ucm I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: - + testSystemTime : '{IO} [Result] ``` -```ucm +``` ucm .> add ⍟ I've added these definitions: - + testSystemTime : '{IO} [Result] .> io.test testSystemTime New test results: - + ◉ testSystemTime systemTime should be sane - + ✅ 1 test(s) passing - + Tip: Use view testSystemTime to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/mvar.md b/unison-src/transcripts-using-base/mvar.md index d2114c2e28..67eccd7a4d 100644 --- a/unison-src/transcripts-using-base/mvar.md +++ b/unison-src/transcripts-using-base/mvar.md @@ -10,7 +10,7 @@ primitives can be built, such as Futures, Run at most once initializer blocks, Queues, etc. -```unison +``` unison eitherCk : (a -> Boolean) -> Either e a -> Boolean eitherCk f = cases Left _ -> false @@ -50,8 +50,7 @@ testMvars _ = runTest test ``` -```ucm -.> add -.> io.test testMvars +``` ucm +scratch/main> add +scratch/main> io.test testMvars ``` - diff --git a/unison-src/transcripts-using-base/mvar.output.md b/unison-src/transcripts-using-base/mvar.output.md index 26cccc7baf..7e18b62f4b 100644 --- a/unison-src/transcripts-using-base/mvar.output.md +++ b/unison-src/transcripts-using-base/mvar.output.md @@ -9,8 +9,7 @@ MVars are the building block on which many other concurrency primitives can be built, such as Futures, Run at most once initializer blocks, Queues, etc. - -```unison +``` unison eitherCk : (a -> Boolean) -> Either e a -> Boolean eitherCk f = cases Left _ -> false @@ -51,48 +50,46 @@ testMvars _ = runTest test ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: eitherCk : (a ->{g} Boolean) -> Either e a ->{g} Boolean testMvars : '{IO} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + eitherCk : (a ->{g} Boolean) -> Either e a ->{g} Boolean testMvars : '{IO} [Result] -.> io.test testMvars +scratch/main> io.test testMvars New test results: - - ◉ testMvars ma should not be empty - ◉ testMvars should read what you sow - ◉ testMvars should reap what you sow - ◉ testMvars ma should be empty - ◉ testMvars swap returns old contents - ◉ testMvars swap returns old contents - ◉ testMvars tryRead should succeed when not empty - ◉ testMvars tryPut should fail when not empty - ◉ testMvars tryTake should succeed when not empty - ◉ testMvars tryTake should not succeed when empty - ◉ testMvars ma2 should be empty - ◉ testMvars tryTake should fail when empty - ◉ testMvars tryRead should fail when empty - + + 1. testMvars ◉ ma should not be empty + ◉ should read what you sow + ◉ should reap what you sow + ◉ ma should be empty + ◉ swap returns old contents + ◉ swap returns old contents + ◉ tryRead should succeed when not empty + ◉ tryPut should fail when not empty + ◉ tryTake should succeed when not empty + ◉ tryTake should not succeed when empty + ◉ ma2 should be empty + ◉ tryTake should fail when empty + ◉ tryRead should fail when empty + ✅ 13 test(s) passing - - Tip: Use view testMvars to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/namespace-dependencies.md b/unison-src/transcripts-using-base/namespace-dependencies.md deleted file mode 100644 index d338c05432..0000000000 --- a/unison-src/transcripts-using-base/namespace-dependencies.md +++ /dev/null @@ -1,11 +0,0 @@ -# namespace.dependencies command - -```unison:hide -external.mynat = 1 -mynamespace.dependsOnText = external.mynat Nat.+ 10 -``` - -```ucm -.> add -.mynamespace> namespace.dependencies -``` diff --git a/unison-src/transcripts-using-base/namespace-dependencies.output.md b/unison-src/transcripts-using-base/namespace-dependencies.output.md deleted file mode 100644 index caf4dc52c7..0000000000 --- a/unison-src/transcripts-using-base/namespace-dependencies.output.md +++ /dev/null @@ -1,25 +0,0 @@ -# namespace.dependencies command - -```unison -external.mynat = 1 -mynamespace.dependsOnText = external.mynat Nat.+ 10 -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - external.mynat : Nat - mynamespace.dependsOnText : Nat - -.mynamespace> namespace.dependencies - - External dependency Dependents in .mynamespace - .builtin.Nat 1. dependsOnText - - .builtin.Nat.+ 1. dependsOnText - - .external.mynat 1. dependsOnText - -``` diff --git a/unison-src/transcripts-using-base/nat-coersion.md b/unison-src/transcripts-using-base/nat-coersion.md index 3f77501890..a055c40bab 100644 --- a/unison-src/transcripts-using-base/nat-coersion.md +++ b/unison-src/transcripts-using-base/nat-coersion.md @@ -1,4 +1,4 @@ -```unison +``` unison testNat: Nat -> Optional Int -> Optional Float -> {Stream Result}() testNat n expectInt expectFloat = @@ -32,7 +32,7 @@ test = 'let runTest testABunchOfNats ``` -```ucm -.> add -.> io.test test +``` ucm +scratch/main> add +scratch/main> io.test test ``` diff --git a/unison-src/transcripts-using-base/nat-coersion.output.md b/unison-src/transcripts-using-base/nat-coersion.output.md index 38ab4450f0..1fe0ce8e34 100644 --- a/unison-src/transcripts-using-base/nat-coersion.output.md +++ b/unison-src/transcripts-using-base/nat-coersion.output.md @@ -1,4 +1,5 @@ -```unison +``` unison + testNat: Nat -> Optional Int -> Optional Float -> {Stream Result}() testNat n expectInt expectFloat = float = Float.fromRepresentation n @@ -31,14 +32,13 @@ test = 'let runTest testABunchOfNats ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: test : '{IO} [Result] @@ -46,40 +46,39 @@ test = 'let -> Optional Int -> Optional Float ->{Stream Result} () - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + test : '{IO} [Result] testNat : Nat -> Optional Int -> Optional Float ->{Stream Result} () -.> io.test test +scratch/main> io.test test New test results: - - ◉ test expected 0.0 got 0.0 - ◉ test round trip though float, expected 0 got 0 - ◉ test expected 0 got 0 - ◉ test round trip though Int, expected 0 got 0 - ◉ test skipped - ◉ test expected 1 got 1 - ◉ test round trip though Int, expected 1 got 1 - ◉ test skipped - ◉ test expected -1 got -1 - ◉ test round trip though Int, expected 18446744073709551615 got 18446744073709551615 - ◉ test expected 1.0000000000000002 got 1.0000000000000002 - ◉ test round trip though float, expected 4607182418800017409 got 4607182418800017409 - ◉ test expected 4607182418800017409 got 4607182418800017409 - ◉ test round trip though Int, expected 4607182418800017409 got 4607182418800017409 - + + 1. test ◉ expected 0.0 got 0.0 + ◉ round trip though float, expected 0 got 0 + ◉ expected 0 got 0 + ◉ round trip though Int, expected 0 got 0 + ◉ skipped + ◉ expected 1 got 1 + ◉ round trip though Int, expected 1 got 1 + ◉ skipped + ◉ expected -1 got -1 + ◉ round trip though Int, expected 18446744073709551615 got 18446744073709551615 + ◉ expected 1.0000000000000002 got 1.0000000000000002 + ◉ round trip though float, expected 4607182418800017409 got 4607182418800017409 + ◉ expected 4607182418800017409 got 4607182418800017409 + ◉ round trip though Int, expected 4607182418800017409 got 4607182418800017409 + ✅ 14 test(s) passing - - Tip: Use view test to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/net.md b/unison-src/transcripts-using-base/net.md index b1125f7019..20e604b0a2 100644 --- a/unison-src/transcripts-using-base/net.md +++ b/unison-src/transcripts-using-base/net.md @@ -1,4 +1,4 @@ -```unison:hide +``` unison :hide serverSocket = compose2 reraise IO.serverSocket.impl socketPort = compose reraise socketPort.impl listen = compose reraise listen.impl @@ -9,8 +9,8 @@ socketReceive = compose2 reraise socketReceive.impl socketAccept = compose reraise socketAccept.impl ``` -```ucm:hide -.> add +``` ucm :hide +scratch/main> add ``` # Tests for network related builtins @@ -92,14 +92,14 @@ testDefaultPort _ = runTest test ``` -```ucm -.> add -.> io.test testDefaultPort +``` ucm +scratch/main> add +scratch/main> io.test testDefaultPort ``` This example demonstrates connecting a TCP client socket to a TCP server socket. A thread is started for both client and server. The server socket asks for any availalbe port (by passing "0" as the port number). The server thread then queries for the actual assigned port number, and puts that into an MVar which the client thread can read. The client thread then reads a string from the server and reports it back to the main thread via a different MVar. -```unison +``` unison serverThread: MVar Nat -> Text -> '{io2.IO}() serverThread portVar toSend = 'let @@ -147,8 +147,8 @@ testTcpConnect = 'let runTest test ``` -```ucm +``` ucm -.> add -.> io.test testTcpConnect +scratch/main> add +scratch/main> io.test testTcpConnect ``` diff --git a/unison-src/transcripts-using-base/net.output.md b/unison-src/transcripts-using-base/net.output.md index 572ef0fbff..7d6e6ba63c 100644 --- a/unison-src/transcripts-using-base/net.output.md +++ b/unison-src/transcripts-using-base/net.output.md @@ -1,4 +1,4 @@ -```unison +``` unison :hide serverSocket = compose2 reraise IO.serverSocket.impl socketPort = compose reraise socketPort.impl listen = compose reraise listen.impl @@ -9,6 +9,10 @@ socketReceive = compose2 reraise socketReceive.impl socketAccept = compose reraise socketAccept.impl ``` +``` ucm :hide +scratch/main> add +``` + # Tests for network related builtins ### Creating server sockets @@ -16,14 +20,13 @@ socketAccept = compose reraise socketAccept.impl This section tests functions in the IO builtin related to binding to TCP server socket, as to be able to accept incoming TCP connections. -```builtin -.io2.IO.serverSocket : Optional Text -> Text ->{io2.IO} Either Failure io2.Socket - +``` + builtin.io2.IO.serverSocket : Optional Text -> Text ->{io2.IO} Either Failure io2.Socket ``` This function takes two parameters, The first is the Hostname. If None is provided, We will attempt to bind to 0.0.0.0 (All ipv4 -addresses). We currently only support IPV4 (we should fix this!) +addresses). We currently only support IPV4 (we should fix this\!) The second is the name of the port to bind to. This can be a decimal representation of a port number between 1-65535. This can be a named port like "ssh" (for port 22) or "kermit" (for port 1649), @@ -31,30 +34,32 @@ This mapping of names to port numbers is maintained by the [nsswitch service](https://en.wikipedia.org/wiki/Name_Service_Switch), typically stored in `/etc/services` and queried with the `getent` tool: - # map number to name - $ getent services 22 - ssh 22/tcp - - # map name to number - $ getent services finger - finger 79/tcp - - # get a list of all known names - $ getent services | head - tcpmux 1/tcp - echo 7/tcp - echo 7/udp - discard 9/tcp sink null - discard 9/udp sink null - systat 11/tcp users - daytime 13/tcp - daytime 13/udp - netstat 15/tcp - qotd 17/tcp quote +``` +# map number to name +$ getent services 22 +ssh 22/tcp + +# map name to number +$ getent services finger +finger 79/tcp + +# get a list of all known names +$ getent services | head +tcpmux 1/tcp +echo 7/tcp +echo 7/udp +discard 9/tcp sink null +discard 9/udp sink null +systat 11/tcp users +daytime 13/tcp +daytime 13/udp +netstat 15/tcp +qotd 17/tcp quote +``` Below shows different examples of how we might specify the server coordinates. -```unison +``` unison testExplicitHost : '{io2.IO} [Result] testExplicitHost _ = test = 'let @@ -91,46 +96,46 @@ testDefaultPort _ = runTest test ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: testDefaultHost : '{IO} [Result] testDefaultPort : '{IO} [Result] testExplicitHost : '{IO} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + testDefaultHost : '{IO} [Result] testDefaultPort : '{IO} [Result] testExplicitHost : '{IO} [Result] -.> io.test testDefaultPort +scratch/main> io.test testDefaultPort New test results: - - ◉ testDefaultPort successfully created socket - ◉ testDefaultPort port should be > 1024 - ◉ testDefaultPort port should be < 65536 - + + 1. testDefaultPort ◉ successfully created socket + ◉ port should be > 1024 + ◉ port should be < 65536 + ✅ 3 test(s) passing - - Tip: Use view testDefaultPort to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` + This example demonstrates connecting a TCP client socket to a TCP server socket. A thread is started for both client and server. The server socket asks for any availalbe port (by passing "0" as the port number). The server thread then queries for the actual assigned port number, and puts that into an MVar which the client thread can read. The client thread then reads a string from the server and reports it back to the main thread via a different MVar. -```unison +``` unison + serverThread: MVar Nat -> Text -> '{io2.IO}() serverThread portVar toSend = 'let go : '{io2.IO, Exception}() @@ -178,38 +183,36 @@ testTcpConnect = 'let ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: clientThread : MVar Nat -> MVar Text -> '{IO} () serverThread : MVar Nat -> Text -> '{IO} () testTcpConnect : '{IO} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + clientThread : MVar Nat -> MVar Text -> '{IO} () serverThread : MVar Nat -> Text -> '{IO} () testTcpConnect : '{IO} [Result] -.> io.test testTcpConnect +scratch/main> io.test testTcpConnect New test results: - - ◉ testTcpConnect should have reaped what we've sown - + + 1. testTcpConnect ◉ should have reaped what we've sown + ✅ 1 test(s) passing - - Tip: Use view testTcpConnect to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/random-deserial.md b/unison-src/transcripts-using-base/random-deserial.md index 1a97ca73d7..70846ca59c 100644 --- a/unison-src/transcripts-using-base/random-deserial.md +++ b/unison-src/transcripts-using-base/random-deserial.md @@ -1,4 +1,4 @@ -```unison +``` unison directory = "unison-src/transcripts-using-base/serialized-cases/" availableCases : '{IO,Exception} [Text] @@ -26,14 +26,14 @@ shuffle = runTestCase : Text ->{Exception,IO} (Text, Test.Result) runTestCase name = sfile = directory ++ name ++ ".v4.ser" - lsfile = directory ++ name ++ ".v3.ser" + ls3file = directory ++ name ++ ".v3.ser" ofile = directory ++ name ++ ".out" hfile = directory ++ name ++ ".v4.hash" p@(f, i) = loadSelfContained sfile - pl@(fl, il) = - if fileExists lsfile - then loadSelfContained lsfile + pl3@(fl3, il3) = + if fileExists ls3file + then loadSelfContained ls3file else p o = fromUtf8 (readFile ofile) h = readFile hfile @@ -43,8 +43,8 @@ runTestCase name = then Fail (name ++ " output mismatch") else if not (toBase32 (crypto.hash Sha3_512 p) == h) then Fail (name ++ " hash mismatch") - else if not (fl il == f i) - then Fail (name ++ " legacy mismatch") + else if not (fl3 il3 == f i) + then Fail (name ++ " legacy v3 mismatch") else Ok name (name, result) @@ -55,7 +55,7 @@ serialTests = do List.map snd (bSort (List.map runTestCase cs)) ``` -```ucm -.> add -.> io.test serialTests +``` ucm +scratch/main> add +scratch/main> io.test serialTests ``` diff --git a/unison-src/transcripts-using-base/random-deserial.output.md b/unison-src/transcripts-using-base/random-deserial.output.md index 48ff86e187..9b02b35804 100644 --- a/unison-src/transcripts-using-base/random-deserial.output.md +++ b/unison-src/transcripts-using-base/random-deserial.output.md @@ -1,4 +1,4 @@ -```unison +``` unison directory = "unison-src/transcripts-using-base/serialized-cases/" availableCases : '{IO,Exception} [Text] @@ -26,14 +26,14 @@ shuffle = runTestCase : Text ->{Exception,IO} (Text, Test.Result) runTestCase name = sfile = directory ++ name ++ ".v4.ser" - lsfile = directory ++ name ++ ".v3.ser" + ls3file = directory ++ name ++ ".v3.ser" ofile = directory ++ name ++ ".out" hfile = directory ++ name ++ ".v4.hash" p@(f, i) = loadSelfContained sfile - pl@(fl, il) = - if fileExists lsfile - then loadSelfContained lsfile + pl3@(fl3, il3) = + if fileExists ls3file + then loadSelfContained ls3file else p o = fromUtf8 (readFile ofile) h = readFile hfile @@ -43,8 +43,8 @@ runTestCase name = then Fail (name ++ " output mismatch") else if not (toBase32 (crypto.hash Sha3_512 p) == h) then Fail (name ++ " hash mismatch") - else if not (fl il == f i) - then Fail (name ++ " legacy mismatch") + else if not (fl3 il3 == f i) + then Fail (name ++ " legacy v3 mismatch") else Ok name (name, result) @@ -55,14 +55,13 @@ serialTests = do List.map snd (bSort (List.map runTestCase cs)) ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: availableCases : '{IO, Exception} [Text] @@ -71,13 +70,13 @@ serialTests = do runTestCase : Text ->{IO, Exception} (Text, Result) serialTests : '{IO, Exception} [Result] shuffle : Nat -> [a] -> [a] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + availableCases : '{IO, Exception} [Text] directory : Text gen : Nat -> Nat -> (Nat, Nat) @@ -85,18 +84,17 @@ serialTests = do serialTests : '{IO, Exception} [Result] shuffle : Nat -> [a] -> [a] -.> io.test serialTests +scratch/main> io.test serialTests New test results: - - ◉ serialTests case-00 - ◉ serialTests case-01 - ◉ serialTests case-02 - ◉ serialTests case-03 - ◉ serialTests case-04 - + + 1. serialTests ◉ case-00 + ◉ case-01 + ◉ case-02 + ◉ case-03 + ◉ case-04 + ✅ 5 test(s) passing - - Tip: Use view serialTests to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/ref-promise.md b/unison-src/transcripts-using-base/ref-promise.md index dd54328ec5..c72b8f63dc 100644 --- a/unison-src/transcripts-using-base/ref-promise.md +++ b/unison-src/transcripts-using-base/ref-promise.md @@ -3,10 +3,10 @@ Ref support a CAS operation that can be used as a building block to change state atomically without locks. -```unison +``` unison casTest: '{io2.IO} [Result] casTest = do - test = do + testPrim = do ref = IO.ref 0 ticket = Ref.readForCas ref v1 = Ref.cas ref ticket 5 @@ -14,18 +14,26 @@ casTest = do Ref.write ref 10 v2 = Ref.cas ref ticket 15 check "CAS fails when there was an intervening write" (not v2) + testBoxed = do + ref = IO.ref ("a", "b") + ticket = Ref.readForCas ref + v1 = Ref.cas ref ticket ("c", "d") + check "CAS is successful is there were no conflicting writes" v1 + Ref.write ref ("e", "f") + v2 = Ref.cas ref ticket ("g", "h") + check "CAS fails when there was an intervening write" (not v2) - runTest test + runTest testPrim ++ runTest testBoxed ``` -```ucm -.> add -.> io.test casTest +``` ucm +scratch/main> add +scratch/main> io.test casTest ``` Promise is a simple one-shot awaitable condition. -```unison +``` unison promiseSequentialTest : '{IO} [Result] promiseSequentialTest = do test = do @@ -53,15 +61,15 @@ promiseConcurrentTest = do runTest test ``` -```ucm -.> add -.> io.test promiseSequentialTest -.> io.test promiseConcurrentTest +``` ucm +scratch/main> add +scratch/main> io.test promiseSequentialTest +scratch/main> io.test promiseConcurrentTest ``` CAS can be used to write an atomic update function. -```unison +``` unison atomicUpdate : Ref {IO} a -> (a -> a) ->{IO} () atomicUpdate ref f = ticket = Ref.readForCas ref @@ -69,14 +77,14 @@ atomicUpdate ref f = if Ref.cas ref ticket value then () else atomicUpdate ref f ``` -```ucm -.> add +``` ucm +scratch/main> add ``` Promise can be used to write an operation that spawns N concurrent tasks and collects their results -```unison +``` unison spawnN : Nat -> '{IO} a ->{IO} [a] spawnN n fa = use Nat eq drop @@ -90,19 +98,19 @@ spawnN n fa = map Promise.read (go n []) ``` -```ucm -.> add +``` ucm +scratch/main> add ``` We can use these primitives to write a more interesting example, where multiple threads repeatedly update an atomic counter, we check that the value of the counter is correct after all threads are done. -```unison +``` unison fullTest : '{IO} [Result] fullTest = do use Nat * + eq drop - + numThreads = 100 iterations = 100 expected = numThreads * iterations @@ -112,17 +120,17 @@ fullTest = do thread n = if eq n 0 then () - else + else atomicUpdate state (v -> v + 1) thread (drop n 1) void (spawnN numThreads '(thread iterations)) result = Ref.read state check "The state of the counter is consistent "(eq result expected) - + runTest test ``` -```ucm -.> add -.> io.test fullTest +``` ucm +scratch/main> add +scratch/main> io.test fullTest ``` diff --git a/unison-src/transcripts-using-base/ref-promise.output.md b/unison-src/transcripts-using-base/ref-promise.output.md index 727f62e89e..07dd3986ca 100644 --- a/unison-src/transcripts-using-base/ref-promise.output.md +++ b/unison-src/transcripts-using-base/ref-promise.output.md @@ -3,10 +3,10 @@ Ref support a CAS operation that can be used as a building block to change state atomically without locks. -```unison +``` unison casTest: '{io2.IO} [Result] casTest = do - test = do + testPrim = do ref = IO.ref 0 ticket = Ref.readForCas ref v1 = Ref.cas ref ticket 5 @@ -14,45 +14,54 @@ casTest = do Ref.write ref 10 v2 = Ref.cas ref ticket 15 check "CAS fails when there was an intervening write" (not v2) + testBoxed = do + ref = IO.ref ("a", "b") + ticket = Ref.readForCas ref + v1 = Ref.cas ref ticket ("c", "d") + check "CAS is successful is there were no conflicting writes" v1 + Ref.write ref ("e", "f") + v2 = Ref.cas ref ticket ("g", "h") + check "CAS fails when there was an intervening write" (not v2) - runTest test + runTest testPrim ++ runTest testBoxed ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: casTest : '{IO} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + casTest : '{IO} [Result] -.> io.test casTest +scratch/main> io.test casTest New test results: - - ◉ casTest CAS is successful is there were no conflicting writes - ◉ casTest CAS fails when there was an intervening write - - ✅ 2 test(s) passing - - Tip: Use view casTest to view the source of a test. + 1. casTest ◉ CAS is successful is there were no conflicting writes + ◉ CAS fails when there was an intervening write + ◉ CAS is successful is there were no conflicting writes + ◉ CAS fails when there was an intervening write + + ✅ 4 test(s) passing + + Tip: Use view 1 to view the source of a test. ``` + Promise is a simple one-shot awaitable condition. -```unison +``` unison promiseSequentialTest : '{IO} [Result] promiseSequentialTest = do test = do @@ -80,55 +89,52 @@ promiseConcurrentTest = do runTest test ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: promiseConcurrentTest : '{IO} [Result] promiseSequentialTest : '{IO} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + promiseConcurrentTest : '{IO} [Result] promiseSequentialTest : '{IO} [Result] -.> io.test promiseSequentialTest +scratch/main> io.test promiseSequentialTest New test results: - - ◉ promiseSequentialTest Should read a value that's been written - ◉ promiseSequentialTest Promise can only be written to once - + + 1. promiseSequentialTest ◉ Should read a value that's been written + ◉ Promise can only be written to once + ✅ 2 test(s) passing - - Tip: Use view promiseSequentialTest to view the source of a - test. -.> io.test promiseConcurrentTest + Tip: Use view 1 to view the source of a test. + +scratch/main> io.test promiseConcurrentTest New test results: - - ◉ promiseConcurrentTest Reads awaits for completion of the Promise - + + 1. promiseConcurrentTest ◉ Reads awaits for completion of the Promise + ✅ 1 test(s) passing - - Tip: Use view promiseConcurrentTest to view the source of a - test. + Tip: Use view 1 to view the source of a test. ``` + CAS can be used to write an atomic update function. -```unison +``` unison atomicUpdate : Ref {IO} a -> (a -> a) ->{IO} () atomicUpdate ref f = ticket = Ref.readForCas ref @@ -136,31 +142,30 @@ atomicUpdate ref f = if Ref.cas ref ticket value then () else atomicUpdate ref f ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: atomicUpdate : Ref {IO} a -> (a -> a) ->{IO} () - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - - atomicUpdate : Ref {IO} a -> (a -> a) ->{IO} () + atomicUpdate : Ref {IO} a -> (a -> a) ->{IO} () ``` + Promise can be used to write an operation that spawns N concurrent tasks and collects their results -```unison +``` unison spawnN : Nat -> '{IO} a ->{IO} [a] spawnN n fa = use Nat eq drop @@ -175,36 +180,35 @@ spawnN n fa = map Promise.read (go n []) ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: spawnN : Nat -> '{IO} a ->{IO} [a] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - - spawnN : Nat -> '{IO} a ->{IO} [a] + spawnN : Nat -> '{IO} a ->{IO} [a] ``` + We can use these primitives to write a more interesting example, where multiple threads repeatedly update an atomic counter, we check that the value of the counter is correct after all threads are done. -```unison +``` unison fullTest : '{IO} [Result] fullTest = do use Nat * + eq drop - + numThreads = 100 iterations = 100 expected = numThreads * iterations @@ -214,44 +218,42 @@ fullTest = do thread n = if eq n 0 then () - else + else atomicUpdate state (v -> v + 1) thread (drop n 1) void (spawnN numThreads '(thread iterations)) result = Ref.read state check "The state of the counter is consistent "(eq result expected) - + runTest test ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: fullTest : '{IO} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + fullTest : '{IO} [Result] -.> io.test fullTest +scratch/main> io.test fullTest New test results: - - ◉ fullTest The state of the counter is consistent - + + 1. fullTest ◉ The state of the counter is consistent + ✅ 1 test(s) passing - - Tip: Use view fullTest to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/serial-test-00.md b/unison-src/transcripts-using-base/serial-test-00.md index ab71adfdd4..4c5f5bb79c 100644 --- a/unison-src/transcripts-using-base/serial-test-00.md +++ b/unison-src/transcripts-using-base/serial-test-00.md @@ -1,4 +1,4 @@ -```unison +``` unison structural type Tree a = Leaf | Node (Tree a) a (Tree a) foldMap : r -> (r -> r -> r) -> (a -> r) -> Tree a -> r @@ -67,7 +67,7 @@ mkTestCase = do saveTestCase "case-00" "v4" f tup ``` -```ucm -.> add -.> run mkTestCase +``` ucm +scratch/main> add +scratch/main> run mkTestCase ``` diff --git a/unison-src/transcripts-using-base/serial-test-00.output.md b/unison-src/transcripts-using-base/serial-test-00.output.md index 715680f06b..a116fcc248 100644 --- a/unison-src/transcripts-using-base/serial-test-00.output.md +++ b/unison-src/transcripts-using-base/serial-test-00.output.md @@ -1,4 +1,4 @@ -```unison +``` unison structural type Tree a = Leaf | Node (Tree a) a (Tree a) foldMap : r -> (r -> r -> r) -> (a -> r) -> Tree a -> r @@ -67,14 +67,13 @@ mkTestCase = do saveTestCase "case-00" "v4" f tup ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: structural type Tree a @@ -92,13 +91,13 @@ mkTestCase = do tree1 : Tree Nat tree2 : Tree Nat tree3 : Tree Text - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + structural type Tree a evaluate : (Tree Nat -> Nat) -> (Tree Text -> Text) @@ -115,8 +114,7 @@ mkTestCase = do tree2 : Tree Nat tree3 : Tree Text -.> run mkTestCase +scratch/main> run mkTestCase () - ``` diff --git a/unison-src/transcripts-using-base/serial-test-01.md b/unison-src/transcripts-using-base/serial-test-01.md index da25e8f4a4..eb0a6fdfa7 100644 --- a/unison-src/transcripts-using-base/serial-test-01.md +++ b/unison-src/transcripts-using-base/serial-test-01.md @@ -1,4 +1,4 @@ -```unison +``` unison l1 = [1.0,2.0,3.0] l2 = [+1,+2,+3] l3 = [?a, ?b, ?c] @@ -15,7 +15,7 @@ mkTestCase = do saveTestCase "case-01" "v4" combines (l1, l2, l3) ``` -```ucm -.> add -.> run mkTestCase +``` ucm +scratch/main> add +scratch/main> run mkTestCase ``` diff --git a/unison-src/transcripts-using-base/serial-test-01.output.md b/unison-src/transcripts-using-base/serial-test-01.output.md index 9194621631..d7deff53f2 100644 --- a/unison-src/transcripts-using-base/serial-test-01.output.md +++ b/unison-src/transcripts-using-base/serial-test-01.output.md @@ -1,4 +1,4 @@ -```unison +``` unison l1 = [1.0,2.0,3.0] l2 = [+1,+2,+3] l3 = [?a, ?b, ?c] @@ -15,14 +15,13 @@ mkTestCase = do saveTestCase "case-01" "v4" combines (l1, l2, l3) ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: combines : ([Float], [Int], [Char]) -> Text @@ -30,21 +29,20 @@ mkTestCase = do l2 : [Int] l3 : [Char] mkTestCase : '{IO, Exception} () - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + combines : ([Float], [Int], [Char]) -> Text l1 : [Float] l2 : [Int] l3 : [Char] mkTestCase : '{IO, Exception} () -.> run mkTestCase +scratch/main> run mkTestCase () - ``` diff --git a/unison-src/transcripts-using-base/serial-test-02.md b/unison-src/transcripts-using-base/serial-test-02.md index 3d13ee487b..827d36f3ce 100644 --- a/unison-src/transcripts-using-base/serial-test-02.md +++ b/unison-src/transcripts-using-base/serial-test-02.md @@ -1,4 +1,4 @@ -```unison +``` unison structural ability Exit a where exit : a -> b @@ -29,7 +29,7 @@ mkTestCase = do ``` -```ucm -.> add -.> run mkTestCase +``` ucm +scratch/main> add +scratch/main> run mkTestCase ``` diff --git a/unison-src/transcripts-using-base/serial-test-02.output.md b/unison-src/transcripts-using-base/serial-test-02.output.md index a6957230e9..9b91fe1aac 100644 --- a/unison-src/transcripts-using-base/serial-test-02.output.md +++ b/unison-src/transcripts-using-base/serial-test-02.output.md @@ -1,4 +1,4 @@ -```unison +``` unison structural ability Exit a where exit : a -> b @@ -29,14 +29,13 @@ mkTestCase = do ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: structural ability Exit a @@ -46,13 +45,13 @@ mkTestCase = do mkTestCase : '{IO, Exception} () prod : [Nat] -> Nat products : ([Nat], [Nat], [Nat]) -> Text - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + structural ability Exit a l1 : [Nat] l2 : [Nat] @@ -61,8 +60,7 @@ mkTestCase = do prod : [Nat] -> Nat products : ([Nat], [Nat], [Nat]) -> Text -.> run mkTestCase +scratch/main> run mkTestCase () - ``` diff --git a/unison-src/transcripts-using-base/serial-test-03.md b/unison-src/transcripts-using-base/serial-test-03.md index d1f49c4040..fb68b0458b 100644 --- a/unison-src/transcripts-using-base/serial-test-03.md +++ b/unison-src/transcripts-using-base/serial-test-03.md @@ -1,4 +1,4 @@ -```unison +``` unison structural ability DC r where shift : ((a -> r) -> r) -> a @@ -43,7 +43,7 @@ mkTestCase = do saveTestCase "case-03" "v4" finish trip ``` -```ucm -.> add -.> run mkTestCase +``` ucm +scratch/main> add +scratch/main> run mkTestCase ``` diff --git a/unison-src/transcripts-using-base/serial-test-03.output.md b/unison-src/transcripts-using-base/serial-test-03.output.md index c161d048bd..72c15ebbdf 100644 --- a/unison-src/transcripts-using-base/serial-test-03.output.md +++ b/unison-src/transcripts-using-base/serial-test-03.output.md @@ -1,4 +1,4 @@ -```unison +``` unison structural ability DC r where shift : ((a -> r) -> r) -> a @@ -43,14 +43,13 @@ mkTestCase = do saveTestCase "case-03" "v4" finish trip ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: structural ability DC r @@ -65,13 +64,13 @@ mkTestCase = do mkTestCase : '{IO, Exception} () reset : '{DC r} r -> r suspSum : [Nat] -> Delayed Nat - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + structural ability DC r structural type Delayed r feed : Nat -> Delayed r -> r @@ -84,8 +83,7 @@ mkTestCase = do reset : '{DC r} r -> r suspSum : [Nat] -> Delayed Nat -.> run mkTestCase +scratch/main> run mkTestCase () - ``` diff --git a/unison-src/transcripts-using-base/serial-test-04.md b/unison-src/transcripts-using-base/serial-test-04.md index f4763238f6..67c699e267 100644 --- a/unison-src/transcripts-using-base/serial-test-04.md +++ b/unison-src/transcripts-using-base/serial-test-04.md @@ -1,4 +1,4 @@ -```unison +``` unison mutual0 = cases 0 -> "okay" @@ -13,7 +13,7 @@ mkTestCase = do saveTestCase "case-04" "v4" mutual1 5 ``` -```ucm -.> add -.> run mkTestCase +``` ucm +scratch/main> add +scratch/main> run mkTestCase ``` diff --git a/unison-src/transcripts-using-base/serial-test-04.output.md b/unison-src/transcripts-using-base/serial-test-04.output.md index ca1949502d..9e45041b57 100644 --- a/unison-src/transcripts-using-base/serial-test-04.output.md +++ b/unison-src/transcripts-using-base/serial-test-04.output.md @@ -1,4 +1,5 @@ -```unison +``` unison + mutual0 = cases 0 -> "okay" n -> @@ -12,32 +13,30 @@ mkTestCase = do saveTestCase "case-04" "v4" mutual1 5 ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: mkTestCase : '{IO, Exception} () mutual0 : Nat -> Text mutual1 : Nat -> Text - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + mkTestCase : '{IO, Exception} () mutual0 : Nat -> Text mutual1 : Nat -> Text -.> run mkTestCase +scratch/main> run mkTestCase () - ``` diff --git a/unison-src/transcripts-using-base/serialized-cases/case-00.v3.ser b/unison-src/transcripts-using-base/serialized-cases/case-00.v3.ser deleted file mode 100644 index c2c2a191f1..0000000000 --- a/unison-src/transcripts-using-base/serialized-cases/case-00.v3.ser +++ /dev/null @@ -1 +0,0 @@ -AAAAAAYBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAABAGAIDAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYCAAASCABEJQL3GHBIMDX5JPPWYFOZ223DZ3ITSUCKHECCW76BTMFCNHASHQAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAMDAABABAEAQCBQAAQAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAQAAAAQCAIDAEAQCCYAAEAQCAYBAEQQAJCMC6ZRYKDA57KL35WBLWOWWY6O2E4VASRZAQVX7QM3BITJYER4AACAMBIEAIFQAAQBAEBQABYBAIFQAAYBAEBQCAJBAASEYF5TDQUGB36UXX3MCXM5NNR45UJZKBFDSBBLP7AZWCRGTQJDYAAEBADQMAQLAACACAIDAAEAEAIAAMAASAQDAAAACAKAAAX7CUYLIPZBB2NU3HFA3VZZPIBMNKJFWD2AXSYRTBZ7VTXTVE3DR23R7ZB6XCZEAZ5QURR4XOHRYMYNJA3D2NV64JQ6S7RHTD2M2AQAAAAAAAAAAAAAAAAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYCAAASCABY54MKDAPBPRJ7CPHBAK36YKBIALXQMXI22MHCH6OX3RZNMAPIFEAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAMDAAAIBAEAACAKAAAX7CUYLIPZBB2NU3HFA3VZZPIBMNKJFWD2AXSYRTBZ7VTXTVE3DR23R7ZB6XCZEAZ5QURR4XOHRYMYNJA3D2NV64JQ6S7RHTD2M2AQAAAAAAAAAAAAAAAAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYCAAASCAEJOCTGNW2P26UFUL4ED6HHI6AMSK5UTY4X2ML63KIV5WR6XGRQ4AAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAMDAAAYBAEAQMAAEAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAACAACAEAQMAAEAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAACAACAEAQMAAEAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAACAACAEAQMAAEAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAACAACAEAQMAAEAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAACAAABMAA4AIBAMAAUAIHBMAA2AIBAMAAWAIGBMAAYAIBAMAAYAIFBMAAWAIBAMAAYAIEBIAQCBYDAEUAWAABAEAQGAIABJHGC5BOORXVIZLYOQAQICYAAIAQCAYBAADVIZLYOQXCWKYCAEAAUAIBA4BQELBABMAAGAIBAMAQAB2UMV4HILRLFMBACAALAACACAIDAEAAUTTBOQXHI32UMV4HIAIHBMAAKAIBAMAQAB2UMV4HILRLFMBACAAKAEAQOAYCFQQAWAAGAEAQGAIAA5KGK6DUFYVSWAQBAAFQABYBAEBQCAAKJZQXILTUN5KGK6DUAEFAWAAIAEAQGAIAA5KGK6DUFYVSWAQBAAFACAIHAMBCYIALAAEQCAIDAEAAOVDFPB2C4KZLAIAQACYABIAQCAYBAADVIZLYOQXCWKYCAAGQUAIBA4BQCKIDAEAAOVDFPB2C4KZLAIAQAAAAAAAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAAAQDAUAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAAAQAAEQQBCLQUZTNWT6XVBNC7BA7RZ2HQDESXNE6HF6TC7W2SFPNUPVZUMHAAAAAAAAAAAAAAAAAAIAACIIAERGBPMY4FBQO7VF563AV3HLLMPHNCOKQJI4QIK37YGNQUJU4CI6AAAAAAAAAAAAAAAAAGAABEEADR3YYUGA6C7CT6E6OCAVX5QUCQAXPAZORVUYOEP45PXDS2YA6QKIAAAAAAAAAAAAAAAAAAAAAKTTBOQXCWAAAAAAAAAAAAAAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAAAAAAJBAASEYF5TDQUGB36UXX3MCXM5NNR45UJZKBFDSBBLP7AZWCRGTQJDYAAAAAAAAAAAAAAAAAYAAEQQAOHPDCQYDYL4KPYTZYICW7WCQKAC54DF2GWTBYR7TV64OLLAD2BJAAAAAAAAAAAAAAAAAAAAAB2UMV4HILRLFMAAAAAAAAAAAAAAAABQAAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAABACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIAAMAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAAAAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAABAAAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAIAAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAYAAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAABAAAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAQAAYBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAABAABQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAACAADAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAIAACAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAACAABAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAABAABQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAGAABAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAABAABQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAIAABAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAAAAAAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAAAAAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAQAAYBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAABAABQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAACAADAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAA4AACAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAMAABAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAABAABQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAQAABAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAABAABQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAASAABAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAAAAAAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAFAAAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAAAAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAABACAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAACAADAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIAAMAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAAAAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAABAAAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAIAAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAYAAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAABAAAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAABIAACAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAACAADAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIAAMAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAAAAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAABAAAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAIAAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAYAAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAABAAAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAAAACAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAACAADAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIAAMAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAAAAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAADQAAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAABQAAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAACAAAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAACIAAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAUAACAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIAAMAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAQAAYBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAAAAAAAGAAFNBSWY3DPAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAAAYAAEQACAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAACAADAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEAAGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAABQABDHN5XWIAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAABQAA3CPFSQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAAAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAA= \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-00.v5.hash b/unison-src/transcripts-using-base/serialized-cases/case-00.v5.hash new file mode 100644 index 0000000000..181c564dc3 --- /dev/null +++ b/unison-src/transcripts-using-base/serialized-cases/case-00.v5.hash @@ -0,0 +1 @@ +Z6EW6IDZJXHDMNGTVSKYLMZVG47ORYF4O6JDQXQGQFJP476SLM75FXFOYI27OJHMIX5OIHKQ6LXWLYQ5LDGEYWEXK6GQPP6JKH6SVMI= \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-00.v5.ser b/unison-src/transcripts-using-base/serialized-cases/case-00.v5.ser new file mode 100644 index 0000000000..afdd5055e3 --- /dev/null +++ b/unison-src/transcripts-using-base/serialized-cases/case-00.v5.ser @@ -0,0 +1 @@ +AAAAABIBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQCAYBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQEAABEEACITAXWMOCQYHP2S67NQK5TVVWHTWRHFIEUOIEFN74DGYKE2OBEPAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGBQAAQAQCAIBAYAAIAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAIAAAAIBAEBQCAIBBMAACAIBAMAQCIIAERGBPMY4FBQO7VF563AV3HLLMPHNCOKQJI4QIK37YGNQUJU4CI6AABAGAUCAECYAAIAQCAYAA4AQECYAAMAQCAYBAEQQAJCMC6ZRYKDA57KL35WBLWOWWY6O2E4VASRZAQVX7QM3BITJYER4AACAQBYGAIFQABABAEBQACACAEAAGAAJAIBQAAAAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAQDAIAACIIAHDXRRIMB4F6FH4J44EBLP3BIFABO6BS5DLJQ4I7Z27OHFVQB5AUQAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMDAAAIBAEAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGAQAAEQQBCLQUZTNWT6XVBNC7BA7RZ2HQDESXNE6HF6TC7W2SFPNUPVZUMHAAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAYGAABQCAIBAYAAIAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAEAAEAIBAYAAIAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAEAAEAIBAYAAIAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAEAAEAIBAYAAIAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAEAAEAIBAYAAIAKAAAX7CUYLIPZBB2NU3HFA3VZZPIBMNKJFWD2AXSYRTBZ7VTXTVE3DR23R7ZB6XCZEAZ5QURR4XOHRYMYNJA3D2NV64JQ6S7RHTD2M2AQAAEAAACYABYAQCAYABIAQOCYABUAQCAYABMAQMCYABQAQCAYABQAQKCYABMAQCAYABQAQICQBAEDQGAJIBMAACAIBAMAQACSOMF2C45DPKRSXQ5ABAQFQAAQBAEBQCAAHKRSXQ5BOFMVQEAIABIAQCBYDAIWCACYAAMAQCAYBAADVIZLYOQXCWKYCAEAAWAAEAEAQGAIABJHGC5BOORXVIZLYOQAQOCYAAUAQCAYBAADVIZLYOQXCWKYCAEAAUAIBA4BQELBABMAAMAIBAMAQAB2UMV4HILRLFMBACAALAADQCAIDAEAAUTTBOQXHI32UMV4HIAIKBMAAQAIBAMAQAB2UMV4HILRLFMBACAAKAEAQOAYCFQQAWAAJAEAQGAIAA5KGK6DUFYVSWAQBAAFQACQBAEBQCAAHKRSXQ5BOFMVQEAANBIAQCBYDAEUQGAIAA5KGK6DUFYVSWAQBAAAAAAAAAAAACAKAAAX7CUYLIPZBB2NU3HFA3VZZPIBMNKJFWD2AXSYRTBZ7VTXTVE3DR23R7ZB6XCZEAZ5QURR4XOHRYMYNJA3D2NV64JQ6S7RHTD2M2AQAAAAAAAAAAAAAAAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQKAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAAASCAEJOCTGNW2P26UFUL4ED6HHI6AMSK5UTY4X2ML63KIV5WR6XGRQ4AAAAAAAAAAAAAAAAIAACIIAERGBPMY4FBQO7VF563AV3HLLMPHNCOKQJI4QIK37YGNQUJU4CI6AAAAAAAAAAAAAAABQAAJBAA4O6GFBQHQXYU7RHTQQFN7MFAUAF3YGLUNNGDRD7HL5Y4WWAHUCSAAAAAAAAAAAAAAAAAAAAVHGC5BOFMAAAAAAAAAAAAAAAMEAAAABEEACITAXWMOCQYHP2S67NQK5TVVWHTWRHFIEUOIEFN74DGYKE2OBEPAAAAAAAAAAAAAAAAYAAEQQAOHPDCQYDYL4KPYTZYICW7WCQKAC54DF2GWTBYR7TV64OLLAD2BJAAAAAAAAAAAAAAAAAAAAOVDFPB2C4KZLAAAAAAAAAAAAAAADAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAQBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAQGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIDAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAGCACAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAGCABAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEBQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAADBABQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAACAYBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAAAAABQQBABAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAAAAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIDAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEBQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAACAYBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAAAAABQQAQBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAAAAABQQAIBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAABAMAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAAAAYIAMAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAQGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAMEAIAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAMEAAAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIDAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEBQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAACAYBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAAAAABQQBYBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAAAAABQQBQBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAABAMAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAAAAYIBAAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAQGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAMEASAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAMEAKAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABACAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAACAYBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAABAMAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAQGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAMEAEAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAMEACAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIDAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAGCADAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEBQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAADBACACAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAADBAFACAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAACAYBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAABAMAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAQGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAMEAEAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAMEACAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIDAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAGCADAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEBQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAADBACACAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAADBAAACAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAACAYBAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAABAMAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAQGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAMEAOAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAAAAMEAMAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIDAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAGCAIAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAEBQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAADBAEQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAADBACQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAQGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIDAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAGAAFNBSWY3DPAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAGAABEAAQCQFLNOASV6MR5HG6P3HFFKN2IW7E4DK75AL4PFVOBRGHLB55BOHFMRTBHEHGBWKEQOK5SZZZ7AXGFJUNVTX7PRKUK2DUMTL4ERO7HQAPYAAAAAAAAAAAAAAQGAIBICVWXAJK7GI6TTPH5TSSVG5ELPSOBVP6QF6HS2XAYTDVQ66QXDSWIZQTSDTA3FCIHFOZM447QLTCU2G2Z37XYVKFNB2GJV6CIXPTYAH4AAAAAAAAAAAAAAIDAEAUBK3LQEVPTEPJZXT6ZZJKTOSFXZHA2X7IC7DZNLQMJR2YPPILRZLEMYJZBZQNSREDSXMWOOPYFZRKNDNM5734KVCWQ5DE27BELXZ4AD6AAAAAAAAAAAAAAAAAGAAEM5XW6ZABAFAKW24BFL4ZD2ON47WOKKU3URN6JYGV72AXY6LK4DCMOWD32C4OKZDGCOIOMDMUJA4V3FTTT6BOMKTI3LHP67CVIVUHIZGXYJC56PAA7QAAAAAAAAAAAAAAAABQAA3CPFSQCAKAVNVYCKXZSHU43Z7M4UVJXJC34TQNL7UBPR4WVYGEY5MHXUFY4VSGME4Q4YGZISBZLWLHHH4C4YVGRWWO756FKRLIORSNPQSF346AB7AAAAAAAAAAAAAAAAABAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAAAAAAAAAAAAAAAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAA \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-01.v3.ser b/unison-src/transcripts-using-base/serialized-cases/case-01.v3.ser deleted file mode 100644 index de087d1496..0000000000 --- a/unison-src/transcripts-using-base/serialized-cases/case-01.v3.ser +++ /dev/null @@ -1 +0,0 @@ -AAAAAAYBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAABAGAIEAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYCAAASCABZFLRYPNZZRJMJUCYY6M4NSX5WH6MF6JAGXDI4HSXGNYHXQRGT5MAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAMDAABABAEAQCCYAAMAQCAYBAADUY2LTOQXGC5ACAABQMAAEAFALZN4S4OANDE4CHA7E4R6TLLNDKTMO27HHZB2OLDWY3AGZJGZ72KIKUMEV73X2VZQOFL7PW7OHRSHQ5NZL6B2OWFIK4WNPU4PLOBOK6IAAEAABAEFQAAIBAEBQABACAMAAUAIAA4AQAAAAAAAAAAABBIAQCAYDAABU4YLUAAAQACYAAIAQCAYBAACU4YLUFYVQEBIAAMAQCIIAHEVOHB5XHGFFRGQLDDZTRWK7WY7ZQXZEA24NDQ6K4ZXA66CE2PVQABAJBABQAAIAAEBAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAAAQDAIAACIIAQYMIPCBVBNP3S5SFG3T6BWR6EJOIV6XGQRUTMQ63KF5YYLGD7VSAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQMAABAEDAABABIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAQAAQBAEDAABABIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAQAAQBAEDAABABIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAQAAQBAEDAABABIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAQAAALAAAQCAIDAEAAORTMN5QXILRLAAFACAAHAIAAAAAAAAAAAAAKAEAQGAYAAVDGY33BOQAACAALAAGQCAIDAEASCAGHFNRMQEP5G2FCRDWLLUNLMZHPE3SDCI7UBZVD25TA6YYJ6OKN3IAAGAQABAFQAAQBAEBQCAAFJFXHILRLAAFACAAHAAAAAAAAAAAAAAAKAEAQGAYAANEW45AAAEAAWAAMAEAQGAIBEEAMOK3CZAI72NUKFCHMWXI2WZSO6JXEGER7IDTKHV3GB5RQT44U3WQAAMBAACQLAABQCAIDAEASCAEUDIV2ECRTIY7TAIXLDHZPSJJP6UFOC5SYSJ7RS4QYOWIOZPZIIIAAACQBAEDQGAALAAFQCAIDAEASCAGHFNRMQEP5G2FCRDWLLUNLMZHPE3SDCI7UBZVD25TA6YYJ6OKN3IAAGAIABMFACAIHAMASQCYAAQAQCAYBAAGEM3DPMF2C45DPKRSXQ5ABBAFQABIBAEBQCAAHKRSXQ5BOFMVQEAIABIAQCBYDAIWCACYAAYAQCAYBAADVIZLYOQXCWKYCAEAAWAAHAEAQGAIABJEW45BOORXVIZLYOQAQQCYABAAQCAYBAADVIZLYOQXCWKYCAEAAUAIBA4BQGLBAEIFQACIBAEBQCAAHKRSXQ5BOFMVQEAIABMAAUAIBAMAQAB2UMV4HILRLFMBAACIKAEAQOAYCEIUQGAIAA5KGK6DUFYVSWAQBAAAAAAAAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQEAABEEAJIGRLUIFDGRR7GAROWGPS7ESS75IK4F3FRET7DFZBQ5MQ5S7SQQQAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYGAABACAILAAAQCAIDAEAAWQ3IMFZC45DPKRSXQ5ABAABQCAAHKRSXQ5BOFMVQEAQAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQEAABEEAMOK3CZAI72NUKFCHMWXI2WZSO6JXEGER7IDTKHV3GB5RQT44U3WQAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYGAABQCAIBBIAQABYBAAAAAAAAAAAAACQBAEBQGAADJZQXIAABAABQCAJBAA4SVY4HW44YUWE2BMMPGOGZL63D7GC7EQDLRUODZLTG4D3YITJ6WAAEAICAGAABAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAAAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAMCQCAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAAASCAEGDCDYQNILL64XMRJW47QNUPRCLSFPVZUENE3EHW2RPOGCZQ75MQAAAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYBAMAQABKGNRXWC5AAAAAAAAAAAAAACP7QAAAAAAAAAAAACAAFIZWG6YLUAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAIAAVDGY33BOQAAAAAAAAAAAAABIAEAAAAAAAAAAAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAABAGAIDAEAAGSLOOQAAAAAAAAAAAAABAAAAAAAAAAAACAABAABUS3TUAAAAAAAAAAAAAAIAAAAAAAAAAABAAAIAANEW45AAAAAAAAAAAAAACAAAAAAAAAAAAMAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAMAQGAIAARBWQYLSAAAAAAAAAAAAAAIAAAAAAAAAABQQAAIAARBWQYLSAAAAAAAAAAAAAAIAAAAAAAAAABRAAAIAARBWQYLSAAAAAAAAAAAAAAIAAAAAAAAAABRQAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAABAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAAAAAAAAAAAAAAAAAA==== \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-01.v5.hash b/unison-src/transcripts-using-base/serialized-cases/case-01.v5.hash new file mode 100644 index 0000000000..d576afd225 --- /dev/null +++ b/unison-src/transcripts-using-base/serialized-cases/case-01.v5.hash @@ -0,0 +1 @@ +F5QWFLMAWQDYCMOPDCCTYLWJ2HOBGUG2G5YLWHSAFGDXSHGYQIWDSN6PVWC2RJXIGB7ZBSZVIJ6OENKGWAEZIV3CLQ2AWL3WKITPDXA= \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-01.v5.ser b/unison-src/transcripts-using-base/serialized-cases/case-01.v5.ser new file mode 100644 index 0000000000..071ca615cb --- /dev/null +++ b/unison-src/transcripts-using-base/serialized-cases/case-01.v5.ser @@ -0,0 +1 @@ +AAAAABIBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQCBABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQEAABEEAFG5MMPCUOP3IIQXASYKKG2MIJ2XJ3B7MGFL6E44DZUAQUNLQVKHIAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGBQAAMAQCAIKAEAQYAIAAAAAAAAAAAAAGAIBEEAO7KOJ7HCZGJXDGV7GZE7OLVCVEIO5QE4Y6TLY67FZSQS6DUK2SVYAAQAQGAQAAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMBAAAJBACAVWVMCTIBA5P5JFQIRMCJBBMWMLBPXDOTQRHHF76XEAPI46LZWWAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQMAABAEDAABABIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAQAAQBAEDAABABIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAQAAQBAEDAABABIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAQAAQBAEDAABABIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAQAAALAAAQCAIDAEAAORTMN5QXILRLAAFACAIMAIAAAAAAAAAAAAALAAGQCAIDAEASCACTOWGHRKHH5UEILQJMFFDNGEE5LU5Q7WDCV7COOB42AIKGVYKVDUAAGAIAA4FQAAQBAEBQCAAFJFXHILRLAAFACAIMAAAAAAAAAAAAAAALAAGACAIDAEASCACTOWGHRKHH5UEILQJMFFDNGEE5LU5Q7WDCV7COOB42AIKGVYKVDUAAGAIABAFQAAYBAEBQCAJBACKBUK5CBIZUMPZQELVRT4XZEUX7KCXBOZMJE7YZOIMHLEHMX4UEEAAABIAQCBYDAAFQACYBAEBQCAJBABJXLDDYVDT62CEFYEWCSRWTCCOV2OYP3BRK7RHHA6NAEFDK4FKR2AADAEAASCQBAEDQGAJIBMAAIAIBAMAQADCGNRXWC5BOORXVIZLYOQAQOCYAAUAQCAYBAADVIZLYOQXCWKYCAEAAUAIBA4BQELBABMAAMAIBAMAQAB2UMV4HILRLFMBACAALAADQCAIDAEAAUSLOOQXHI32UMV4HIAIIBMAAQAIBAMAQAB2UMV4HILRLFMBACAAKAEAQOAYDFQQCECYABEAQCAYBAADVIZLYOQXCWKYCAEAAWAAKAEAQGAIAA5KGK6DUFYVSWAQABEFACAIHAMBCEKIDAEAAOVDFPB2C4KZLAIAQAAAAAAAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGAQAAEQQBFA2FORAUM2GH4YCF2YZ6L4SKL7VBLQXMWESP4MXEGDVSDWL6KCCAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAYGAABACAILAAAQCAIDAEAAWQ3IMFZC45DPKRSXQ5ABAABQCAAHKRSXQ5BOFMVQEAQAAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMBAAAJBADX2TSPZYWJSNYZVPZWJH3S5IVJCDXMBHGHU26HXZOMUEXQ5CWUVOAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQMAAEAEAQCAILAABQCAIDAEAAOTDJON2C4YLUAIAAGBQAAQAUBPFXSLRYBUMTQI4D4TSH2NNNUNKNR3L447EHJZMO3DMA3FE3H7JJBKRQSX7O7KXGBYVP5635Y6GI6DVXFPYHJ2YVBLSZV6TR5NYFZLZAAAQAAEAQWAABAEAQGAAEAIBQACQBAEGACAAAAAAAAAAAAEFQAAQBAEBQCAAFJZQXILRLAICAAAYBAEQQB35JZH44LEZG4M2X43ET5ZOUKURB3WATTD2NPD34XGKCLYORLKKXAACAQBYCAAAQAAICAAAACAKAAAX7CUYLIPZBB2NU3HFA3VZZPIBMNKJFWD2AXSYRTBZ7VTXTVE3DR23R7ZB6XCZEAZ5QURR4XOHRYMYNJA3D2NV64JQ6S7RHTD2M2AQAAAAAAAAAAAAAAAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQKAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAAASCAEBLNKYFGQCB272SLARCYESCCZMYWC7OG5HBCOOL75OIA6RZ4XTNMAAAAAAAAAAAAAAAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMAQGAYLH7YAAAAAAAAAAAYLIAAAAAAAAAAAAAYLIAEAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMAQGAYIAEBQQAQDBABQCAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAQDAEBQGCTBAMFGEAYKMMAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAA==== \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-02.v3.ser b/unison-src/transcripts-using-base/serialized-cases/case-02.v3.ser deleted file mode 100644 index 4a1d4e2237..0000000000 --- a/unison-src/transcripts-using-base/serialized-cases/case-02.v3.ser +++ /dev/null @@ -1 +0,0 @@ -AAAAAAYBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAABAGAIFAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYCAAASCAABWEQKZVTA34OQNVOLD4GRH72HLOHCHQEYO4JJPWXD6HBMRKR6L4AACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAMDAAAQBAEFQAAQBAEBQCAAKJRUXG5BOOZUWK53MAEAAMAAEAFADPJIFOASFNIGUEE6ABTI5E6ON24BBMZ7CAQAE3AN2OXOWNV3ET5LZKZZWA57Q7DDA5SHTB4NDM7M4HPYI6EFBI7M72VZDNJCL63URRAAAEAACAEAQMAIEAABU4YLUAEAACAAGAAAACAAAAAAAAAAAAAFACAAHAEAAAAAAAAAAAAAKAEAQGAYAANHGC5AAAEAAGBABIAZR522FFIW2QNIQTV45PSZZV4R5VXT52UC5SIS3TTQZ6XJ36SN6JLO6DPP44KYTTAVNI6ERW7OAEWHHJ63TJMEDFONVPC3T6QZVW3NHAAAACAABBMAACAIBAMAQABKOMF2C4KQCAUBAGAIBEEAADMJAVTLGBXY5A3K4WHYNCP7UOW4OEPAJQ5YSS7NOH4OCZCVD4XYAAIAAEAABAAAQEAABAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAAAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAMBAAAJBABINM6WVR5VXSHZHLHI7QKDZ4EYHDZDXV7CQVDPR6N6TR75XWQLOAAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAABAGBQAAEAQWAABAEAQGAIBEEAGIJEYGWCVEET6QTADG3PYT3IZ4NY6GSPWISPD4BLO2G6RVUBTCMYAAAEACIIARH76IQRIUZMLQUQ3OMILAPHXZJGRFJ5Z4JQMMVNZZFXO2M4JFZNQAAIBAMAACAIAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQEAABEEAGIJEYGWCVEET6QTADG3PYT3IZ4NY6GSPWISPD4BLO2G6RVUBTCMYAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYGAEAQCBQAAIAQCQBTD3VUKKRNVA2RBHLZ27FTTLZD3LPH3VIF3ERFXHHBT5OTX5E34SW54G67ZYVRHGBK2R4JDN64AJMOOT5XGSYIGK43K6FXH5BTLNW2OAABAAAQCBIBIAZR522FFIW2QNIQTV45PSZZV4R5VXT52UC5SIS3TTQZ6XJ36SN6JLO6DPP44KYTTAVNI6ERW7OAEWHHJ63TJMEDFONVPC3T6QZVW3NHAAEAACDKOVWXAQ3PNZ2ACAABAIAQAAIBBEAQABABAFADGHXLIUVC3KBVCCOXTV6LHGXSHWW6PXKQLWJCLOOODH25HP2JXZFN3YN57TRLCOMCVVDYSG35YASY45H3ONFQQMVZWV4LOP2DGW3NU4AAAAQBAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQEAABEEAIT77EIIUKMWFYKINXGEFQHT34UTISU646EYGGKW44S3XNGOES4WYAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYGAAAQCCQBAADQCAAAAAAAAAAAAAFACAIDAMAAGTTBOQAACAADAEASCAABWEQKZVTA34OQNVOLD4GRH72HLOHCHQEYO4JJPWXD6HBMRKR6L4AAEAACAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQEAABEEALTMJU3MI3LHRHUSEX3BATWO6NXEOBXKBFJ7AUAVPNE63A5X3SXEAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYGAAAQCBQAAQAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAIAAIAQCBQAAQAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAIAAIAQCBQAAQAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAIAAIAQCBQAAQAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAIAAAFQACYBAEBQCAJBABINM6WVR5VXSHZHLHI7QKDZ4EYHDZDXV7CQVDPR6N6TR75XWQLOAAABAUFQACQBAEBQCAJBABINM6WVR5VXSHZHLHI7QKDZ4EYHDZDXV7CQVDPR6N6TR75XWQLOAAABAQFQACIBAEBQCAJBABINM6WVR5VXSHZHLHI7QKDZ4EYHDZDXV7CQVDPR6N6TR75XWQLOAAABAMFACAIHAMASQCYAAEAQCAYBAAFE4YLUFZ2G6VDFPB2ACAYLAABACAIDAEAAOVDFPB2C4KZLAIAQACQBAEDQGARMEAFQAAYBAEBQCAAHKRSXQ5BOFMVQEAIABMAAIAIBAMAQACSOMF2C45DPKRSXQ5ABAYFQABIBAEBQCAAHKRSXQ5BOFMVQEAIABIAQCBYDAMWCAIQLAADACAIDAEAAOVDFPB2C4KZLAIAQACYAA4AQCAYBAAFE4YLUFZ2G6VDFPB2ACCILAAEACAIDAEAAOVDFPB2C4KZLAIAQACQBAEDQGARCFEBQCAAHKRSXQ5BOFMVQEAIAAAAAAAABAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAAAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAMCQCAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAAASCAFZWE2NWENVTYT2JCL5QQJ3HPG3SHA3VASU7QKAKXWSPNQO35ZLSAAAAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYBAUAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAIAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAGAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAACQAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAA4AACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAJAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAAAQDAEEQCAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAABAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAQAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAAAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAABQAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAQAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAFAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAABQAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAOAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAAEAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQCCABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAAAQAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAIAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAEAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAACAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAABAAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAABQAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAUAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAGAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAABAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAAAAAAAAAAAAAAAAAACAKAAAX7CUYLIPZBB2NU3HFA3VZZPIBMNKJFWD2AXSYRTBZ7VTXTVE3DR23R7ZB6XCZEAZ5QURR4XOHRYMYNJA3D2NV64JQ6S7RHTD2M2AQAAAAAAAAAAAAAAAAA \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-02.v5.hash b/unison-src/transcripts-using-base/serialized-cases/case-02.v5.hash new file mode 100644 index 0000000000..f7f6926bc2 --- /dev/null +++ b/unison-src/transcripts-using-base/serialized-cases/case-02.v5.hash @@ -0,0 +1 @@ +OKXJPQQY4QXSCGDHM2LSUTSIKWE7W5PS6CSYCKBOEOBTRKHOKWTH6QZP7HEVWPEJC5CWGWB54ZPI7YB36F37MXN7ISPCP5JGX26NRBQ= \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-02.v5.ser b/unison-src/transcripts-using-base/serialized-cases/case-02.v5.ser new file mode 100644 index 0000000000..0257e72254 --- /dev/null +++ b/unison-src/transcripts-using-base/serialized-cases/case-02.v5.ser @@ -0,0 +1 @@ +AAAAABIBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQCBIBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQEAABEEAAYIUEFZ4JEHYKKJOYXA3U4QEFR2C7BDWZX43W26BCDHYJLM2O2UYAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGBQAAIAQCCYAAIAQCAYBAAFEY2LTOQXHM2LFO5WACAAGAACACQBXUUCXAJCWUDKCCPAAZUOSPHG5OAQWM7RAIACNQG5HLXLG25SJ6V4VM43AO7YPRRQOZDZQ6GRWPWODX4EPCCQUPWP5K4RWURF7N2IYQAACAABACAIGAEDAAA2OMF2ACAAAAAAAAAAAAAFACAIMAEAAAAAAAAAAAAADAQAUAMY65NCSULNIGUIJ26OXZM426I623Z65KBOZEJNZZYM7LU57JG7EVXPBXX6OFMJZQKWUPCI3PXACLDTU7NZUWCBSXG2XRNZ7IM23NWTQAAABAAAQWAABAEAQGAIAAVHGC5BOFIBAIAIDAEASCAAMEKCC46ESD4FFEXMLQN2OICCY5BPQR3M36N3NPARBT4EVWNHNKMAAEAABAEAACAQAAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMBAAAJBAAQQUM3BJ2CBV2DRYDFJVT73O4QXWQ2FFGAQ65UETP5ZKJGMQUOPIAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQMAABAEDAABABIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAQAAQBAEDAABABIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAQAAQBAEDAABABIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAQAAQBAEDAABABIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAQAAALAAFQCAIDAEASCAHMBCFOX4WLK3FQIFDLLBB3ZZQPJHUEKONSUX2NJGCJJSHMAWVAHQAACBILAAFACAIDAEASCAHMBCFOX4WLK3FQIFDLLBB3ZZQPJHUEKONSUX2NJGCJJSHMAWVAHQAACBALAAEQCAIDAEASCAHMBCFOX4WLK3FQIFDLLBB3ZZQPJHUEKONSUX2NJGCJJSHMAWVAHQAACAYKAEAQOAYBFAFQAAIBAEBQCAAKJZQXILTUN5KGK6DUAEBQWAACAEAQGAIAA5KGK6DUFYVSWAQBAAFACAIHAMBCYIALAABQCAIDAEAAOVDFPB2C4KZLAIAQACYAAQAQCAYBAAFE4YLUFZ2G6VDFPB2ACBQLAACQCAIDAEAAOVDFPB2C4KZLAIAQACQBAEDQGAZMEARAWAAGAEAQGAIAA5KGK6DUFYVSWAQBAAFQABYBAEBQCAAKJZQXILTUN5KGK6DUAEEQWAAIAEAQGAIAA5KGK6DUFYVSWAQBAAFACAIHAMBCEKIDAEAAOVDFPB2C4KZLAIAQAAAAAAAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGAQAAEQQAZBETA2YKUQSP2CMAM3N7CPNDHRXDY2J6ZCJ4PQFN3I32GWQGMJTAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAYGAEAQCBQAAIAQCQBTD3VUKKRNVA2RBHLZ27FTTLZD3LPH3VIF3ERFXHHBT5OTX5E34SW54G67ZYVRHGBK2R4JDN64AJMOOT5XGSYIGK43K6FXH5BTLNW2OAABAAAQCBIBIAZR522FFIW2QNIQTV45PSZZV4R5VXT52UC5SIS3TTQZ6XJ36SN6JLO6DPP44KYTTAVNI6ERW7OAEWHHJ63TJMEDFONVPC3T6QZVW3NHAAEAACDKOVWXAQ3PNZ2ACAABAIAQAAIBBEAQABABAFADGHXLIUVC3KBVCCOXTV6LHGXSHWW6PXKQLWJCLOOODH25HP2JXZFN3YN57TRLCOMCVVDYSG35YASY45H3ONFQQMVZWV4LOP2DGW3NU4AAAAQBAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMBAAAJBABTRHHJSOELTLHBAUQWOZQU2H5SUAC5SDOJNUSQDJ2NEYRSZ4RBDQAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQMAABAEFACAIMAEAAAAAAAAAAAAADAEASCAAMEKCC46ESD4FFEXMLQN2OICCY5BPQR3M36N3NPARBT4EVWNHNKMAAEAABAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMBAAAJBADWARCXL6LFVNSYECRVVQQ544YHUT2CFHGZKL5GUTBEUZDWALKQDYAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQMAABAEFQAAIBAEBQCAJBABSCJGBVQVJBE7UEYAZW36E62GPDOHRUT5SETY7AK3WRXUNNAMYTGAAABAASCADHCOOTE4IXGWOCBJBM5TBJUP3FIAF3EG4S3JFAGTU2JRDFTZCCHAAACAIDAAAQCAAAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAQDAUAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAABEEACCCRTMFHIIGXIOHAMVGWP7N3SC62DIUUYCD3WQSN7XFJEZSCRZ5AAAAAAAAAAAAAAAAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAYBAUBQQAIDBABQGCAFAMEAOAYIBEAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAYBBEBQQAIDBABAGCAAAMEAGAYIAQBQQBIDBADAGCAHAMEAQAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMAQQAYIAEBQQAQDBACAGCAIAMEBAAYIAMBQQBIDBADACAKAAAX7CUYLIPZBB2NU3HFA3VZZPIBMNKJFWD2AXSYRTBZ7VTXTVE3DR23R7ZB6XCZEAZ5QURR4XOHRYMYNJA3D2NV64JQ6S7RHTD2M2AQAAAAAAAAAAAAAAAABAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAAAAAAAAAAAAAAAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAA=== \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-03.v3.ser b/unison-src/transcripts-using-base/serialized-cases/case-03.v3.ser deleted file mode 100644 index 435e66ff65..0000000000 --- a/unison-src/transcripts-using-base/serialized-cases/case-03.v3.ser +++ /dev/null @@ -1 +0,0 @@ -AAAAAAYBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAABAGAIJAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYCAAASCAAHJ5GLRMTZGDAIHWCMVBFQVOID3O6JTDETEG5MZHC3C6AJRBEBWIAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAMDACAIBAYAAEAIBIA3WMQZC4T2RMC6ZEPP5ZNKMTP4JLD42EUQESFNU3ZE6XBO7H47OFPSHSSWYEB4EGRHQJHTH3DUE6CIUQVPAYYPKIKPJNB4DEW52A7H2AAAQAAIBAUAUAN3GIMROJ5IWBPMSHX64WVGJX6EVR6NCKICJCW2N4SPLQXPT6PXCXZDZJLMCA6CDITYETZT5R2CPBEKIKXQMMHVEFHUWQ6BSLO5APT5AACAABBVHK3LQINXW45ABAAFQAAIBAEBQCAJBAADU6TFYWJ4TBQED3BGKQSYKXEB5XPEZRSJSDOWMTRNRPAEYQSA3EAIBAABQAAYBAAAQAAIBBEAQABABAFADOZSDELSPKFQL3ER57XFVJSN7RFMPTISSASIVWTPET24F347T5YV6I6KK3AQHQQ2E6BE6M7MOQTYJCSCV4DDB5JBJ5FUHQMS3XID47IAAAAQBAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQEAABEEAAOT2MXCZHSMGAQPMEZKCLBK4QHW54TGGJGIN2ZSOFWF4ATCCIDMQBAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYGAABACAILAAAQCAIDAEASCAAHJ5GLRMTZGDAIHWCMVBFQVOID3O6JTDETEG5MZHC3C6AJRBEBWIAAACABEEANR5YMZ4O453FLTU6EFVRUUPWHXYW6TUZGJMG5CJVPJJYYAJA5VZIAAIBACAYAAEAQAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAAAQDAIAACIIAFUTEOAMPWV2QO7URYOGW3IWLDUJYIBKZCECC27ZRNLNBHED7DH6QAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQMAACAEAQWAABAEAQGAIBEEALXH4JMVTQID2LYZDNY3BE27ZGPCN3RF5B7BBRYHCBOA6XAK6MCPAAAIAQAAYDAFAELKAEKPNPXNQI6W6YSDGGZGXWUNYSTAHMSM6JVRCZOWLR4AATVNPYCLZDPEOQXITARNPEUEFDJ3J63DOWUMUEQ22II25H2OTZMS7VLYAACAIAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQEAABEEADALIIXAMWTUJRTIMNDOK5OFVUPWKYC237QOO6OFNL6GQ2KOIKP3AAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYGAABACAIKAEAAOAIAAAAAAAAAAAAAUAIBAMBQAA2OMF2AAAIABMAACAIBAMAQCIIA4WGJEFVRN4PBIRD4R2ZSHRLGVUIFAJNAEQCRO37MI7IHJM6JQ3EAAAQAAMBQGAKAIWUAIU627O3AR5N5REGMNSNPNI3RFGAOZEZ4TLCFS5MXDYABHK27QEXSG6I5BORGBC26JIIKGTWT5WG5NIZIJBVUQRV2PU5HSZF7KXQAAAAQAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAAAQDAIAACIIAGXO4NCLJE6O5KYIZMT7TW5V3WRSBNWAXMPEJLR5JCA7WKSGWLQSAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQMAACAEAQMAAEAFAELKAEKPNPXNQI6W6YSDGGZGXWUNYSTAHMSM6JVRCZOWLR4AATVNPYCLZDPEOQXITARNPEUEFDJ3J63DOWUMUEQ22II25H2OTZMS7VLYAAEAABAEAQAAIBAEFQAAIBAEBQAAABAIBQCAJBAA253RUJNETZ3VLBDFSP6O3WXO2GIFWYC5R4RFOHVEID6ZKI2ZOCIAACAMAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAAAQDAIAACIIAVMQSQXYFSDZ7NIPEJPI7XUFYIE43FEMQEHYQS7CWAIXJ3OT7IEAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQMAABAEDAABABIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAQAAQBAEDAABABIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAQAAQBAEDAABABIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAQAAQBAEDAABABIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAQAAAKAEAAOAIAAAAAAAAAAABAUAIBAMBQAA2OMF2AAAIABMAAWAIBAMAQCIIAGXO4NCLJE6O5KYIZMT7TW5V3WRSBNWAXMPEJLR5JCA7WKSGWLQSAAAQAA4FACAAHAEAAAAAAAAAAAAQKAEAQGAYAANHGC5AAAEAAWAAKAEAQGAIBEEADLXOGRFUSPHOVMEMWJ7Z3O253IZAW3ALWHSEVY6URAP3FJDLFYJAAAIAAQCQBAADQCAAAAAAAAAAAAIFACAIDAMAAGTTBOQAACAALAAEQCAIDAEASCABV3XDIS2JHTXKWCGLE745XNO5UMQLNQF3DZCK4PKIQH5SURVS4EQAAEAAJBIAQCBYDAEUAWAABAEAQGAIABJHGC5BOORXVIZLYOQAQOCYAAIAQCAYBAADVIZLYOQXCWKYCAEAAUAIBA4BQELBABMAAGAIBAMAQAB2UMV4HILRLFMBACAALAACACAIDAEAAUTTBOQXHI32UMV4HIAIIBMAAKAIBAMAQAB2UMV4HILRLFMBACAAKAEAQOAYDFQQCECYAAYAQCAYBAADVIZLYOQXCWKYCAEAAWAAHAEAQGAIABJHGC5BOORXVIZLYOQAQSCYABAAQCAYBAADVIZLYOQXCWKYCAEAAUAIBA4BQEIRJAMAQAB2UMV4HILRLFMBACAAAAAAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAAAQDAIAACIIAXOPYSZLHAQHUXRSG3RWCJV7SM6E3XCL2D6CDDQOEC4B5OAV4YE6AAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQMAADAEAQCCYAAEAQCAYBAACU4YLUFYVQEAQAAMAAEAIAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAAAAIBQEAABEEANR5YMZ4O453FLTU6EFVRUUPWHXYW6TUZGJMG5CJVPJJYYAJA5VZIAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAYGAABACAIDAAAQCAABAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAAAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAMBAAAJBADSYZEQWWFXR4FCEPSHLGI6FM2WRAUBFUASAKF3P5RD5A5FTZGDMQAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAABAGBQAAIAQCCYAAUAQCAYBAAFEY2LTOQXHM2LFO5WACAAGAACACQBXUUCXAJCWUDKCCPAAZUOSPHG5OAQWM7RAIACNQG5HLXLG25SJ6V4VM43AO7YPRRQOZDZQ6GRWPWODX4EPCCQUPWP5K4RWURF7N2IYQAACAABACAIKAEAAOAIAAAAAAAAAAAAAUAIBAMBQAA2OMF2AAAIABMAAIAIBAMAQADCVNZUXMZLSONQWYLR5HUBAGAAGAACAAB2CN5XWYZLBNYAQAAALAAAQCAIDAEAAKTTBOQXCWAQHAQBQCAJBADSYZEQWWFXR4FCEPSHLGI6FM2WRAUBFUASAKF3P5RD5A5FTZGDMQAACAACACCYAAIAQCAYBAEQQALJGI4AY7NLVA57JDQ4NNWRMWHITQQCVSEIEFV7TC2W2COIH6GP5AAAQOCYAAMAQCAYEAFADOZSDELSPKFQL3ER57XFVJSN7RFMPTISSASIVWTPET24F347T5YV6I6KK3AQHQQ2E6BE6M7MOQTYJCSCV4DDB5JBJ5FUHQMS3XID47IAAAAIAAMAQCIIA4WGJEFVRN4PBIRD4R2ZSHRLGVUIFAJNAEQCRO37MI7IHJM6JQ3EAAAQAAUAQAAICAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAABAGBIBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAABAAAJBACVSCKC7AWIPH5VB4RF5D66QXBATTMURSAQ7CCL4KYBC5HN2P5AQAAAAAAAAAAAAAAAAAAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAABACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAACAEAUARNIARJ5V65WBD233CIMY3E262RXCKMA5SJTZGWELF2ZOHQACOVV7AJPEN4R2C5CMCFV4SQQUNHNH3MN22RSQSDLJBDLU7J2PFSL6VPAAAAAAAAAAAAAAEAACAABEEALXH4JMVTQID2LYZDNY3BE27ZGPCN3RF5B7BBRYHCBOA6XAK6MCPAAAAAAAAAAAAAAAAACAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAGAAAAEQQAB2PJS4LE6JQYCB5QTFIJMFLSA63XSMYZEZBXLGJYWYXQCMIJANSAEAAAAAAAAAAAAAAAEAAACDKOVWXAQ3PNZ2AAAAAAAAAAAAAAAAQEBAAAAAAAAAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAFQAAJBAAWSMRYBR62XKB36SHBY23NCZMORHBAFLEIQILL7GFVNUE4QP4M72AAAAAAAAAAAAAAAAAIBAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAABQAAIAA5BG633MMVQW4AAAAAAAAAAAAEAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAAAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAAAABQCCABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAABQAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAQAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAABIAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAMAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAAAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAA4AACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAIAAAQCQBXUUCXAJCWUDKCCPAAZUOSPHG5OAQWM7RAIACNQG5HLXLG25SJ6V4VM43AO7YPRRQOZDZQ6GRWPWODX4EPCCQUPWP5K4RWURF7N2IYQAAAAAAAAAAAAAAAAAQBAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAAAAAAYBBAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAYAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAIAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAAAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAUAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAGAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAOAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAAEAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAMAAGAIJAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAAAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAABQAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAQAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAABIAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAMAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAAAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAA4AACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAIAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAAAAMAQWAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAEAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAACAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAGAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAACAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAAAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAFAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAABQAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAAAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAADQAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAABAAACAKAAAX7CUYLIPZBB2NU3HFA3VZZPIBMNKJFWD2AXSYRTBZ7VTXTVE3DR23R7ZB6XCZEAZ5QURR4XOHRYMYNJA3D2NV64JQ6S7RHTD2M2AQAAAAAAAAAAAAAAAAAAIAAAAAAAAAAAAIAAAAAAAAAAABQAAAAAAAAAAAAAAAAAAAAAAAAAAJBAAYC2CFYDFU5CMM2DDI3SXLRNND5SWAWW74DTXTRLK7RUGSTSCT6YAAAAAAAAAAAAAAQEAAAAAAAAAAAAMAAAAAAAAAAACAAAAAAAAAAAAAAAAAAAAAAAAAAAEQQBZMMSILLC3Y6CRCHZDVTEPCWNLIQKAS2AJAFC5X6YR6QOSZ4TBWIAAAAAAAAAAAAAAYAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAIBIBC2QBCT3L53MCHVXWEQZRWJV5VDOEUYB3ETHSNMIWLVS4PAAE5LL6AS6I3ZDUF2EYELLZFBBI2O2PWY3VVDFBEGWSCGXJ6TU6LEX5K6AAAAAAAAAAAAAAIAAEAACIIAXOPYSZLHAQHUXRSG3RWCJV7SM6E3XCL2D6CDDQOEC4B5OAV4YE6AAAAAAAAAAAAAAAAAEAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAIAAAAJBAADU6TFYWJ4TBQED3BGKQSYKXEB5XPEZRSJSDOWMTRNRPAEYQSA3EAIAAAAAAAAAAAAAAAIAAAEGU5LNOBBW63TUAAAAAAAAAAAAAAABAICAAAAAAAAAAAABAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAALAAASCABNEZDQDD5VOUDX5EODRVW2FSY5COCAKWIRAQWX6MLK3IJZA7YZ7UAAAAAAAAAAAAAAAAAQCAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAACAAAQAB2CN5XWYZLBNYAAAAAAAAAAAAIAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAAAADAEEQCAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAADAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAACAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAAAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAUAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAABAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAAAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAADAAAIBIA32KBLQERLKBVBBHQAM2HJHTTOXAILGPYQEABGYDOTV3VTNOZE7K6KWONQHP4HYYYHMR4YPDI3H3HB36CHRBIKH3H6VOI3KIS7W5EMIAAAAAAAAAAAAAAAAAIAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAAAAMAQSAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAMAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAIAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAAAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAACQAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAAAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAEAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAMAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAABAAAYBBIAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAGAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAAAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAEAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAABIAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAAAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAACAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAAAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAGAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAAAAMAQWAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAIAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAAAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAYAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAAAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAAAQAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAAAACAADJZQXIAAAAAAAAAAAAAAQAAAAAAAAAAAFAAAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAAAAAAEAAGTTBOQAAAAAAAAAAAAABAAAAAAAAAAAAIAABAABU4YLUAAAAAAAAAAAAAAIAAAAAAAAAAAAAAAIAANHGC5AAAAAAAAAAAAAACAAAAAAAAAAAAYAACAKAAAX7CUYLIPZBB2NU3HFA3VZZPIBMNKJFWD2AXSYRTBZ7VTXTVE3DR23R7ZB6XCZEAZ5QURR4XOHRYMYNJA3D2NV64JQ6S7RHTD2M2AQAAAAAAAAAAAAAAAAAAIAAAAAAAAAAAAIAAAAAAAAAAABQAAAAAAAAAAAAAAAAAAAAAAAAAAJBAAYC2CFYDFU5CMM2DDI3SXLRNND5SWAWW74DTXTRLK7RUGSTSCT6YAAAAAAAAAAAAAAQEAAAAAAAAAAAAMAAAAAAAAAAACAAAAAAAAAAAAAAAAAAAAAAAAAAAEQQBZMMSILLC3Y6CRCHZDVTEPCWNLIQKAS2AJAFC5X6YR6QOSZ4TBWIAAAAAAAAAAAAAAYAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAAAAEAIBIBC2QBCT3L53MCHVXWEQZRWJV5VDOEUYB3ETHSNMIWLVS4PAAE5LL6AS6I3ZDUF2EYELLZFBBI2O2PWY3VVDFBEGWSCGXJ6TU6LEX5K6AAAAAAAAAAAAAAAAAEAQAA2OMF2AAAAAAAAAAAAAAEAAAAAAAAAAALIAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAA= \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-03.v5.hash b/unison-src/transcripts-using-base/serialized-cases/case-03.v5.hash new file mode 100644 index 0000000000..3b39c4aee9 --- /dev/null +++ b/unison-src/transcripts-using-base/serialized-cases/case-03.v5.hash @@ -0,0 +1 @@ +DLSO2TFPG5363MWC7FDSUW55VYA7P7CI4DBRFLWGPSUTF6YR45QPIPBSJPANZH44MGVYRSSMTPXODLDUFCO6JF43V3IPU4DRDU7JKII= \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-03.v5.ser b/unison-src/transcripts-using-base/serialized-cases/case-03.v5.ser new file mode 100644 index 0000000000..f0188e6737 --- /dev/null +++ b/unison-src/transcripts-using-base/serialized-cases/case-03.v5.ser @@ -0,0 +1 @@ +AAAAABIBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQCCIBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQEAABEEAAOT2MXCZHSMGAQPMEZKCLBK4QHW54TGGJGIN2ZSOFWF4ATCCIDMQAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGBQBAEAQMAACAEAUAN3GIMROJ5IWBPMSHX64WVGJX6EVR6NCKICJCW2N4SPLQXPT6PXCXZDZJLMCA6CDITYETZT5R2CPBEKIKXQMMHVEFHUWQ6BSLO5APT5AAAIAAEAQKAKAG5TEGIXE6ULAXWJD37OLKTE37CKY7GRFEBERLNG6JHVYLXZ7H3RL4R4UVWBAPBBUJ4CJ4Z6Y5BHQSFEFLYGGD2SCT2LIPAZFXOQHZ6QABAAAQ2TVNVYEG33OOQAQACYAAEAQCAYBAEQQAB2PJS4LE6JQYCB5QTFIJMFLSA63XSMYZEZBXLGJYWYXQCMIJANSAEAQAAYAAMAQAAIAAEAQSAIAAQAQCQBXMZBSFZHVCYF5SI673S2UZG7YSWHZUJJAJEK3JXSJ5OC56PZ64K7EPFFNQIDYINCPASPGPWHIJ4ERJBK6BRQ6UQU6S2DYGJN3UB6PUAAAAIAQAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGAQAAEQQAB2PJS4LE6JQYCB5QTFIJMFLSA63XSMYZEZBXLGJYWYXQCMIJANSAEAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAYGAABACAILAAAQCAIDAEASCAAHJ5GLRMTZGDAIHWCMVBFQVOID3O6JTDETEG5MZHC3C6AJRBEBWIAAACABEEANR5YMZ4O453FLTU6EFVRUUPWHXYW6TUZGJMG5CJVPJJYYAJA5VZIAAIBACAYAAEAQAAABAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAAAAAAAAAAAAAAAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAYCAAASCABD4J3OKKBTZLPQBBAFHIQYPQADAQXNC3RHA5YKBV72ZGYDNKNQSIAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAQDAYAAEAIBBMAAKAIBAMAQACSMNFZXILTWNFSXO3ABAADAABABIA32KBLQERLKBVBBHQAM2HJHTTOXAILGPYQEABGYDOTV3VTNOZE7K6KWONQHP4HYYYHMR4YPDI3H3HB36CHRBIKH3H6VOI3KIS7W5EMIAABAAAQBAEFACAIMAEAAAAAAAAAAAAALAACACAIDAEAAYVLONF3GK4TTMFWC4PJ5AIBAABQAAQAAOQTPN5WGKYLOAEAAACYAAEAQCAYBAACU4YLUFYVQEBQDAMAQCIIAEPRHNZJIGPFN6AEEAU5CDB6AAMCC5ULOE4DXBIGX7LE3ANVJWCJAAAQAAMAQWAACAEAQGAIBEEAC2JSHAGH3K5IHP2I4HDLNULFR2E4EAVMRCBBNP4YWVWQTSB7RT7IAAEDAWAADAEAQGBABIA3WMQZC4T2RMC6ZEPP5ZNKMTP4JLD42EUQESFNU3ZE6XBO7H47OFPSHSSWYEB4EGRHQJHTH3DUE6CIUQVPAYYPKIKPJNB4DEW52A7H2AAAACAADAEASCABD4J3OKKBTZLPQBBAFHIQYPQADAQXNC3RHA5YKBV72ZGYDNKNQSIAAEAAEAEAACAQAAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMBAAAJBAAWSMRYBR62XKB36SHBY23NCZMORHBAFLEIQILL7GFVNUE4QP4M72AABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQMAACAEAQWAABAEAQGAIBEEALXH4JMVTQID2LYZDNY3BE27ZGPCN3RF5B7BBRYHCBOA6XAK6MCPAAAIAQAAYDAFAELKAEKPNPXNQI6W6YSDGGZGXWUNYSTAHMSM6JVRCZOWLR4AATVNPYCLZDPEOQXITARNPEUEFDJ3J63DOWUMUEQ22II25H2OTZMS7VLYAACAIAAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMBAAAJBAA253RUJNETZ3VLBDFSP6O3WXO2GIFWYC5R4RFOHVEID6ZKI2ZOCIAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQMAACAEAQMAAEAFAELKAEKPNPXNQI6W6YSDGGZGXWUNYSTAHMSM6JVRCZOWLR4AATVNPYCLZDPEOQXITARNPEUEFDJ3J63DOWUMUEQ22II25H2OTZMS7VLYAAEAABAEAQAAIBAEFQAAIBAEBQAAABAIBQCAJBAA253RUJNETZ3VLBDFSP6O3WXO2GIFWYC5R4RFOHVEID6ZKI2ZOCIAACAMAAAAABAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAAAAAAAAAAAAAAAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAYCAAASCAC23KGP4O2QVLBIVRGK3KNMAXLIWJNNACUZJTSDXUCUCGLJWAODNUAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAQDAYAACAIGAACACQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAABAABACAIGAACACQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAABAABACAIGAACACQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAABAABACAIGAACACQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAABAAAAUAIBBQAQAAAAAAAAAAACBMAAWAIBAMAQCIIAGXO4NCLJE6O5KYIZMT7TW5V3WRSBNWAXMPEJLR5JCA7WKSGWLQSAAAQAAYFACAIMAEAAAAAAAAAAAAQLAAFACAIDAEASCABV3XDIS2JHTXKWCGLE745XNO5UMQLNQF3DZCK4PKIQH5SURVS4EQAAEAAGBIAQCDABAAAAAAAAAAAAECYABEAQCAYBAEQQANO5Y2EWSJ452VQRSZH7HN3LXNDEC3MBOY6ISXD2SEB7MVENMXBEAABAABQKAEAQOAYBFAFQAAIBAEBQCAAKJZQXILTUN5KGK6DUAECQWAACAEAQGAIAA5KGK6DUFYVSWAQBAAFACAIHAMBCYIALAABQCAIDAEAAOVDFPB2C4KZLAIAQACYAAQAQCAYBAAFE4YLUFZ2G6VDFPB2ACBYLAACQCAIDAEAAOVDFPB2C4KZLAIAQACQBAEDQGAZMEARAWAAGAEAQGAIAA5KGK6DUFYVSWAQBAAFQABYBAEBQCAAKJZQXILTUN5KGK6DUAEEQWAAIAEAQGAIAA5KGK6DUFYVSWAQBAAFACAIHAMBCEKIDAEAAOVDFPB2C4KZLAIAQAAAAAAAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGAQAAEQQBO47RFSWOBAPJPDENXDMETL7EZ4JXOEXUH4EGHA4IFYD24BLZQJ4AAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAYGAABQCAIBBMAACAIBAMAQABKOMF2C4KYCAIAAGAACAEAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGAQAAEQQBWHXBTHR3TXMVOOTYQWWGSR6Y67C32OTEZFQ3UJGV5FHDABEDWXFAAAQCQAVMBCUJUWZXIISNQY3J4HHF4UCTG2VI2OTKVWAQFVZWYX3T5MXS6LWV44LU2USLVE3FHYGV7SNVPQ5CN26L4NIXDELTBDOENZ644M7KAAAAAAAAAAAAAAAEAYGAABACAIDAAAQCAAAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAQDAIAACIIA56Y5WAMUIZRITDKODUPJXHBCZSTKHCBX3KEPA7VOBOBEFIG6PEJQAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMDAAAQBAEFACAIMAEAAAAAAAAAAAAALAAAQCAIDAEASCABD4J3OKKBTZLPQBBAFHIQYPQADAQXNC3RHA5YKBV72ZGYDNKNQSIAAEAACAMBQCQCFVACFHWX3WYEPLPMJBTDMTL3KG4JJQDWJGPE2YRMXLFY6AAJ2WX4BF4RXSHILUJQIWXSKCCRU5U7NRXLKGKCINNEENOT5HJ4WJP2V4AAAAEAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGBIBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIAACIIALLNIZ7R3KCVMFCWEZLNJVQC5NCZFVUAKTFGOIO6QKQIZNGYBYNWQAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAQBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIAQCQCFVACFHWX3WYEPLPMJBTDMTL3KG4JJQDWJGPE2YRMXLFY6AAJ2WX4BF4RXSHILUJQIWXSKCCRU5U7NRXLKGKCINNEENOT5HJ4WJP2V4AAAAAAAAAAAAAAQCAABEEALXH4JMVTQID2LYZDNY3BE27ZGPCN3RF5B7BBRYHCBOA6XAK6MCPAAAAAAAAAAAAAAAAQDBABQAAJBAADU6TFYWJ4TBQED3BGKQSYKXEB5XPEZRSJSDOWMTRNRPAEYQSA3EAIAAAAAAAAAAAAACAAABBVHK3LQINXW45AAAAAAAAAAAAAACAQLAAASCABNEZDQDD5VOUDX5EODRVW2FSY5COCAKWIRAQWX6MLK3IJZA7YZ7UAAAAAAAAAAAAAAAEBQQAYBAADUE33PNRSWC3QAAAAAAAAAAAAQAAYIAABQQAADAEEAGCADAMEAIAYIAABQQBIDBADAGCAAAMEAOAYIBAAQCQBXUUCXAJCWUDKCCPAAZUOSPHG5OAQWM7RAIACNQG5HLXLG25SJ6V4VM43AO7YPRRQOZDZQ6GRWPWODX4EPCCQUPWP5K4RWURF7N2IYQAAAAAAAAAAAAAAAEAYIAABQCCADBABQGCAEAMEAAAYIAUBQQBQDBAAAGCAHAMEAQAYIAMBQCCIDBAAAGCADAMEAIAYIAABQQBIDBADAGCAAAMEAOAYIBABQQAADAEFQGCABAMEAEAYIAABQQAYDBACAGCAAAMEAKAYIAYBQQAADBADQGCAIAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAAEAAAAAAAAAAAAMAAAAAAAAAAAAABEEAO7MO3AGKEMYUJRVHB2HU3TQRMZJVDRA35VCHQP2XAXASCUDPHSEYAAAAAAAAAAAAACAQAAAAAAAAAAAEAAAAAAAAAAAAAAEQQAI7CO3SSQM6K34AIIBJ2EGD4AAYEF3IW4JYHOCQNP6WJWA3KTMESAAAAAAAAAAAAAAYAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABACAKAIWUAIU627O3AR5N5REGMNSNPNI3RFGAOZEZ4TLCFS5MXDYABHK27QEXSG6I5BORGBC26JIIKGTWT5WG5NIZIJBVUQRV2PU5HSZF7KXQAAAAAAAAAAAAACAIAAEQQBO47RFSWOBAPJPDENXDMETL7EZ4JXOEXUH4EGHA4IFYD24BLZQJ4AAAAAAAAAAAAAAACAMEAEAABEEAAOT2MXCZHSMGAQPMEZKCLBK4QHW54TGGJGIN2ZSOFWF4ATCCIDMQBAAAAAAAAAAAAAAIAAAEGU5LNOBBW63TUAAAAAAAAAAAAAAICBMAACIIAFUTEOAMPWV2QO7URYOGW3IWLDUJYIBKZCECC27ZRNLNBHED7DH6QAAAAAAAAAAAAAAAQGCACAEAAOQTPN5WGKYLOAAAAAAAAAAAACAADBAAAGCAAAMAQSAYIAMBQQAADBAAQGCAAAMEAKAYIAABQQBADBAAAGCAGAEAUAN5FAVYCIVVA2QQTYAGNDUTZZXLQEFTH4ICAATMBXJ252ZWXMSPVPFLHGYDX6D4MMDWI6MHRUNT5TQ57BDYQUFD5T7KXENVEJP3OSGEAAAAAAAAAAAAAAABAGCAAAMAQSAYIAMBQQAADBAAQGCAAAMEAKAYIAABQQBADBAAAGCAGAMEAEAYBBIBQQAADBABQGCAAAMEACAYIAABQQBIDBAAAGCAEAMEAAAYIAYBQQAADAEFQGCACAMEAAAYIAMBQQAADBAAQGCAAAMEAKAYIAABQQBADBAAAGCAGAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAAEAAAAAAAAAAAAMAAAAAAAAAAAAABEEAO7MO3AGKEMYUJRVHB2HU3TQRMZJVDRA35VCHQP2XAXASCUDPHSEYAAAAAAAAAAAAACAQAAAAAAAAAAAEAAAAAAAAAAAAAAEQQAI7CO3SSQM6K34AIIBJ2EGD4AAYEF3IW4JYHOCQNP6WJWA3KTMESAAAAAAAAAAAAAAYAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABACAKAIWUAIU627O3AR5N5REGMNSNPNI3RFGAOZEZ4TLCFS5MXDYABHK27QEXSG6I5BORGBC26JIIKGTWT5WG5NIZIJBVUQRV2PU5HSZF7KXQAAAAAAAAAAAAAAAIDBAWQCAKAAAX7CUYLIPZBB2NU3HFA3VZZPIBMNKJFWD2AXSYRTBZ7VTXTVE3DR23R7ZB6XCZEAZ5QURR4XOHRYMYNJA3D2NV64JQ6S7RHTD2M2AQAAAAAAAAAAAAAAAABAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAAAAAAAAAAAAAAAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAA=== \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-04.v5.hash b/unison-src/transcripts-using-base/serialized-cases/case-04.v5.hash new file mode 100644 index 0000000000..acb9258d45 --- /dev/null +++ b/unison-src/transcripts-using-base/serialized-cases/case-04.v5.hash @@ -0,0 +1 @@ +EXAQLMU6IKGAY7DNOHND5VUQQAQPIJN3IVCF5DISOOEVLRQZ3Q2CZOYEVDMY7MYQX2CG6CJFH2HQD6XOMKHQNK5JUZB3G7RZQNREQRQ= \ No newline at end of file diff --git a/unison-src/transcripts-using-base/serialized-cases/case-04.v5.ser b/unison-src/transcripts-using-base/serialized-cases/case-04.v5.ser new file mode 100644 index 0000000000..bcced67760 --- /dev/null +++ b/unison-src/transcripts-using-base/serialized-cases/case-04.v5.ser @@ -0,0 +1 @@ +AAAAABIBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQCBIBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQEAABEEADVNOCW62AVOZXJ6CMCXMWMTBLF4FFUTLGYPNRXF3BZCNXIDIOZNIAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGBQAAEAQMAAGAABU4YLUAEAAAAAAAAAAAAAHAMCG623BPEAQWAACAEAQGAIBEEAG57PICSIFU224UOLFTG2BAWCL4E7NVW2SJJUAWDIJO7R3YJCNHYQAAAFACAIMAEAAAAAAAAAAAAILAAAQCAIDAEAAQTTBOQXGI4TPOABAEAADAEASCAB2WXBLPNAKXM3U7BGBLWLGJQVS6CS2JVTMHWY3S5Q4RG3UBUHMWUAQCAAAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAQDAIAACIIAHK24FN5UBK5TOT4EYFOZMZGCWLYKLJGWNQ63DOLWDSE3OQGQ5S2QCAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMDAAAIBAMAQCIIAHK24FN5UBK5TOT4EYFOZMZGCWLYKLJGWNQ63DOLWDSE3OQGQ5S2QAAIAAAAQCQAAF7YVGC2D6IIOTNGZZIG5OOL2ALDKSJNQ6QF4WEMYOP5M545JGY4OW4P6IPVYWJAGPMFEMPF3R4ODGDKIGY6TNPXCMHUX4J4Y6TGQEAAAAAAAAAAAAAAAAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMBAAAJBABXP32AUSBNGWXFDSZMZWQIFQS7BH3NNWUSKNAFQ2CLX4O6CITJ6EAABAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIBQMAAABMAACAIBAMAQCIIA74Z3E7TZQYDVD277KYVK5NAJDGFSKNDJXTUKC63K45WJSDPTGK4QAAALAABACAIDAEABGSKPFZXXAZLOIZUWYZJONFWXA3BOOYZQAAYBAEQQB3YGQKCYHD3UZXVHZGINUEURDHPZAHALBT23ILWELMAMPRQ2D7NPAABACAAAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAQDAIAACIIA54DIFBMDR52M32T4TEG2CKIRTX4QDQFQZ5NUF3CFWAGHYYNB7WXQAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMDAABABAEAQCCYAAEAQCAYAAIBACAADAACACAAAAEAUAABP6FJQWQ7SCDU3JWOKBXLTS6QCY2USLMHUBPFRDGDT7LHPHKJWHDVXD7SD5OFSIBT3BJDDZO4PDQZQ2SBWHU3L5YTB5F7CPGHUZUBAAAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAQDAIAACIIA74Z3E7TZQYDVD277KYVK5NAJDGFSKNDJXTUKC63K45WJSDPTGK4QAAIBIAKWARKE2LM3UEJGYMNU6DTS6KBJTNKUNHJVK3AIC243ML5Z6WLZPF3K6OF2NKJF2SNST4DK7ZG2XYORG5PF6GULRSFZQRXCG47OOGPVAAAAAAAAAAAAAAACAMDAAAIBAYAAIAKAAYHWPACBPYWKJKM2NKSLWVRBTSNVST2AI6PHPF4OJ5445524FEGZP6XTZUG4DBW2Y2I4CYBXK5ONOIRUUGROEFVJFPSLQVSNSU5EE7IAAIAACAIBAAAQCAIDAQAUAJOA7BYABDTZGHSVVPMSW7MJOX2SYXXFOHDKQRESSFMT3HFUDFIO5UOEVZ4JCZAQQL53EGN2XPGLX432KM4VDDP52DPQXQ7AQNTICXPAAAABAAAAAAIBIAAC74KTBNB7EEHJWTM4UDOXHF5AFRVJEWYPIC6LCGMHH6WO6OUTMOHLOH7EH24LEQDHWCSGHS5Y6HBTBVEDMPJWX3RGD2L6E6MPJTICAAAAAAAAAAAAAAAAAEAUAFLAIVCNFWN2CETMGG2PBZZPFAUZWVKGTU2VNQEBNONWF647LF4XS5VPHC5GVES5JGZJ6BVP4TNL4HITOXS7DKFYZC4YI3RDOPXHDH2QAAAAAAAAAAAAAABAGBIBAFABKYCFITJNTOQRE3BRWTYOOLZIFGNVKRU5GVLMBALLTNRPXH2ZPF4XNLZYXJVJEXKJWKPQNL7E3K7B2E3V4XY2ROGIXGCG4I3T5ZYZ6UAAAAAAAAAAAAAAAIAACIIAHK24FN5UBK5TOT4EYFOZMZGCWLYKLJGWNQ63DOLWDSE3OQGQ5S2QCAAAAAAAAAAAAAAACAKACVQEKRGS3G5BCJWDDNHQ44XSQKM3KVDJ2NKWYCAWXG3C7OPVS6LZO2XTROTKSJOUTMU7A2X6JWV6DUJXLZPRVC4MROMENYRXH3TRT5IAAAAAAAAAAAAAAAQDBACQCAKAAAX7CUYLIPZBB2NU3HFA3VZZPIBMNKJFWD2AXSYRTBZ7VTXTVE3DR23R7ZB6XCZEAZ5QURR4XOHRYMYNJA3D2NV64JQ6S7RHTD2M2AQAAAAAAAAAAAAAAAABAFAAAL7RKMFUH4QQ5G2NTSQN244XUAWGVES3B5ALZMIZQ472Z3Z2SNRY5NY74Q7LRMSAM6YKIY6LXDY4GMGUQNR5G27OEYPJPYTZR5GNAIAAAAAAAAAAAAAAAA====== \ No newline at end of file diff --git a/unison-src/transcripts-using-base/stm.md b/unison-src/transcripts-using-base/stm.md index 0320353161..eedf47bf37 100644 --- a/unison-src/transcripts-using-base/stm.md +++ b/unison-src/transcripts-using-base/stm.md @@ -1,6 +1,6 @@ Loops that access a shared counter variable, accessed in transactions. Some thread delaying is just accomplished by counting in a loop. -```unison +``` unison count : Nat -> () count = cases 0 -> () @@ -27,13 +27,13 @@ body k out v = atomically '(TVar.write out (Some n)) ``` -```ucm -.> add +``` ucm +scratch/main> add ``` Test case. -```unison +``` unison spawn : Nat ->{io2.IO} Result spawn k = let out1 = TVar.newIO None @@ -66,7 +66,7 @@ tests : '{io2.IO} [Result] tests = '(map spawn nats) ``` -```ucm -.> add -.> io.test tests +``` ucm +scratch/main> add +scratch/main> io.test tests ``` diff --git a/unison-src/transcripts-using-base/stm.output.md b/unison-src/transcripts-using-base/stm.output.md index a5d87ed520..3edffadcf8 100644 --- a/unison-src/transcripts-using-base/stm.output.md +++ b/unison-src/transcripts-using-base/stm.output.md @@ -1,6 +1,7 @@ Loops that access a shared counter variable, accessed in transactions. Some thread delaying is just accomplished by counting in a loop. -```unison + +``` unison count : Nat -> () count = cases 0 -> () @@ -27,36 +28,35 @@ body k out v = atomically '(TVar.write out (Some n)) ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: body : Nat -> TVar (Optional Nat) -> TVar Nat ->{IO} () count : Nat -> () inc : TVar Nat ->{IO} Nat loop : '{IO} Nat -> Nat -> Nat ->{IO} Nat - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + body : Nat -> TVar (Optional Nat) -> TVar Nat ->{IO} () count : Nat -> () inc : TVar Nat ->{IO} Nat loop : '{IO} Nat -> Nat -> Nat ->{IO} Nat - ``` + Test case. -```unison +``` unison spawn : Nat ->{io2.IO} Result spawn k = let out1 = TVar.newIO None @@ -89,49 +89,47 @@ tests : '{io2.IO} [Result] tests = '(map spawn nats) ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: display : Nat -> Nat -> Nat -> Text nats : [Nat] spawn : Nat ->{IO} Result tests : '{IO} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + display : Nat -> Nat -> Nat -> Text nats : [Nat] spawn : Nat ->{IO} Result tests : '{IO} [Result] -.> io.test tests +scratch/main> io.test tests New test results: - - ◉ tests verified - ◉ tests verified - ◉ tests verified - ◉ tests verified - ◉ tests verified - ◉ tests verified - ◉ tests verified - ◉ tests verified - ◉ tests verified - ◉ tests verified - + + 1. tests ◉ verified + ◉ verified + ◉ verified + ◉ verified + ◉ verified + ◉ verified + ◉ verified + ◉ verified + ◉ verified + ◉ verified + ✅ 10 test(s) passing - - Tip: Use view tests to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/test-watch-dependencies.md b/unison-src/transcripts-using-base/test-watch-dependencies.md index 8f3c610561..603b8d2016 100644 --- a/unison-src/transcripts-using-base/test-watch-dependencies.md +++ b/unison-src/transcripts-using-base/test-watch-dependencies.md @@ -4,36 +4,36 @@ https://github.com/unisonweb/unison/issues/2195 We add a simple definition. -```unison:hide +``` unison :hide x = 999 ``` -```ucm:hide -.> add +``` ucm :hide +scratch/main> add ``` Now, we update that definition and define a test-watch which depends on it. -```unison +``` unison x = 1000 test> mytest = checks [x + 1 == 1001] ``` We expect this 'add' to fail because the test is blocked by the update to `x`. -```ucm:error -.> add +``` ucm :error +scratch/main> add ``` --- -```unison +``` unison y = 42 test> useY = checks [y + 1 == 43] ``` This should correctly identify `y` as a dependency and add that too. -```ucm -.> add useY +``` ucm +scratch/main> add useY ``` diff --git a/unison-src/transcripts-using-base/test-watch-dependencies.output.md b/unison-src/transcripts-using-base/test-watch-dependencies.output.md index 53835d0f6e..c4f43b9263 100644 --- a/unison-src/transcripts-using-base/test-watch-dependencies.output.md +++ b/unison-src/transcripts-using-base/test-watch-dependencies.output.md @@ -4,25 +4,28 @@ https://github.com/unisonweb/unison/issues/2195 We add a simple definition. -```unison +``` unison :hide x = 999 ``` +``` ucm :hide +scratch/main> add +``` + Now, we update that definition and define a test-watch which depends on it. -```unison +``` unison x = 1000 test> mytest = checks [x + 1 == 1001] ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: mytest : [Result] @@ -31,65 +34,63 @@ test> mytest = checks [x + 1 == 1001] new definition: x : Nat - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 2 | test> mytest = checks [x + 1 == 1001] ✅ Passed Passed - ``` + We expect this 'add' to fail because the test is blocked by the update to `x`. -```ucm -.> add +``` ucm :error +scratch/main> add x These definitions failed: - + Reason needs update x : Nat blocked mytest : [Result] - - Tip: Use `help filestatus` to learn more. + Tip: Use `help filestatus` to learn more. ``` ---- -```unison +----- + +``` unison y = 42 test> useY = checks [y + 1 == 43] ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: useY : [Result] y : Nat - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 2 | test> useY = checks [y + 1 == 43] ✅ Passed Passed - ``` + This should correctly identify `y` as a dependency and add that too. -```ucm -.> add useY +``` ucm +scratch/main> add useY ⍟ I've added these definitions: - + useY : [Result] y : Nat - ``` diff --git a/unison-src/transcripts-using-base/thread.md b/unison-src/transcripts-using-base/thread.md index d2c2712042..31f16e2635 100644 --- a/unison-src/transcripts-using-base/thread.md +++ b/unison-src/transcripts-using-base/thread.md @@ -1,6 +1,6 @@ Lets just make sure we can start a thread -```unison +``` unison otherThread : '{io2.IO}() otherThread = 'let watch "I'm the other Thread" () @@ -18,12 +18,12 @@ testBasicFork = 'let See if we can get another thread to stuff a value into a MVar -```ucm:hide -.> add -.> io.test testBasicFork +``` ucm :hide +scratch/main> add +scratch/main> io.test testBasicFork ``` -```unison +``` unison thread1 : Nat -> MVar Nat -> '{io2.IO}() thread1 x mv = 'let go = 'let @@ -47,12 +47,12 @@ testBasicMultiThreadMVar = 'let ``` -```ucm -.> add -.> io.test testBasicMultiThreadMVar +``` ucm +scratch/main> add +scratch/main> io.test testBasicMultiThreadMVar ``` -```unison +``` unison sendingThread: Nat -> MVar Nat -> '{io2.IO}() sendingThread toSend mv = 'let go = 'let @@ -90,7 +90,7 @@ testTwoThreads = 'let ``` -```ucm -.> add -.> io.test testTwoThreads +``` ucm +scratch/main> add +scratch/main> io.test testTwoThreads ``` diff --git a/unison-src/transcripts-using-base/thread.output.md b/unison-src/transcripts-using-base/thread.output.md index 76c28fa213..8f4924e69d 100644 --- a/unison-src/transcripts-using-base/thread.output.md +++ b/unison-src/transcripts-using-base/thread.output.md @@ -1,6 +1,6 @@ Lets just make sure we can start a thread -```unison +``` unison otherThread : '{io2.IO}() otherThread = 'let watch "I'm the other Thread" () @@ -16,23 +16,28 @@ testBasicFork = 'let ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: otherThread : '{IO} () testBasicFork : '{IO} [Result] - ``` + See if we can get another thread to stuff a value into a MVar -```unison +``` ucm :hide +scratch/main> add + +scratch/main> io.test testBasicFork +``` + +``` unison thread1 : Nat -> MVar Nat -> '{io2.IO}() thread1 x mv = 'let go = 'let @@ -56,41 +61,39 @@ testBasicMultiThreadMVar = 'let ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: testBasicMultiThreadMVar : '{IO} [Result] thread1 : Nat -> MVar Nat -> '{IO} () - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + testBasicMultiThreadMVar : '{IO} [Result] thread1 : Nat -> MVar Nat -> '{IO} () -.> io.test testBasicMultiThreadMVar +scratch/main> io.test testBasicMultiThreadMVar New test results: - - ◉ testBasicMultiThreadMVar other thread should have incremented - + + 1. testBasicMultiThreadMVar ◉ other thread should have incremented + ✅ 1 test(s) passing - - Tip: Use view testBasicMultiThreadMVar to view the source of a - test. + Tip: Use view 1 to view the source of a test. ``` -```unison + +``` unison sendingThread: Nat -> MVar Nat -> '{io2.IO}() sendingThread toSend mv = 'let go = 'let @@ -128,40 +131,38 @@ testTwoThreads = 'let ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: receivingThread : MVar Nat -> MVar Text -> '{IO} () sendingThread : Nat -> MVar Nat -> '{IO} () (also named thread1) testTwoThreads : '{IO} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + receivingThread : MVar Nat -> MVar Text -> '{IO} () sendingThread : Nat -> MVar Nat -> '{IO} () (also named thread1) testTwoThreads : '{IO} [Result] -.> io.test testTwoThreads +scratch/main> io.test testTwoThreads New test results: - - ◉ testTwoThreads - + + 1. testTwoThreads ◉ + ✅ 1 test(s) passing - - Tip: Use view testTwoThreads to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/tls.md b/unison-src/transcripts-using-base/tls.md index 77c66db491..b17afb3b94 100644 --- a/unison-src/transcripts-using-base/tls.md +++ b/unison-src/transcripts-using-base/tls.md @@ -1,6 +1,6 @@ # Tests for TLS builtins -```unison:hide +``` unison :hide -- generated with: -- openssl req -newkey rsa:2048 -subj '/CN=test.unison.cloud/O=Unison/C=US' -nodes -keyout key.pem -x509 -days 3650 -out cert.pem @@ -11,15 +11,15 @@ self_signed_cert_pem2 = "-----BEGIN CERTIFICATE-----\nMIIDVTCCAj2gAwIBAgIUdMNT5s not_a_cert = "-----BEGIN SCHERMIFICATE-----\n-----END SCHERMIFICATE-----" ``` -```ucm:hide -.> add +``` ucm :hide +scratch/main> add ``` # Using an alternative certificate store First lets make sure we can load our cert and private key -```unison +``` unison this_should_work=match (decodeCert.impl (toUtf8 self_signed_cert_pem2) with Left (Failure _ t _) -> [Fail t] Right _ -> [Ok "succesfully decoded self_signed_pem"] @@ -31,9 +31,9 @@ this_should_not_work=match (decodeCert.impl (toUtf8 not_a_cert) with what_should_work _ = this_should_work ++ this_should_not_work ``` -```ucm -.> add -.> io.test what_should_work +``` ucm +scratch/main> add +scratch/main> io.test what_should_work ``` Test handshaking a client/server a local TCP connection using our @@ -44,7 +44,7 @@ We'll create a server and a client, and start threads for each. The server will report the port it is bound to via a passed MVar which the client can read. -```unison +``` unison serverThread: MVar Nat -> Text -> '{io2.IO}() serverThread portVar toSend = 'let go: '{io2.IO, Exception}() @@ -190,9 +190,9 @@ testCNReject _ = runTest test ``` -```ucm -.> add -.> io.test testConnectSelfSigned -.> io.test testCAReject -.> io.test testCNReject +``` ucm +scratch/main> add +scratch/main> io.test testConnectSelfSigned +scratch/main> io.test testCAReject +scratch/main> io.test testCNReject ``` diff --git a/unison-src/transcripts-using-base/tls.output.md b/unison-src/transcripts-using-base/tls.output.md index 135f490186..a475223453 100644 --- a/unison-src/transcripts-using-base/tls.output.md +++ b/unison-src/transcripts-using-base/tls.output.md @@ -1,6 +1,6 @@ # Tests for TLS builtins -```unison +``` unison :hide -- generated with: -- openssl req -newkey rsa:2048 -subj '/CN=test.unison.cloud/O=Unison/C=US' -nodes -keyout key.pem -x509 -days 3650 -out cert.pem @@ -11,11 +11,15 @@ self_signed_cert_pem2 = "-----BEGIN CERTIFICATE-----\nMIIDVTCCAj2gAwIBAgIUdMNT5s not_a_cert = "-----BEGIN SCHERMIFICATE-----\n-----END SCHERMIFICATE-----" ``` +``` ucm :hide +scratch/main> add +``` + # Using an alternative certificate store First lets make sure we can load our cert and private key -```unison +``` unison this_should_work=match (decodeCert.impl (toUtf8 self_signed_cert_pem2) with Left (Failure _ t _) -> [Fail t] Right _ -> [Ok "succesfully decoded self_signed_pem"] @@ -27,42 +31,41 @@ this_should_not_work=match (decodeCert.impl (toUtf8 not_a_cert) with what_should_work _ = this_should_work ++ this_should_not_work ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: this_should_not_work : [Result] this_should_work : [Result] what_should_work : ∀ _. _ -> [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + this_should_not_work : [Result] this_should_work : [Result] what_should_work : ∀ _. _ -> [Result] -.> io.test what_should_work +scratch/main> io.test what_should_work New test results: - - ◉ what_should_work succesfully decoded self_signed_pem - ◉ what_should_work failed - + + 1. what_should_work ◉ succesfully decoded self_signed_pem + ◉ failed + ✅ 2 test(s) passing - - Tip: Use view what_should_work to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` + Test handshaking a client/server a local TCP connection using our self-signed cert. @@ -71,7 +74,7 @@ We'll create a server and a client, and start threads for each. The server will report the port it is bound to via a passed MVar which the client can read. -```unison +``` unison serverThread: MVar Nat -> Text -> '{io2.IO}() serverThread portVar toSend = 'let go: '{io2.IO, Exception}() @@ -217,14 +220,13 @@ testCNReject _ = runTest test ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: serverThread : MVar Nat -> Text -> '{IO} () @@ -235,13 +237,13 @@ testCNReject _ = -> MVar Nat -> '{IO, Exception} Text testConnectSelfSigned : '{IO} [Result] - ``` -```ucm -.> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + serverThread : MVar Nat -> Text -> '{IO} () testCAReject : '{IO} [Result] testCNReject : '{IO} [Result] @@ -251,35 +253,33 @@ testCNReject _ = -> '{IO, Exception} Text testConnectSelfSigned : '{IO} [Result] -.> io.test testConnectSelfSigned +scratch/main> io.test testConnectSelfSigned New test results: - - ◉ testConnectSelfSigned should have reaped what we've sown - + + 1. testConnectSelfSigned ◉ should have reaped what we've sown + ✅ 1 test(s) passing - - Tip: Use view testConnectSelfSigned to view the source of a - test. -.> io.test testCAReject + Tip: Use view 1 to view the source of a test. + +scratch/main> io.test testCAReject New test results: - - ◉ testCAReject correctly rejected self-signed cert - + + 1. testCAReject ◉ correctly rejected self-signed cert + ✅ 1 test(s) passing - - Tip: Use view testCAReject to view the source of a test. -.> io.test testCNReject + Tip: Use view 1 to view the source of a test. + +scratch/main> io.test testCNReject New test results: - - ◉ testCNReject correctly rejected self-signed cert - + + 1. testCNReject ◉ correctly rejected self-signed cert + ✅ 1 test(s) passing - - Tip: Use view testCNReject to view the source of a test. + Tip: Use view 1 to view the source of a test. ``` diff --git a/unison-src/transcripts-using-base/utf8.md b/unison-src/transcripts-using-base/utf8.md index 107bd260cd..ac21f96263 100644 --- a/unison-src/transcripts-using-base/utf8.md +++ b/unison-src/transcripts-using-base/utf8.md @@ -2,13 +2,13 @@ Test for new Text -> Bytes conversions explicitly using UTF-8 as the encoding Unison has function for converting between `Text` and a UTF-8 `Bytes` encoding of the Text. -```ucm -.> find Utf8 +``` ucm +scratch/main> find Utf8 ``` ascii characters are encoded as single bytes (in the range 0-127). -```unison +``` unison ascii: Text ascii = "ABCDE" @@ -18,7 +18,7 @@ ascii = "ABCDE" non-ascii characters are encoded as multiple bytes. -```unison +``` unison greek: Text greek = "ΑΒΓΔΕ" @@ -27,7 +27,7 @@ greek = "ΑΒΓΔΕ" We can check that encoding and then decoding should give us back the same `Text` we started with -```unison +``` unison checkRoundTrip: Text -> [Result] checkRoundTrip t = bytes = toUtf8 t @@ -42,7 +42,7 @@ test> greekTest = checkRoundTrip greek If we try to decode an invalid set of bytes, we get back `Text` explaining the decoding error: -```unison +``` unison greek_bytes = Bytes.fromList [206, 145, 206, 146, 206, 147, 206, 148, 206] diff --git a/unison-src/transcripts-using-base/utf8.output.md b/unison-src/transcripts-using-base/utf8.output.md index 6bba05281a..75404e1eb4 100644 --- a/unison-src/transcripts-using-base/utf8.output.md +++ b/unison-src/transcripts-using-base/utf8.output.md @@ -1,19 +1,18 @@ -Test for new Text -> Bytes conversions explicitly using UTF-8 as the encoding +Test for new Text -\> Bytes conversions explicitly using UTF-8 as the encoding Unison has function for converting between `Text` and a UTF-8 `Bytes` encoding of the Text. -```ucm -.> find Utf8 +``` ucm +scratch/main> find Utf8 1. builtin.Text.toUtf8 : Text -> Bytes 2. Text.fromUtf8 : Bytes ->{Exception} Text 3. builtin.Text.fromUtf8.impl : Bytes -> Either Failure Text - - ``` + ascii characters are encoded as single bytes (in the range 0-127). -```unison +``` unison ascii: Text ascii = "ABCDE" @@ -21,59 +20,57 @@ ascii = "ABCDE" ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These names already exist. You can `update` them to your new definition: ascii : Text - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 4 | > toUtf8 ascii ⧩ 0xs4142434445 - ``` + non-ascii characters are encoded as multiple bytes. -```unison +``` unison greek: Text greek = "ΑΒΓΔΕ" > toUtf8 greek ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: greek : Text - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 4 | > toUtf8 greek ⧩ 0xsce91ce92ce93ce94ce95 - ``` + We can check that encoding and then decoding should give us back the same `Text` we started with -```unison +``` unison checkRoundTrip: Text -> [Result] checkRoundTrip t = bytes = toUtf8 t @@ -86,31 +83,30 @@ greek = "ΑΒΓΔΕ" test> greekTest = checkRoundTrip greek ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: checkRoundTrip : Text -> [Result] greek : Text greekTest : [Result] - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 10 | test> greekTest = checkRoundTrip greek ✅ Passed Passed - ``` + If we try to decode an invalid set of bytes, we get back `Text` explaining the decoding error: -```unison +``` unison greek_bytes = Bytes.fromList [206, 145, 206, 146, 206, 147, 206, 148, 206] @@ -121,23 +117,21 @@ greek_bytes = Bytes.fromList [206, 145, 206, 146, 206, 147, 206, 148, 206] ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: greek_bytes : Bytes - + Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. 5 | > match fromUtf8.impl (drop 1 greek_bytes) with ⧩ - "Cannot decode byte '\\x91': Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" - + "Cannot decode byte '\\x91': Data.Text.Encoding: Invalid UTF-8 stream" ``` diff --git a/unison-src/transcripts/abilities.md b/unison-src/transcripts/abilities.md deleted file mode 100644 index 3bf6c47ec1..0000000000 --- a/unison-src/transcripts/abilities.md +++ /dev/null @@ -1,27 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -Some random ability stuff to ensure things work. - -```unison - -unique ability A where - one : Nat ->{A} Nat - two : Nat -> Nat ->{A} Nat - three : Nat -> Nat -> Nat ->{A} Nat - four : Nat ->{A} (Nat -> Nat -> Nat -> Nat) - -ha : Request {A} r -> r -ha = cases - { x } -> x - { one i -> c } -> handle c (i+1) with ha - { two i j -> c } -> handle c (i+j) with ha - { three i j k -> c } -> handle c (i+j+k) with ha - { four i -> c } -> handle c (j k l -> i+j+k+l) with ha -``` - -```ucm -.> add -``` diff --git a/unison-src/transcripts/abilities.output.md b/unison-src/transcripts/abilities.output.md deleted file mode 100644 index c90d76a45d..0000000000 --- a/unison-src/transcripts/abilities.output.md +++ /dev/null @@ -1,42 +0,0 @@ - -Some random ability stuff to ensure things work. - -```unison -unique ability A where - one : Nat ->{A} Nat - two : Nat -> Nat ->{A} Nat - three : Nat -> Nat -> Nat ->{A} Nat - four : Nat ->{A} (Nat -> Nat -> Nat -> Nat) - -ha : Request {A} r -> r -ha = cases - { x } -> x - { one i -> c } -> handle c (i+1) with ha - { two i j -> c } -> handle c (i+j) with ha - { three i j k -> c } -> handle c (i+j+k) with ha - { four i -> c } -> handle c (j k l -> i+j+k+l) with ha -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ability A - ha : Request {A} r -> r - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - ability A - ha : Request {A} r -> r - -``` diff --git a/unison-src/transcripts/ability-order-doesnt-affect-hash.md b/unison-src/transcripts/ability-order-doesnt-affect-hash.md deleted file mode 100644 index 4a0606a4bd..0000000000 --- a/unison-src/transcripts/ability-order-doesnt-affect-hash.md +++ /dev/null @@ -1,20 +0,0 @@ -The order of a set of abilities is normalized before hashing. - -```unison -unique ability Foo where - foo : () - -unique ability Bar where - bar : () - -term1 : () ->{Foo, Bar} () -term1 _ = () - -term2 : () ->{Bar, Foo} () -term2 _ = () -``` - -```ucm -.> add -.> names term1 -``` diff --git a/unison-src/transcripts/ability-order-doesnt-affect-hash.output.md b/unison-src/transcripts/ability-order-doesnt-affect-hash.output.md deleted file mode 100644 index 879dc0c624..0000000000 --- a/unison-src/transcripts/ability-order-doesnt-affect-hash.output.md +++ /dev/null @@ -1,51 +0,0 @@ -The order of a set of abilities is normalized before hashing. - -```unison -unique ability Foo where - foo : () - -unique ability Bar where - bar : () - -term1 : () ->{Foo, Bar} () -term1 _ = () - -term2 : () ->{Bar, Foo} () -term2 _ = () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ability Bar - ability Foo - term1 : '{Bar, Foo} () - term2 : '{Bar, Foo} () - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - ability Bar - ability Foo - term1 : '{Bar, Foo} () - term2 : '{Bar, Foo} () - -.> names term1 - - Term - Hash: #8hum58rlih - Names: term1 term2 - - Tip: Use `names.global` to see more results. - -``` diff --git a/unison-src/transcripts/ability-term-conflicts-on-update.md b/unison-src/transcripts/ability-term-conflicts-on-update.md deleted file mode 100644 index 04810a4939..0000000000 --- a/unison-src/transcripts/ability-term-conflicts-on-update.md +++ /dev/null @@ -1,93 +0,0 @@ -# Regression test for updates which conflict with an existing ability constructor - -https://github.com/unisonweb/unison/issues/2786 - -```ucm:hide -.ns> builtins.merge -``` - -First we add an ability to the codebase. -Note that this will create the name `Channels.send` as an ability constructor. - -```unison -unique ability Channels where - send : a -> {Channels} () -``` - -```ucm -.ns> add -``` - -Now we update the ability, changing the name of the constructor, _but_, we simultaneously -add a new top-level term with the same name as the constructor which is being -removed from Channels. - -```unison -unique ability Channels where - sends : [a] -> {Channels} () - -Channels.send : a -> () -Channels.send a = () - -thing : '{Channels} () -thing _ = send 1 -``` - -These should fail with a term/ctor conflict since we exclude the ability from the update. - -```ucm:error -.ns> update.old patch Channels.send -.ns> update.old patch thing -``` - -If however, `Channels.send` and `thing` _depend_ on `Channels`, updating them should succeed since it pulls in the ability as a dependency. - -```unison -unique ability Channels where - sends : [a] -> {Channels} () - -Channels.send : a -> () -Channels.send a = sends [a] - -thing : '{Channels} () -thing _ = send 1 -``` - -These updates should succeed since `Channels` is a dependency. - -```ucm -.ns> update.old.preview patch Channels.send -.ns> update.old.preview patch thing -``` - -We should also be able to successfully update the whole thing. - -```ucm -.ns> update.old -``` - -# Constructor-term conflict - -```ucm:hide -.ns2> builtins.merge -``` - - -```unison -X.x = 1 -``` - -```ucm -.ns2> add -``` - -```unison -structural ability X where - x : () -``` - -This should fail with a ctor/term conflict. - -```ucm:error -.ns2> add -``` diff --git a/unison-src/transcripts/ability-term-conflicts-on-update.output.md b/unison-src/transcripts/ability-term-conflicts-on-update.output.md deleted file mode 100644 index 901446e8d4..0000000000 --- a/unison-src/transcripts/ability-term-conflicts-on-update.output.md +++ /dev/null @@ -1,228 +0,0 @@ -# Regression test for updates which conflict with an existing ability constructor - -https://github.com/unisonweb/unison/issues/2786 - -First we add an ability to the codebase. -Note that this will create the name `Channels.send` as an ability constructor. - -```unison -unique ability Channels where - send : a -> {Channels} () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ability Channels - -``` -```ucm -.ns> add - - ⍟ I've added these definitions: - - ability Channels - -``` -Now we update the ability, changing the name of the constructor, _but_, we simultaneously -add a new top-level term with the same name as the constructor which is being -removed from Channels. - -```unison -unique ability Channels where - sends : [a] -> {Channels} () - -Channels.send : a -> () -Channels.send a = () - -thing : '{Channels} () -thing _ = send 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - Channels.send : a -> () - thing : '{Channels} () - - ⍟ These names already exist. You can `update` them to your - new definition: - - ability Channels - -``` -These should fail with a term/ctor conflict since we exclude the ability from the update. - -```ucm -.ns> update.old patch Channels.send - - x These definitions failed: - - Reason - term/ctor collision Channels.send : a -> () - - Tip: Use `help filestatus` to learn more. - -.ns> update.old patch thing - - ⍟ I've added these definitions: - - Channels.send : a -> () - thing : '{Channels} () - - ⍟ I've updated these names to your new definition: - - ability Channels - -``` -If however, `Channels.send` and `thing` _depend_ on `Channels`, updating them should succeed since it pulls in the ability as a dependency. - -```unison -unique ability Channels where - sends : [a] -> {Channels} () - -Channels.send : a -> () -Channels.send a = sends [a] - -thing : '{Channels} () -thing _ = send 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⊡ Previously added definitions will be ignored: Channels - - ⍟ These names already exist. You can `update` them to your - new definition: - - Channels.send : a ->{Channels} () - thing : '{Channels} () - -``` -These updates should succeed since `Channels` is a dependency. - -```ucm -.ns> update.old.preview patch Channels.send - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⊡ Previously added definitions will be ignored: Channels - - ⍟ These names already exist. You can `update` them to your - new definition: - - Channels.send : a ->{Channels} () - -.ns> update.old.preview patch thing - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⊡ Previously added definitions will be ignored: Channels - - ⍟ These names already exist. You can `update` them to your - new definition: - - Channels.send : a ->{Channels} () - thing : '{Channels} () - -``` -We should also be able to successfully update the whole thing. - -```ucm -.ns> update.old - - ⊡ Ignored previously added definitions: Channels - - ⍟ I've updated these names to your new definition: - - Channels.send : a ->{Channels} () - thing : '{Channels} () - -``` -# Constructor-term conflict - -```unison -X.x = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - X.x : Nat - -``` -```ucm -.ns2> add - - ⍟ I've added these definitions: - - X.x : Nat - -``` -```unison -structural ability X where - x : () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - x These definitions would fail on `add` or `update`: - - Reason - blocked structural ability X - ctor/term collision X.x - - Tip: Use `help filestatus` to learn more. - -``` -This should fail with a ctor/term conflict. - -```ucm -.ns2> add - - x These definitions failed: - - Reason - blocked structural ability X - ctor/term collision X.x - - Tip: Use `help filestatus` to learn more. - -``` diff --git a/unison-src/transcripts/add-run.md b/unison-src/transcripts/add-run.md deleted file mode 100644 index 99ac7792e3..0000000000 --- a/unison-src/transcripts/add-run.md +++ /dev/null @@ -1,129 +0,0 @@ -# add.run - -## Basic usage - -```ucm:hide -.> builtins.merge -``` - -```unison -even : Nat -> Boolean -even x = if x == 0 then true else odd (drop x 1) - -odd : Nat -> Boolean -odd x = if x == 0 then false else even (drop x 1) - -is2even : 'Boolean -is2even = '(even 2) -``` - -it errors if there isn't a previous run - -```ucm:error -.> add.run foo -``` - -```ucm -.> run is2even -``` - -it errors if the desired result name conflicts with a name in the -unison file -```ucm:error -.> add.run is2even -``` - -otherwise, the result is successfully persisted -```ucm -.> add.run foo.bar.baz -``` - -```ucm -.> view foo.bar.baz -``` - -## It resolves references within the unison file - -```unison -z b = b Nat.+ 12 -y a b = a Nat.+ b Nat.+ z 10 - - - - -main : '{IO, Exception} (Nat -> Nat -> Nat) -main _ = y -``` - -```ucm -.> run main -.> add.run result -``` - -## It resolves references within the codebase - -```unison -inc : Nat -> Nat -inc x = x + 1 -``` - -```ucm -.> add inc -``` - -```unison -main : '(Nat -> Nat) -main _ x = inc x -``` - -```ucm -.> run main -.> add.run natfoo -.> view natfoo -``` - -## It captures scratch file dependencies at run time - -```unison -x = 1 -y = x + x -main = 'y -``` - -```ucm -.> run main -``` - - -```unison -x = 50 -``` - -this saves 2 to xres, rather than 100 -```ucm -.> add.run xres -.> view xres -``` - -## It fails with a message if add cannot complete cleanly - -```unison -main = '5 -``` - -```ucm:error -.> run main -.> add.run xres -``` - -## It works with absolute names - -```unison -main = '5 -``` - -```ucm -.> run main -.> add.run .an.absolute.name -.> view .an.absolute.name -``` diff --git a/unison-src/transcripts/add-run.output.md b/unison-src/transcripts/add-run.output.md deleted file mode 100644 index 3d97788e78..0000000000 --- a/unison-src/transcripts/add-run.output.md +++ /dev/null @@ -1,308 +0,0 @@ -# add.run - -## Basic usage - -```unison -even : Nat -> Boolean -even x = if x == 0 then true else odd (drop x 1) - -odd : Nat -> Boolean -odd x = if x == 0 then false else even (drop x 1) - -is2even : 'Boolean -is2even = '(even 2) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - even : Nat -> Boolean - is2even : 'Boolean - odd : Nat -> Boolean - -``` -it errors if there isn't a previous run - -```ucm -.> add.run foo - - ⚠️ - - There is no previous evaluation to save. Use `run` to evaluate - something before attempting to save it. - -``` -```ucm -.> run is2even - - true - -``` -it errors if the desired result name conflicts with a name in the -unison file -```ucm -.> add.run is2even - - ⚠️ - - Cannot save the last run result into `is2even` because that - name conflicts with a name in the scratch file. - -``` -otherwise, the result is successfully persisted -```ucm -.> add.run foo.bar.baz - - ⍟ I've added these definitions: - - foo.bar.baz : Boolean - -``` -```ucm -.> view foo.bar.baz - - foo.bar.baz : Boolean - foo.bar.baz = true - -``` -## It resolves references within the unison file - -```unison -z b = b Nat.+ 12 -y a b = a Nat.+ b Nat.+ z 10 - - - - -main : '{IO, Exception} (Nat -> Nat -> Nat) -main _ = y -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - main : '{IO, Exception} (Nat -> Nat -> Nat) - y : Nat -> Nat -> Nat - z : Nat -> Nat - -``` -```ucm -.> run main - - a b -> a Nat.+ b Nat.+ z 10 - -.> add.run result - - ⍟ I've added these definitions: - - result : Nat -> Nat -> Nat - z : Nat -> Nat - -``` -## It resolves references within the codebase - -```unison -inc : Nat -> Nat -inc x = x + 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - inc : Nat -> Nat - -``` -```ucm -.> add inc - - ⍟ I've added these definitions: - - inc : Nat -> Nat - -``` -```unison -main : '(Nat -> Nat) -main _ x = inc x -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - main : '(Nat -> Nat) - -``` -```ucm -.> run main - - inc - -.> add.run natfoo - - ⍟ I've added these definitions: - - natfoo : Nat -> Nat - -.> view natfoo - - natfoo : Nat -> Nat - natfoo = inc - -``` -## It captures scratch file dependencies at run time - -```unison -x = 1 -y = x + x -main = 'y -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - main : 'Nat - x : Nat - y : Nat - -``` -```ucm -.> run main - - 2 - -``` -```unison -x = 50 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - x : Nat - -``` -this saves 2 to xres, rather than 100 -```ucm -.> add.run xres - - ⍟ I've added these definitions: - - xres : Nat - -.> view xres - - xres : Nat - xres = 2 - -``` -## It fails with a message if add cannot complete cleanly - -```unison -main = '5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - main : 'Nat - -``` -```ucm -.> run main - - 5 - -.> add.run xres - - x These definitions failed: - - Reason - needs update xres : Nat - - Tip: Use `help filestatus` to learn more. - -``` -## It works with absolute names - -```unison -main = '5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - main : 'Nat - -``` -```ucm -.> run main - - 5 - -.> add.run .an.absolute.name - - ⍟ I've added these definitions: - - .an.absolute.name : Nat - -.> view .an.absolute.name - - .an.absolute.name : Nat - .an.absolute.name = 5 - -``` diff --git a/unison-src/transcripts/add-test-watch-roundtrip.md b/unison-src/transcripts/add-test-watch-roundtrip.md deleted file mode 100644 index e8d070d2b1..0000000000 --- a/unison-src/transcripts/add-test-watch-roundtrip.md +++ /dev/null @@ -1,15 +0,0 @@ -```ucm:hide -.> builtins.mergeio -``` - -```unison:hide -test> foo : [Test.Result] -foo = [] -``` - -Apparently when we add a test watch, we add a type annotation to it, even if it already has one. We don't want this to happen though! - -```ucm -.> add -.> view foo -``` diff --git a/unison-src/transcripts/add-test-watch-roundtrip.output.md b/unison-src/transcripts/add-test-watch-roundtrip.output.md deleted file mode 100644 index 5c9389ca1f..0000000000 --- a/unison-src/transcripts/add-test-watch-roundtrip.output.md +++ /dev/null @@ -1,21 +0,0 @@ -```unison -test> foo : [Test.Result] -foo = [] -``` - -Apparently when we add a test watch, we add a type annotation to it, even if it already has one. We don't want this to happen though! - -```ucm -.> add - - ⍟ I've added these definitions: - - foo : [Result] - -.> view foo - - foo : [Result] - foo : [Result] - foo = [] - -``` diff --git a/unison-src/transcripts/addupdatemessages.md b/unison-src/transcripts/addupdatemessages.md deleted file mode 100644 index c644d921a0..0000000000 --- a/unison-src/transcripts/addupdatemessages.md +++ /dev/null @@ -1,63 +0,0 @@ -# Adds and updates - -Let's set up some definitions to start: - -```ucm:hide -.> builtins.merge -``` - -```unison -x = 1 -y = 2 - -structural type X = One Nat -structural type Y = Two Nat Nat -``` - -Expected: `x` and `y`, `X`, and `Y` exist as above. UCM tells you this. - -```ucm -.> add -``` - -Let's add an alias for `1` and `One`: - -```unison -z = 1 - -structural type Z = One Nat -``` - -Expected: `z` is now `1`. UCM tells you that this definition is also called `x`. -Also, `Z` is an alias for `X`. - -```ucm -.> add -``` - -Let's update something that has an alias (to a value that doesn't have a name already): - -```unison -x = 3 -structural type X = Three Nat Nat Nat -``` - -Expected: `x` is now `3` and `X` has constructor `Three`. UCM tells you the old definitions were also called `z` and `Z` and these names have also been updated. - -```ucm -.> update -``` - -Update it to something that already exists with a different name: - -```unison -x = 2 -structural type X = Two Nat Nat -``` - -Expected: `x` is now `2` and `X` is `Two`. UCM says the old definition was also named `z/Z`, and was also updated. And it says the new definition is also named `y/Y`. - -```ucm -.> update -``` - diff --git a/unison-src/transcripts/addupdatemessages.output.md b/unison-src/transcripts/addupdatemessages.output.md deleted file mode 100644 index 44925f17c8..0000000000 --- a/unison-src/transcripts/addupdatemessages.output.md +++ /dev/null @@ -1,153 +0,0 @@ -# Adds and updates - -Let's set up some definitions to start: - -```unison -x = 1 -y = 2 - -structural type X = One Nat -structural type Y = Two Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type X - structural type Y - x : Nat - y : Nat - -``` -Expected: `x` and `y`, `X`, and `Y` exist as above. UCM tells you this. - -```ucm -.> add - - ⍟ I've added these definitions: - - structural type X - structural type Y - x : Nat - y : Nat - -``` -Let's add an alias for `1` and `One`: - -```unison -z = 1 - -structural type Z = One Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type Z - (also named X) - z : Nat - (also named x) - -``` -Expected: `z` is now `1`. UCM tells you that this definition is also called `x`. -Also, `Z` is an alias for `X`. - -```ucm -.> add - - ⍟ I've added these definitions: - - structural type Z - (also named X) - z : Nat - (also named x) - -``` -Let's update something that has an alias (to a value that doesn't have a name already): - -```unison -x = 3 -structural type X = Three Nat Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - structural type X - (The old definition is also named Z.) - x : Nat - (The old definition is also named z.) - -``` -Expected: `x` is now `3` and `X` has constructor `Three`. UCM tells you the old definitions were also called `z` and `Z` and these names have also been updated. - -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Everything typechecks, so I'm saving the results... - - Done. - -``` -Update it to something that already exists with a different name: - -```unison -x = 2 -structural type X = Two Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - structural type X - (also named Y) - x : Nat - (also named y) - -``` -Expected: `x` is now `2` and `X` is `Two`. UCM says the old definition was also named `z/Z`, and was also updated. And it says the new definition is also named `y/Y`. - -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -``` diff --git a/unison-src/transcripts/alias-many.md b/unison-src/transcripts/alias-many.md index c682faf22b..e693e50a5b 100644 --- a/unison-src/transcripts/alias-many.md +++ b/unison-src/transcripts/alias-many.md @@ -1,7 +1,7 @@ -```ucm:hide -.> builtins.merge +``` ucm :hide +scratch/main> builtins.merge lib.builtins ``` -```unison:hide:all +``` unison :hide-all List.adjacentPairs : [a] -> [(a, a)] List.adjacentPairs as = go xs acc = @@ -94,15 +94,15 @@ List.takeWhile p xs = _ -> acc go xs [] ``` -```ucm:hide -.stuff> add +``` ucm :hide +scratch/main> add ``` The `alias.many` command can be used to copy definitions from the current namespace into your curated one. The names that will be used in the target namespace are the names you specify, relative to the current namespace: ``` -.> help alias.many +scratch/main> help alias.many alias.many (or copy) `alias.many [relative2...] ` creates aliases `relative1`, `relative2`, ... @@ -112,9 +112,9 @@ The names that will be used in the target namespace are the names you specify, r Let's try it! -```ucm -.> alias.many stuff.List.adjacentPairs stuff.List.all stuff.List.any stuff.List.chunk stuff.List.chunksOf stuff.List.dropWhile stuff.List.first stuff.List.init stuff.List.intersperse stuff.List.isEmpty stuff.List.last stuff.List.replicate stuff.List.splitAt stuff.List.tail stuff.List.takeWhile .mylib -.> find-in mylib +``` ucm +scratch/main> alias.many List.adjacentPairs List.all List.any List.chunk List.chunksOf List.dropWhile List.first List.init List.intersperse List.isEmpty List.last List.replicate List.splitAt List.tail List.takeWhile mylib +scratch/main> find-in mylib ``` Thanks, `alias.many`! diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 8236c60d04..a4cf25a46b 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -1,69 +1,72 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtins +``` + +``` ucm :hide +scratch/main> add +``` + The `alias.many` command can be used to copy definitions from the current namespace into your curated one. The names that will be used in the target namespace are the names you specify, relative to the current namespace: -``` -.> help alias.many +``` +scratch/main> help alias.many alias.many (or copy) `alias.many [relative2...] ` creates aliases `relative1`, `relative2`, ... in the namespace `namespace`. `alias.many foo.foo bar.bar .quux` creates aliases `.quux.foo.foo` and `.quux.bar.bar`. - ``` -Let's try it! +Let's try it\! + +``` ucm +scratch/main> alias.many List.adjacentPairs List.all List.any List.chunk List.chunksOf List.dropWhile List.first List.init List.intersperse List.isEmpty List.last List.replicate List.splitAt List.tail List.takeWhile mylib -```ucm -.> alias.many stuff.List.adjacentPairs stuff.List.all stuff.List.any stuff.List.chunk stuff.List.chunksOf stuff.List.dropWhile stuff.List.first stuff.List.init stuff.List.intersperse stuff.List.isEmpty stuff.List.last stuff.List.replicate stuff.List.splitAt stuff.List.tail stuff.List.takeWhile .mylib + Here's what changed in mylib : - Here's what changed in .mylib : - Added definitions: - - 1. stuff.List.adjacentPairs : [a] -> [(a, a)] - 2. stuff.List.all : (a ->{g} Boolean) - -> [a] - ->{g} Boolean - 3. stuff.List.any : (a ->{g} Boolean) - -> [a] - ->{g} Boolean - 4. stuff.List.chunk : Nat -> [a] -> [[a]] - 5. stuff.List.chunksOf : Nat -> [a] -> [[a]] - 6. stuff.List.dropWhile : (a ->{g} Boolean) - -> [a] - ->{g} [a] - 7. stuff.List.first : [a] -> Optional a - 8. stuff.List.init : [a] -> Optional [a] - 9. stuff.List.intersperse : a -> [a] -> [a] - 10. stuff.List.isEmpty : [a] -> Boolean - 11. stuff.List.last : [a] -> Optional a - 12. stuff.List.replicate : Nat -> a -> [a] - 13. stuff.List.splitAt : Nat -> [a] -> ([a], [a]) - 14. stuff.List.tail : [a] -> Optional [a] - 15. stuff.List.takeWhile : (a ->{𝕖} Boolean) - -> [a] - ->{𝕖} [a] - - Tip: You can use `undo` or `reflog` to undo this change. -.> find-in mylib + 1. List.adjacentPairs : [a] -> [(a, a)] + 2. List.all : (a ->{g} Boolean) + -> [a] + ->{g} Boolean + 3. List.any : (a ->{g} Boolean) + -> [a] + ->{g} Boolean + 4. List.chunk : Nat -> [a] -> [[a]] + 5. List.chunksOf : Nat -> [a] -> [[a]] + 6. List.dropWhile : (a ->{g} Boolean) -> [a] ->{g} [a] + 7. List.first : [a] -> Optional a + 8. List.init : [a] -> Optional [a] + 9. List.intersperse : a -> [a] -> [a] + 10. List.isEmpty : [a] -> Boolean + 11. List.last : [a] -> Optional a + 12. List.replicate : Nat -> a -> [a] + 13. List.splitAt : Nat -> [a] -> ([a], [a]) + 14. List.tail : [a] -> Optional [a] + 15. List.takeWhile : (a ->{𝕖} Boolean) -> [a] ->{𝕖} [a] - 1. stuff.List.adjacentPairs : [a] -> [(a, a)] - 2. stuff.List.all : (a ->{g} Boolean) -> [a] ->{g} Boolean - 3. stuff.List.any : (a ->{g} Boolean) -> [a] ->{g} Boolean - 4. stuff.List.chunk : Nat -> [a] -> [[a]] - 5. stuff.List.chunksOf : Nat -> [a] -> [[a]] - 6. stuff.List.dropWhile : (a ->{g} Boolean) -> [a] ->{g} [a] - 7. stuff.List.first : [a] -> Optional a - 8. stuff.List.init : [a] -> Optional [a] - 9. stuff.List.intersperse : a -> [a] -> [a] - 10. stuff.List.isEmpty : [a] -> Boolean - 11. stuff.List.last : [a] -> Optional a - 12. stuff.List.replicate : Nat -> a -> [a] - 13. stuff.List.splitAt : Nat -> [a] -> ([a], [a]) - 14. stuff.List.tail : [a] -> Optional [a] - 15. stuff.List.takeWhile : (a ->{𝕖} Boolean) -> [a] ->{𝕖} [a] - + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. +scratch/main> find-in mylib + + 1. List.adjacentPairs : [a] -> [(a, a)] + 2. List.all : (a ->{g} Boolean) -> [a] ->{g} Boolean + 3. List.any : (a ->{g} Boolean) -> [a] ->{g} Boolean + 4. List.chunk : Nat -> [a] -> [[a]] + 5. List.chunksOf : Nat -> [a] -> [[a]] + 6. List.dropWhile : (a ->{g} Boolean) -> [a] ->{g} [a] + 7. List.first : [a] -> Optional a + 8. List.init : [a] -> Optional [a] + 9. List.intersperse : a -> [a] -> [a] + 10. List.isEmpty : [a] -> Boolean + 11. List.last : [a] -> Optional a + 12. List.replicate : Nat -> a -> [a] + 13. List.splitAt : Nat -> [a] -> ([a], [a]) + 14. List.tail : [a] -> Optional [a] + 15. List.takeWhile : (a ->{𝕖} Boolean) -> [a] ->{𝕖} [a] ``` -Thanks, `alias.many! + +Thanks, `alias.many`\! diff --git a/unison-src/transcripts/anf-tests.md b/unison-src/transcripts/anf-tests.md deleted file mode 100644 index 122a673060..0000000000 --- a/unison-src/transcripts/anf-tests.md +++ /dev/null @@ -1,34 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -This tests a variable related bug in the ANF compiler. - -The nested let would get flattened out, resulting in: - - bar = result - -which would be handled by renaming. However, the _context_ portion of -the rest of the code was not being renamed correctly, so `bar` would -remain in the definition of `baz`. - -```unison -foo _ = - id x = x - void x = () - bar = let - void (Debug.watch "hello" "hello") - result = 5 - void (Debug.watch "goodbye" "goodbye") - result - baz = id bar - baz - -> !foo -``` - -```ucm -.> add -``` - diff --git a/unison-src/transcripts/anf-tests.output.md b/unison-src/transcripts/anf-tests.output.md deleted file mode 100644 index c200d1056f..0000000000 --- a/unison-src/transcripts/anf-tests.output.md +++ /dev/null @@ -1,54 +0,0 @@ - -This tests a variable related bug in the ANF compiler. - -The nested let would get flattened out, resulting in: - - bar = result - -which would be handled by renaming. However, the _context_ portion of -the rest of the code was not being renamed correctly, so `bar` would -remain in the definition of `baz`. - -```unison -foo _ = - id x = x - void x = () - bar = let - void (Debug.watch "hello" "hello") - result = 5 - void (Debug.watch "goodbye" "goodbye") - result - baz = id bar - baz - -> !foo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo : ∀ _. _ -> Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 12 | > !foo - ⧩ - 5 - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - foo : ∀ _. _ -> Nat - -``` diff --git a/unison-src/transcripts/any-extract.md b/unison-src/transcripts/any-extract.md deleted file mode 100644 index 5e9d09324e..0000000000 --- a/unison-src/transcripts/any-extract.md +++ /dev/null @@ -1,23 +0,0 @@ -# Unit tests for Any.unsafeExtract - -```ucm:hide -.> builtins.mergeio -.> load unison-src/transcripts-using-base/base.u -.> add -``` - -Any.unsafeExtract is a way to extract the value contained in an Any. This is unsafe because it allows the programmer to coerce a value into any type, which would cause undefined behaviour if used to coerce a value to the wrong type. - -```unison - -test> Any.unsafeExtract.works = - use Nat != - checks [1 == Any.unsafeExtract (Any 1), - not (1 == Any.unsafeExtract (Any 2)), - (Some 1) == Any.unsafeExtract (Any (Some 1)) - ] -``` - -```ucm -.> add -``` diff --git a/unison-src/transcripts/any-extract.output.md b/unison-src/transcripts/any-extract.output.md deleted file mode 100644 index 75567fb411..0000000000 --- a/unison-src/transcripts/any-extract.output.md +++ /dev/null @@ -1,41 +0,0 @@ -# Unit tests for Any.unsafeExtract - -Any.unsafeExtract is a way to extract the value contained in an Any. This is unsafe because it allows the programmer to coerce a value into any type, which would cause undefined behaviour if used to coerce a value to the wrong type. - -```unison -test> Any.unsafeExtract.works = - use Nat != - checks [1 == Any.unsafeExtract (Any 1), - not (1 == Any.unsafeExtract (Any 2)), - (Some 1) == Any.unsafeExtract (Any (Some 1)) - ] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - Any.unsafeExtract.works : [Result] - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 3 | checks [1 == Any.unsafeExtract (Any 1), - - ✅ Passed Passed - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - Any.unsafeExtract.works : [Result] - -``` diff --git a/unison-src/transcripts/api-doc-rendering.md b/unison-src/transcripts/api-doc-rendering.md deleted file mode 100644 index 6deffaaba8..0000000000 --- a/unison-src/transcripts/api-doc-rendering.md +++ /dev/null @@ -1,94 +0,0 @@ -# Doc rendering - -```ucm:hide -.> builtins.mergeio -``` - -```unison:hide -structural type Maybe a = Nothing | Just a -otherTerm = "text" - -otherDoc : (Text -> Doc2) -> Doc2 -otherDoc mkMsg = {{ -This doc should be embedded. - -{{mkMsg "message"}} - -}} - -{{ -# Heading - -## Heading 2 - -Term Link: {otherTerm} - -Type Link: {type Maybe} - -Term source: - -@source{term} - -Term signature: - -@signature{term} - -* List item - -1. Numbered list item - -> Block quote - - Code block - -Inline code: - -`` 1 + 2 `` - -`"doesn't typecheck" + 1` - -[Link](https://unison-lang.org) - -![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) - -**Bold** - -*Italic* - -~~Strikethrough~~ - -Horizontal rule - ---- - -Table - -| Header 1 | Header 2 | -| -------- | -------- | -| Cell 1 | Cell 2 | -| Cell 3 | Cell 4 | - - -Video - -{{ Special (Embed (Any (Video [(MediaSource "test.mp4" None)] [("poster", "test.png")]))) }} - -Transclusion/evaluation: - -{{otherDoc (a -> Word a )}} - -}} -term = 42 -``` - -```ucm:hide -.> add -``` - -```ucm -.> display term.doc -``` - -```api -GET /api/non-project-code/getDefinition?names=term -``` diff --git a/unison-src/transcripts/api-doc-rendering.output.md b/unison-src/transcripts/api-doc-rendering.output.md deleted file mode 100644 index cac34211af..0000000000 --- a/unison-src/transcripts/api-doc-rendering.output.md +++ /dev/null @@ -1,943 +0,0 @@ -# Doc rendering - -```unison -structural type Maybe a = Nothing | Just a -otherTerm = "text" - -otherDoc : (Text -> Doc2) -> Doc2 -otherDoc mkMsg = {{ -This doc should be embedded. - -{{mkMsg "message"}} - -}} - -{{ -# Heading - -## Heading 2 - -Term Link: {otherTerm} - -Type Link: {type Maybe} - -Term source: - -@source{term} - -Term signature: - -@signature{term} - -* List item - -1. Numbered list item - -> Block quote - - Code block - -Inline code: - -`` 1 + 2 `` - -`"doesn't typecheck" + 1` - -[Link](https://unison-lang.org) - -![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) - -**Bold** - -*Italic* - -~~Strikethrough~~ - -Horizontal rule - ---- - -Table - -| Header 1 | Header 2 | -| -------- | -------- | -| Cell 1 | Cell 2 | -| Cell 3 | Cell 4 | - - -Video - -{{ Special (Embed (Any (Video [(MediaSource "test.mp4" None)] [("poster", "test.png")]))) }} - -Transclusion/evaluation: - -{{otherDoc (a -> Word a )}} - -}} -term = 42 -``` - -```ucm -.> display term.doc - - # Heading - - # Heading 2 - - Term Link: otherTerm - - Type Link: Maybe - - Term source: - - term : Nat - term = 42 - - Term signature: - - term : Nat - - * List item - - 1. Numbered list item - - > Block quote - - Code block - - Inline code: - - `1 Nat.+ 2` - - `"doesn't typecheck" + 1` - - Link - - ![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) - - Bold - - Italic - - ~~Strikethrough~~ - - Horizontal rule - - --- - - Table - - | Header 1 | Header 2 | | -------- | -------- | | Cell 1 | - Cell 2 | | Cell 3 | Cell 4 | - - Video - - - {{ embed {{ - Video - [MediaSource "test.mp4" Nothing] - [("poster", "test.png")] }} }} - - - Transclusion/evaluation: - - This doc should be embedded. - - message - -``` -```api -GET /api/non-project-code/getDefinition?names=term -{ - "missingDefinitions": [], - "termDefinitions": { - "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": { - "bestTermName": "term", - "defnTermTag": "Plain", - "signature": [ - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - } - ], - "termDefinition": { - "contents": [ - { - "annotation": { - "contents": "term", - "tag": "HashQualifier" - }, - "segment": "term" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "term", - "tag": "HashQualifier" - }, - "segment": "term" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "NumericLiteral" - }, - "segment": "42" - } - ], - "tag": "UserObject" - }, - "termDocs": [ - [ - "doc", - "#kjfaflbrgl89j2uq4ruubejakm6s02cp3m61ufu7rv7tkbd4nmkvcn1fciue53v0msir9t7ds111ab9er8qfa06gsa9ddfrdfgc99mo", - { - "contents": [ - { - "contents": [ - { - "contents": "Heading", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - [ - { - "contents": [ - { - "contents": [ - { - "contents": "Heading", - "tag": "Word" - }, - { - "contents": "2", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - [ - { - "contents": [ - { - "contents": "Term", - "tag": "Word" - }, - { - "contents": "Link:", - "tag": "Word" - }, - { - "contents": { - "contents": [ - { - "annotation": { - "contents": "#k5gpql9cbdfau6lf1aja24joc3sfctvjor8esu8bemn0in3l148otb0t3vebgqrt6qml302h62bbfeftg65gec1v8ouin5m6v2969d8", - "tag": "TermReference" - }, - "segment": "otherTerm" - } - ], - "tag": "Link" - }, - "tag": "Special" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "Type", - "tag": "Word" - }, - { - "contents": "Link:", - "tag": "Word" - }, - { - "contents": { - "contents": [ - { - "annotation": { - "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg", - "tag": "TypeReference" - }, - "segment": "Maybe" - } - ], - "tag": "Link" - }, - "tag": "Special" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "Term", - "tag": "Word" - }, - { - "contents": "source:", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": { - "contents": [ - { - "contents": [ - "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", - { - "contents": [ - [ - { - "annotation": { - "contents": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", - "tag": "TermReference" - }, - "segment": "term" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": ": " - }, - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - } - ], - [ - { - "annotation": { - "contents": "term", - "tag": "HashQualifier" - }, - "segment": "term" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "term", - "tag": "HashQualifier" - }, - "segment": "term" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "NumericLiteral" - }, - "segment": "42" - } - ] - ], - "tag": "UserObject" - } - ], - "tag": "Term" - } - ], - "tag": "Source" - }, - "tag": "Special" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "Term", - "tag": "Word" - }, - { - "contents": "signature:", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": { - "contents": [ - [ - { - "annotation": { - "contents": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", - "tag": "TermReference" - }, - "segment": "term" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": ": " - }, - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - } - ] - ], - "tag": "Signature" - }, - "tag": "Special" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": [ - { - "contents": "List", - "tag": "Word" - }, - { - "contents": "item", - "tag": "Word" - } - ], - "tag": "Paragraph" - } - ], - "tag": "BulletedList" - }, - { - "contents": [ - 1, - [ - { - "contents": [ - { - "contents": "Numbered", - "tag": "Word" - }, - { - "contents": "list", - "tag": "Word" - }, - { - "contents": "item", - "tag": "Word" - } - ], - "tag": "Paragraph" - } - ] - ], - "tag": "NumberedList" - }, - { - "contents": [ - { - "contents": ">", - "tag": "Word" - }, - { - "contents": "Block", - "tag": "Word" - }, - { - "contents": "quote", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "Code", - "tag": "Word" - }, - { - "contents": "block", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "Inline", - "tag": "Word" - }, - { - "contents": "code:", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": { - "contents": [ - { - "annotation": { - "tag": "NumericLiteral" - }, - "segment": "1" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat.+", - "tag": "TermReference" - }, - "segment": "Nat.+" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "NumericLiteral" - }, - "segment": "2" - } - ], - "tag": "Example" - }, - "tag": "Special" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": { - "contents": "\"doesn't typecheck\" + 1", - "tag": "Word" - }, - "tag": "Code" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": [ - { - "contents": [ - { - "contents": "Link", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": { - "contents": "https://unison-lang.org", - "tag": "Word" - }, - "tag": "Group" - } - ], - "tag": "NamedLink" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png)", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": { - "contents": [ - { - "contents": "Bold", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - "tag": "Bold" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": { - "contents": [ - { - "contents": "Italic", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - "tag": "Bold" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": { - "contents": [ - { - "contents": "Strikethrough", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - "tag": "Strikethrough" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "Horizontal", - "tag": "Word" - }, - { - "contents": "rule", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "---", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "Table", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "|", - "tag": "Word" - }, - { - "contents": "Header", - "tag": "Word" - }, - { - "contents": "1", - "tag": "Word" - }, - { - "contents": "|", - "tag": "Word" - }, - { - "contents": "Header", - "tag": "Word" - }, - { - "contents": "2", - "tag": "Word" - }, - { - "contents": "|", - "tag": "Word" - }, - { - "contents": "|", - "tag": "Word" - }, - { - "contents": "--------", - "tag": "Word" - }, - { - "contents": "|", - "tag": "Word" - }, - { - "contents": "--------", - "tag": "Word" - }, - { - "contents": "|", - "tag": "Word" - }, - { - "contents": "|", - "tag": "Word" - }, - { - "contents": "Cell", - "tag": "Word" - }, - { - "contents": "1", - "tag": "Word" - }, - { - "contents": "|", - "tag": "Word" - }, - { - "contents": "Cell", - "tag": "Word" - }, - { - "contents": "2", - "tag": "Word" - }, - { - "contents": "|", - "tag": "Word" - }, - { - "contents": "|", - "tag": "Word" - }, - { - "contents": "Cell", - "tag": "Word" - }, - { - "contents": "3", - "tag": "Word" - }, - { - "contents": "|", - "tag": "Word" - }, - { - "contents": "Cell", - "tag": "Word" - }, - { - "contents": "4", - "tag": "Word" - }, - { - "contents": "|", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "Video", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": { - "contents": [ - [ - { - "mediaSourceMimeType": null, - "mediaSourceUrl": "test.mp4" - } - ], - { - "poster": "test.png" - } - ], - "tag": "Video" - }, - "tag": "Special" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "Transclusion/evaluation:", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": [ - { - "contents": [ - { - "contents": "This", - "tag": "Word" - }, - { - "contents": "doc", - "tag": "Word" - }, - { - "contents": "should", - "tag": "Word" - }, - { - "contents": "be", - "tag": "Word" - }, - { - "contents": "embedded.", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - { - "contents": [ - { - "contents": "message", - "tag": "Word" - } - ], - "tag": "Paragraph" - } - ], - "tag": "UntitledSection" - } - ], - "tag": "Paragraph" - } - ] - ], - "tag": "Section" - } - ] - ], - "tag": "Section" - } - ] - ], - "termNames": [ - "term" - ] - } - }, - "typeDefinitions": {} -} -``` \ No newline at end of file diff --git a/unison-src/transcripts/api-find.md b/unison-src/transcripts/api-find.md deleted file mode 100644 index 201d3cad85..0000000000 --- a/unison-src/transcripts/api-find.md +++ /dev/null @@ -1,26 +0,0 @@ -# find api - -```unison -rachel.filesystem.x = 42 -ross.httpClient.y = 43 -joey.httpServer.z = 44 -joey.yaml.zz = 45 -``` - -```ucm -.> add -``` - -```api --- Namespace segment prefix search -GET /api/non-project-code/find?query=http - --- Namespace segment suffix search -GET /api/non-project-code/find?query=Server - --- Substring search -GET /api/non-project-code/find?query=lesys - --- Cross-segment search -GET /api/non-project-code/find?query=joey.http -``` diff --git a/unison-src/transcripts/api-find.output.md b/unison-src/transcripts/api-find.output.md deleted file mode 100644 index 6505a1a320..0000000000 --- a/unison-src/transcripts/api-find.output.md +++ /dev/null @@ -1,255 +0,0 @@ -# find api - -```unison -rachel.filesystem.x = 42 -ross.httpClient.y = 43 -joey.httpServer.z = 44 -joey.yaml.zz = 45 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - joey.httpServer.z : ##Nat - joey.yaml.zz : ##Nat - rachel.filesystem.x : ##Nat - ross.httpClient.y : ##Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - joey.httpServer.z : ##Nat - joey.yaml.zz : ##Nat - rachel.filesystem.x : ##Nat - ross.httpClient.y : ##Nat - -``` -```api --- Namespace segment prefix search -GET /api/non-project-code/find?query=http -[ - [ - { - "result": { - "segments": [ - { - "contents": "ross.", - "tag": "Gap" - }, - { - "contents": "http", - "tag": "Match" - }, - { - "contents": "Client.y", - "tag": "Gap" - } - ] - }, - "score": 156 - }, - { - "contents": { - "bestFoundTermName": "y", - "namedTerm": { - "termHash": "#emomp74i93h6ps0b5sukke0tci0ooba3f9jk21qm919a7act9u7asani84c0mqbdk4lcjrdvr9olpedp23p6df78r4trqlg0cciadc8", - "termName": "ross.httpClient.y", - "termTag": "Plain", - "termType": [ - { - "annotation": { - "contents": "##Nat", - "tag": "HashQualifier" - }, - "segment": "##Nat" - } - ] - } - }, - "tag": "FoundTermResult" - } - ], - [ - { - "result": { - "segments": [ - { - "contents": "joey.", - "tag": "Gap" - }, - { - "contents": "http", - "tag": "Match" - }, - { - "contents": "Server.z", - "tag": "Gap" - } - ] - }, - "score": 156 - }, - { - "contents": { - "bestFoundTermName": "z", - "namedTerm": { - "termHash": "#a84tg4er4kfl9k2p250vp2o1dsp5kmn9a7q8g2bo723qbtbf9sagrl28fa4q0j5f2cv4alsjik6rf487ss646qt95gbm3dd13k7e1fo", - "termName": "joey.httpServer.z", - "termTag": "Plain", - "termType": [ - { - "annotation": { - "contents": "##Nat", - "tag": "HashQualifier" - }, - "segment": "##Nat" - } - ] - } - }, - "tag": "FoundTermResult" - } - ] -] --- Namespace segment suffix search -GET /api/non-project-code/find?query=Server -[ - [ - { - "result": { - "segments": [ - { - "contents": "joey.http", - "tag": "Gap" - }, - { - "contents": "Server", - "tag": "Match" - }, - { - "contents": ".z", - "tag": "Gap" - } - ] - }, - "score": 223 - }, - { - "contents": { - "bestFoundTermName": "z", - "namedTerm": { - "termHash": "#a84tg4er4kfl9k2p250vp2o1dsp5kmn9a7q8g2bo723qbtbf9sagrl28fa4q0j5f2cv4alsjik6rf487ss646qt95gbm3dd13k7e1fo", - "termName": "joey.httpServer.z", - "termTag": "Plain", - "termType": [ - { - "annotation": { - "contents": "##Nat", - "tag": "HashQualifier" - }, - "segment": "##Nat" - } - ] - } - }, - "tag": "FoundTermResult" - } - ] -] --- Substring search -GET /api/non-project-code/find?query=lesys -[ - [ - { - "result": { - "segments": [ - { - "contents": "rachel.fi", - "tag": "Gap" - }, - { - "contents": "lesys", - "tag": "Match" - }, - { - "contents": "tem.x", - "tag": "Gap" - } - ] - }, - "score": 175 - }, - { - "contents": { - "bestFoundTermName": "x", - "namedTerm": { - "termHash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", - "termName": "rachel.filesystem.x", - "termTag": "Plain", - "termType": [ - { - "annotation": { - "contents": "##Nat", - "tag": "HashQualifier" - }, - "segment": "##Nat" - } - ] - } - }, - "tag": "FoundTermResult" - } - ] -] --- Cross-segment search -GET /api/non-project-code/find?query=joey.http -[ - [ - { - "result": { - "segments": [ - { - "contents": "joey.http", - "tag": "Match" - }, - { - "contents": "Server.z", - "tag": "Gap" - } - ] - }, - "score": 300 - }, - { - "contents": { - "bestFoundTermName": "z", - "namedTerm": { - "termHash": "#a84tg4er4kfl9k2p250vp2o1dsp5kmn9a7q8g2bo723qbtbf9sagrl28fa4q0j5f2cv4alsjik6rf487ss646qt95gbm3dd13k7e1fo", - "termName": "joey.httpServer.z", - "termTag": "Plain", - "termType": [ - { - "annotation": { - "contents": "##Nat", - "tag": "HashQualifier" - }, - "segment": "##Nat" - } - ] - } - }, - "tag": "FoundTermResult" - } - ] -] -``` \ No newline at end of file diff --git a/unison-src/transcripts/api-getDefinition.md b/unison-src/transcripts/api-getDefinition.md deleted file mode 100644 index 4a56b2bc9e..0000000000 --- a/unison-src/transcripts/api-getDefinition.md +++ /dev/null @@ -1,54 +0,0 @@ -# Get Definitions Test - -```ucm:hide -.nested> builtins.mergeio -``` - -```unison:hide -{{ Documentation }} -names.x = 42 -``` - -```ucm:hide -.nested> add -``` - -```api --- Should NOT find names by suffix -GET /api/non-project-code/getDefinition?names=x - --- Term names should strip relativeTo prefix. -GET /api/non-project-code/getDefinition?names=names.x&relativeTo=nested - --- Should find definitions by hash, names should be relative -GET /api/non-project-code/getDefinition?names=%23qkhkl0n238&relativeTo=nested -``` - -```ucm:hide -.doctest> builtins.mergeio -``` - -```unison:hide -thing.doc = {{ The correct docs for the thing }} -thing = "A thing" -thingalias.doc = {{ Docs for the alias, should not be displayed }} -thingalias = "A thing" -otherstuff.thing.doc = {{ A doc for a different term with the same name, should not be displayed }} -otherstuff.thing = "A different thing" -``` - -```ucm:hide -.doctest> add -``` - -Only docs for the term we request should be returned, even if there are other term docs with the same suffix. - -```api -GET /api/non-project-code/getDefinition?names=thing&relativeTo=doctest -``` - -If we request a doc, the api should return the source, but also the rendered doc should appear in the 'termDocs' list. - -```api -GET /api/non-project-code/getDefinition?names=thing.doc&relativeTo=doctest -``` diff --git a/unison-src/transcripts/api-getDefinition.output.md b/unison-src/transcripts/api-getDefinition.output.md deleted file mode 100644 index 24debb744d..0000000000 --- a/unison-src/transcripts/api-getDefinition.output.md +++ /dev/null @@ -1,510 +0,0 @@ -# Get Definitions Test - -```unison -{{ Documentation }} -names.x = 42 -``` - -```api --- Should NOT find names by suffix -GET /api/non-project-code/getDefinition?names=x -{ - "missingDefinitions": [ - "x" - ], - "termDefinitions": {}, - "typeDefinitions": {} -} --- Term names should strip relativeTo prefix. -GET /api/non-project-code/getDefinition?names=names.x&relativeTo=nested -{ - "missingDefinitions": [], - "termDefinitions": { - "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": { - "bestTermName": "x", - "defnTermTag": "Plain", - "signature": [ - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - } - ], - "termDefinition": { - "contents": [ - { - "annotation": { - "contents": "x", - "tag": "HashQualifier" - }, - "segment": "x" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "x", - "tag": "HashQualifier" - }, - "segment": "x" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "NumericLiteral" - }, - "segment": "42" - } - ], - "tag": "UserObject" - }, - "termDocs": [ - [ - "doc", - "#ulr9f75rpcrv79d7sfo2ep2tvbntu3e360lfomird2bdpj4bnea230e8o5j0b9our8vggocpa7eck3pus14fcfajlttat1bg71t6rbg", - { - "contents": [ - { - "contents": "Documentation", - "tag": "Word" - } - ], - "tag": "Paragraph" - } - ] - ], - "termNames": [ - "names.x" - ] - } - }, - "typeDefinitions": {} -} --- Should find definitions by hash, names should be relative -GET /api/non-project-code/getDefinition?names=%23qkhkl0n238&relativeTo=nested -{ - "missingDefinitions": [], - "termDefinitions": { - "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": { - "bestTermName": "x", - "defnTermTag": "Plain", - "signature": [ - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - } - ], - "termDefinition": { - "contents": [ - { - "annotation": { - "contents": "x", - "tag": "HashQualifier" - }, - "segment": "x" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "x", - "tag": "HashQualifier" - }, - "segment": "x" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "NumericLiteral" - }, - "segment": "42" - } - ], - "tag": "UserObject" - }, - "termDocs": [ - [ - "doc", - "#ulr9f75rpcrv79d7sfo2ep2tvbntu3e360lfomird2bdpj4bnea230e8o5j0b9our8vggocpa7eck3pus14fcfajlttat1bg71t6rbg", - { - "contents": [ - { - "contents": "Documentation", - "tag": "Word" - } - ], - "tag": "Paragraph" - } - ] - ], - "termNames": [ - "names.x" - ] - } - }, - "typeDefinitions": {} -} -``````unison -thing.doc = {{ The correct docs for the thing }} -thing = "A thing" -thingalias.doc = {{ Docs for the alias, should not be displayed }} -thingalias = "A thing" -otherstuff.thing.doc = {{ A doc for a different term with the same name, should not be displayed }} -otherstuff.thing = "A different thing" -``` - -Only docs for the term we request should be returned, even if there are other term docs with the same suffix. - -```api -GET /api/non-project-code/getDefinition?names=thing&relativeTo=doctest -{ - "missingDefinitions": [], - "termDefinitions": { - "#jksc1s5kud95ro5ivngossullt2oavsd41s3u48bch67jf3gknru5j6hmjslonkd5sdqs8mr8k4rrnef8fodngbg4sm7u6au564ekjg": { - "bestTermName": "thing", - "defnTermTag": "Plain", - "signature": [ - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - } - ], - "termDefinition": { - "contents": [ - { - "annotation": { - "contents": "thing", - "tag": "HashQualifier" - }, - "segment": "thing" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "thing", - "tag": "HashQualifier" - }, - "segment": "thing" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TextLiteral" - }, - "segment": "\"A thing\"" - } - ], - "tag": "UserObject" - }, - "termDocs": [ - [ - "thing.doc", - "#t9qfdoiuskj4n9go8cftj1r83s43s3o7sppafm5vr0bq5feieb7ap0cie5ed2qsf9g3ig448vffhnajinq81pnnkila1jp2epa7f26o", - { - "contents": [ - { - "contents": "The", - "tag": "Word" - }, - { - "contents": "correct", - "tag": "Word" - }, - { - "contents": "docs", - "tag": "Word" - }, - { - "contents": "for", - "tag": "Word" - }, - { - "contents": "the", - "tag": "Word" - }, - { - "contents": "thing", - "tag": "Word" - } - ], - "tag": "Paragraph" - } - ] - ], - "termNames": [ - "thing", - "thingalias" - ] - } - }, - "typeDefinitions": {} -} -```If we request a doc, the api should return the source, but also the rendered doc should appear in the 'termDocs' list. - -```api -GET /api/non-project-code/getDefinition?names=thing.doc&relativeTo=doctest -{ - "missingDefinitions": [], - "termDefinitions": { - "#t9qfdoiuskj4n9go8cftj1r83s43s3o7sppafm5vr0bq5feieb7ap0cie5ed2qsf9g3ig448vffhnajinq81pnnkila1jp2epa7f26o": { - "bestTermName": "thing.doc", - "defnTermTag": "Doc", - "signature": [ - { - "annotation": { - "contents": "#ej86si0ur1lsjade71dojr25phk9bbom9rdks6dltolos5tjivakujcriqe02npba53n9gd7tkh8bmv08ttjb9t35lq2ch5heshqcs0", - "tag": "TypeReference" - }, - "segment": "Doc2" - } - ], - "termDefinition": { - "contents": [ - { - "annotation": { - "contents": "thing.doc", - "tag": "HashQualifier" - }, - "segment": "thing.doc" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "#ej86si0ur1lsjade71dojr25phk9bbom9rdks6dltolos5tjivakujcriqe02npba53n9gd7tkh8bmv08ttjb9t35lq2ch5heshqcs0", - "tag": "TypeReference" - }, - "segment": "Doc2" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "thing.doc", - "tag": "HashQualifier" - }, - "segment": "thing.doc" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "DocDelimiter" - }, - "segment": "{{" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": null, - "segment": "The" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": null, - "segment": "correct" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": null, - "segment": "docs" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": null, - "segment": "for" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": null, - "segment": "the" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": null, - "segment": "thing" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "DocDelimiter" - }, - "segment": "}}" - } - ], - "tag": "UserObject" - }, - "termDocs": [ - [ - "thing.doc", - "#t9qfdoiuskj4n9go8cftj1r83s43s3o7sppafm5vr0bq5feieb7ap0cie5ed2qsf9g3ig448vffhnajinq81pnnkila1jp2epa7f26o", - { - "contents": [ - { - "contents": "The", - "tag": "Word" - }, - { - "contents": "correct", - "tag": "Word" - }, - { - "contents": "docs", - "tag": "Word" - }, - { - "contents": "for", - "tag": "Word" - }, - { - "contents": "the", - "tag": "Word" - }, - { - "contents": "thing", - "tag": "Word" - } - ], - "tag": "Paragraph" - } - ] - ], - "termNames": [ - "thing.doc" - ] - } - }, - "typeDefinitions": {} -} -``` \ No newline at end of file diff --git a/unison-src/transcripts/api-list-projects-branches.md b/unison-src/transcripts/api-list-projects-branches.md deleted file mode 100644 index 111489cf97..0000000000 --- a/unison-src/transcripts/api-list-projects-branches.md +++ /dev/null @@ -1,24 +0,0 @@ -# List Projects And Branches Test - -```ucm:hide -.> project.create-empty project-one -.> project.create-empty project-two -.> project.create-empty project-three -project-one/main> branch branch-one -project-one/main> branch branch-two -project-one/main> branch branch-three -``` - -```api --- Should list all projects -GET /api/projects - --- Should list projects starting with project-t -GET /api/projects?prefix=project-t - --- Should list all branches -GET /api/projects/project-one/branches - --- Should list all branches beginning with branch-t -GET /api/projects/project-one/branches?prefix=branch-t -``` diff --git a/unison-src/transcripts/api-list-projects-branches.output.md b/unison-src/transcripts/api-list-projects-branches.output.md deleted file mode 100644 index 1c12eea541..0000000000 --- a/unison-src/transcripts/api-list-projects-branches.output.md +++ /dev/null @@ -1,53 +0,0 @@ -# List Projects And Branches Test - -```api --- Should list all projects -GET /api/projects -[ - { - "projectName": "project-one" - }, - { - "projectName": "project-three" - }, - { - "projectName": "project-two" - } -] --- Should list projects starting with project-t -GET /api/projects?prefix=project-t -[ - { - "projectName": "project-three" - }, - { - "projectName": "project-two" - } -] --- Should list all branches -GET /api/projects/project-one/branches -[ - { - "branchName": "branch-one" - }, - { - "branchName": "branch-three" - }, - { - "branchName": "branch-two" - }, - { - "branchName": "main" - } -] --- Should list all branches beginning with branch-t -GET /api/projects/project-one/branches?prefix=branch-t -[ - { - "branchName": "branch-three" - }, - { - "branchName": "branch-two" - } -] -``` \ No newline at end of file diff --git a/unison-src/transcripts/api-namespace-details.md b/unison-src/transcripts/api-namespace-details.md deleted file mode 100644 index 0cfc7a8353..0000000000 --- a/unison-src/transcripts/api-namespace-details.md +++ /dev/null @@ -1,23 +0,0 @@ -# Namespace Details Test - -```ucm:hide -.> builtins.mergeio -``` - -```unison -{{ Documentation }} -nested.names.x = 42 - -nested.names.readme = {{ -Here's a *README*! -}} -``` - -```ucm -.> add -``` - -```api --- Should find names by suffix -GET /api/non-project-code/namespaces/nested.names -``` diff --git a/unison-src/transcripts/api-namespace-details.output.md b/unison-src/transcripts/api-namespace-details.output.md deleted file mode 100644 index 80d1d6ae0c..0000000000 --- a/unison-src/transcripts/api-namespace-details.output.md +++ /dev/null @@ -1,81 +0,0 @@ -# Namespace Details Test - -```unison -{{ Documentation }} -nested.names.x = 42 - -nested.names.readme = {{ -Here's a *README*! -}} -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - nested.names.readme : Doc2 - nested.names.x : Nat - nested.names.x.doc : Doc2 - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - nested.names.readme : Doc2 - nested.names.x : Nat - nested.names.x.doc : Doc2 - -``` -```api --- Should find names by suffix -GET /api/non-project-code/namespaces/nested.names -{ - "fqn": "nested.names", - "hash": "#6tnmlu9knsce0u2991u6fvcmf4v44fdf0aiqtmnq7mjj0gi5sephg3lf12iv3odr5rc7vlgq75ciborrd3625c701bdmdomia2gcm3o", - "readme": { - "contents": [ - { - "contents": "Here's", - "tag": "Word" - }, - { - "contents": "a", - "tag": "Word" - }, - { - "contents": { - "contents": [ - { - "contents": { - "contents": [ - { - "contents": "README", - "tag": "Word" - } - ], - "tag": "Paragraph" - }, - "tag": "Bold" - }, - { - "contents": "!", - "tag": "Word" - } - ], - "tag": "Join" - }, - "tag": "Group" - } - ], - "tag": "Paragraph" - } -} -``` \ No newline at end of file diff --git a/unison-src/transcripts/api-namespace-list.md b/unison-src/transcripts/api-namespace-list.md deleted file mode 100644 index 717607269a..0000000000 --- a/unison-src/transcripts/api-namespace-list.md +++ /dev/null @@ -1,22 +0,0 @@ -# Namespace list api - -```ucm:hide -.> builtins.mergeio -``` - -```unison -{{ Documentation }} -nested.names.x = 42 - -nested.names.readme = {{ I'm a readme! }} -``` - -```ucm -.> add -``` - -```api -GET /api/non-project-code/list?namespace=nested.names - -GET /api/non-project-code/list?namespace=names&relativeTo=nested -``` diff --git a/unison-src/transcripts/api-namespace-list.output.md b/unison-src/transcripts/api-namespace-list.output.md deleted file mode 100644 index 0ef32d1941..0000000000 --- a/unison-src/transcripts/api-namespace-list.output.md +++ /dev/null @@ -1,134 +0,0 @@ -# Namespace list api - -```unison -{{ Documentation }} -nested.names.x = 42 - -nested.names.readme = {{ I'm a readme! }} -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - nested.names.readme : Doc2 - nested.names.x : Nat - nested.names.x.doc : Doc2 - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - nested.names.readme : Doc2 - nested.names.x : Nat - nested.names.x.doc : Doc2 - -``` -```api -GET /api/non-project-code/list?namespace=nested.names -{ - "namespaceListingChildren": [ - { - "contents": { - "termHash": "#ddmmatmmiqsts2ku0i02kntd0s7rvcui4nn1cusio8thp9oqhbtilvcnhen52ibv43kr5q83f5er5q9h56s807k17tnelnrac7cch8o", - "termName": "readme", - "termTag": "Doc", - "termType": [ - { - "annotation": { - "contents": "#ej86si0ur1", - "tag": "HashQualifier" - }, - "segment": "#ej86si0ur1" - } - ] - }, - "tag": "TermObject" - }, - { - "contents": { - "termHash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", - "termName": "x", - "termTag": "Plain", - "termType": [ - { - "annotation": { - "contents": "##Nat", - "tag": "HashQualifier" - }, - "segment": "##Nat" - } - ] - }, - "tag": "TermObject" - }, - { - "contents": { - "namespaceHash": "#n1egracfeljprftoktbjcase2hs4f4p8idbhs5ujipl42agld1810hrq9t7p7ped16aagni2cm1fjcjhho770jh80ipthhmg0cnsur0", - "namespaceName": "x", - "namespaceSize": 1 - }, - "tag": "Subnamespace" - } - ], - "namespaceListingFQN": "nested.names", - "namespaceListingHash": "#oms19b4f9s3c8tb5skeb8jii95ij35n3hdg038pu6rv5b0fikqe4gd7lnu6a1i6aq5tdh2opdo4s0sfrupvk6vfkr9lf0n752gbl8o0" -} -GET /api/non-project-code/list?namespace=names&relativeTo=nested -{ - "namespaceListingChildren": [ - { - "contents": { - "termHash": "#ddmmatmmiqsts2ku0i02kntd0s7rvcui4nn1cusio8thp9oqhbtilvcnhen52ibv43kr5q83f5er5q9h56s807k17tnelnrac7cch8o", - "termName": "readme", - "termTag": "Doc", - "termType": [ - { - "annotation": { - "contents": "#ej86si0ur1", - "tag": "HashQualifier" - }, - "segment": "#ej86si0ur1" - } - ] - }, - "tag": "TermObject" - }, - { - "contents": { - "termHash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", - "termName": "x", - "termTag": "Plain", - "termType": [ - { - "annotation": { - "contents": "##Nat", - "tag": "HashQualifier" - }, - "segment": "##Nat" - } - ] - }, - "tag": "TermObject" - }, - { - "contents": { - "namespaceHash": "#n1egracfeljprftoktbjcase2hs4f4p8idbhs5ujipl42agld1810hrq9t7p7ped16aagni2cm1fjcjhho770jh80ipthhmg0cnsur0", - "namespaceName": "x", - "namespaceSize": 1 - }, - "tag": "Subnamespace" - } - ], - "namespaceListingFQN": "nested.names", - "namespaceListingHash": "#oms19b4f9s3c8tb5skeb8jii95ij35n3hdg038pu6rv5b0fikqe4gd7lnu6a1i6aq5tdh2opdo4s0sfrupvk6vfkr9lf0n752gbl8o0" -} -``` \ No newline at end of file diff --git a/unison-src/transcripts/api-summaries.md b/unison-src/transcripts/api-summaries.md deleted file mode 100644 index cf473e778a..0000000000 --- a/unison-src/transcripts/api-summaries.md +++ /dev/null @@ -1,80 +0,0 @@ -# Definition Summary APIs - -```ucm:hide -.> builtins.mergeio -``` - - -```unison:hide -nat : Nat -nat = 42 -doc : Doc2 -doc = {{ Hello }} -test> mytest = [Test.Result.Ok "ok"] -func : Text -> Text -func x = x ++ "hello" - -funcWithLongType : Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -funcWithLongType a b c d e f g h = a ++ b ++ c ++ d ++ e ++ f ++ g ++ h - -structural type Thing = This Nat | That -structural type Maybe a = Nothing | Just a - -structural ability Stream s where - send : s -> () -``` - -```ucm:hide -.> add -.> alias.type ##Nat Nat -.> alias.term ##IO.putBytes.impl.v3 putBytesImpl -``` - -## Term Summary APIs - -```api --- term -GET /api/non-project-code/definitions/terms/by-hash/@qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8/summary?name=nat - --- term without name uses hash -GET /api/non-project-code/definitions/terms/by-hash/@qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8/summary - --- doc -GET /api/non-project-code/definitions/terms/by-hash/@icfnhas71n8q5rm7rmpe51hh7bltsr7rb4lv7qadc4cbsifu1mhonlqj2d7836iar2ptc648q9p4u7hf40ijvld574421b6u8gpu0lo/summary?name=doc - --- test -GET /api/non-project-code/definitions/terms/by-hash/@u17p9803hdibisou6rlr1sjbccdossgh7vtkd03ovlvnsl2n91lq94sqhughc62tnrual2jlrfk922sebp4nm22o7m5u9j40emft8r8/summary?name=mytest - --- function -GET /api/non-project-code/definitions/terms/by-hash/@6ee6j48hk3eovokflkgbmpbfr3oqj4hedqn8ocg3i4i0ko8j7nls7njjirmnh4k2bg8h95seaot798uuloqk62u2ttiqoceulkbmq2o/summary?name=func - --- constructor -GET /api/non-project-code/definitions/terms/by-hash/@altimqs66j3dh94dpab5pg7j5adjrndq61n803j7fg0v0ohdiut6or66bu1fiongpd45s5euiuo8ru47b928aqv8osln1ikdeg05hq0@d0/summary?name=Thing.This - --- Long type signature -GET /api/non-project-code/definitions/terms/by-hash/@ieskgcjjvuegpecq9pbha59ttonke7pf31keeq0jlh31ijkfq00e06fdi36ae90u24pjva6ucqdbedropjgi3g3b75nu76ll5ls8ke8/summary?name=funcWithLongType - --- Long type signature with render width -GET /api/non-project-code/definitions/terms/by-hash/@ieskgcjjvuegpecq9pbha59ttonke7pf31keeq0jlh31ijkfq00e06fdi36ae90u24pjva6ucqdbedropjgi3g3b75nu76ll5ls8ke8/summary?renderWidth=20&name=funcWithLongType - --- Builtin Term -GET /api/non-project-code/definitions/terms/by-hash/@@IO.putBytes.impl.v3/summary?name=putBytesImpl -``` - -## Type Summary APIs - -```api --- data -GET /api/non-project-code/definitions/types/by-hash/@altimqs66j3dh94dpab5pg7j5adjrndq61n803j7fg0v0ohdiut6or66bu1fiongpd45s5euiuo8ru47b928aqv8osln1ikdeg05hq0/summary?name=Thing - --- data with type args -GET /api/non-project-code/definitions/types/by-hash/@nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg/summary?name=Maybe - --- ability -GET /api/non-project-code/definitions/types/by-hash/@rfi1v9429f9qluv533l2iba77aadttilrpmnhljfapfnfa6sru2nr8ibpqvib9nc4s4nb9s1as45upsfqfqe6ivqi2p82b2vd866it8/summary?name=Stream - --- builtin type -GET /api/non-project-code/definitions/types/by-hash/@@Nat/summary?name=Nat -``` - - diff --git a/unison-src/transcripts/api-summaries.output.md b/unison-src/transcripts/api-summaries.output.md deleted file mode 100644 index cc5a9fcea3..0000000000 --- a/unison-src/transcripts/api-summaries.output.md +++ /dev/null @@ -1,826 +0,0 @@ -# Definition Summary APIs - -```unison -nat : Nat -nat = 42 -doc : Doc2 -doc = {{ Hello }} -test> mytest = [Test.Result.Ok "ok"] -func : Text -> Text -func x = x ++ "hello" - -funcWithLongType : Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -funcWithLongType a b c d e f g h = a ++ b ++ c ++ d ++ e ++ f ++ g ++ h - -structural type Thing = This Nat | That -structural type Maybe a = Nothing | Just a - -structural ability Stream s where - send : s -> () -``` - -## Term Summary APIs - -```api --- term -GET /api/non-project-code/definitions/terms/by-hash/@qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8/summary?name=nat -{ - "displayName": "nat", - "hash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", - "summary": { - "contents": [ - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - } - ], - "tag": "UserObject" - }, - "tag": "Plain" -} --- term without name uses hash -GET /api/non-project-code/definitions/terms/by-hash/@qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8/summary -{ - "displayName": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", - "hash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", - "summary": { - "contents": [ - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - } - ], - "tag": "UserObject" - }, - "tag": "Plain" -} --- doc -GET /api/non-project-code/definitions/terms/by-hash/@icfnhas71n8q5rm7rmpe51hh7bltsr7rb4lv7qadc4cbsifu1mhonlqj2d7836iar2ptc648q9p4u7hf40ijvld574421b6u8gpu0lo/summary?name=doc -{ - "displayName": "doc", - "hash": "#icfnhas71n8q5rm7rmpe51hh7bltsr7rb4lv7qadc4cbsifu1mhonlqj2d7836iar2ptc648q9p4u7hf40ijvld574421b6u8gpu0lo", - "summary": { - "contents": [ - { - "annotation": { - "contents": "#ej86si0ur1lsjade71dojr25phk9bbom9rdks6dltolos5tjivakujcriqe02npba53n9gd7tkh8bmv08ttjb9t35lq2ch5heshqcs0", - "tag": "TypeReference" - }, - "segment": "Doc2" - } - ], - "tag": "UserObject" - }, - "tag": "Doc" -} --- test -GET /api/non-project-code/definitions/terms/by-hash/@u17p9803hdibisou6rlr1sjbccdossgh7vtkd03ovlvnsl2n91lq94sqhughc62tnrual2jlrfk922sebp4nm22o7m5u9j40emft8r8/summary?name=mytest -{ - "displayName": "mytest", - "hash": "#u17p9803hdibisou6rlr1sjbccdossgh7vtkd03ovlvnsl2n91lq94sqhughc62tnrual2jlrfk922sebp4nm22o7m5u9j40emft8r8", - "summary": { - "contents": [ - { - "annotation": { - "tag": "DelimiterChar" - }, - "segment": "[" - }, - { - "annotation": { - "contents": "#aql7qk3iud6vs4cvu43aimopoosgk0fnipibdkc3so13adencmibgfn0u5c01r0adei55nkl3ttsjhl8gbj7tr4gnpj63g64ftbq6s0", - "tag": "TypeReference" - }, - "segment": "Result" - }, - { - "annotation": { - "tag": "DelimiterChar" - }, - "segment": "]" - } - ], - "tag": "UserObject" - }, - "tag": "Test" -} --- function -GET /api/non-project-code/definitions/terms/by-hash/@6ee6j48hk3eovokflkgbmpbfr3oqj4hedqn8ocg3i4i0ko8j7nls7njjirmnh4k2bg8h95seaot798uuloqk62u2ttiqoceulkbmq2o/summary?name=func -{ - "displayName": "func", - "hash": "#6ee6j48hk3eovokflkgbmpbfr3oqj4hedqn8ocg3i4i0ko8j7nls7njjirmnh4k2bg8h95seaot798uuloqk62u2ttiqoceulkbmq2o", - "summary": { - "contents": [ - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - } - ], - "tag": "UserObject" - }, - "tag": "Plain" -} --- constructor -GET /api/non-project-code/definitions/terms/by-hash/@altimqs66j3dh94dpab5pg7j5adjrndq61n803j7fg0v0ohdiut6or66bu1fiongpd45s5euiuo8ru47b928aqv8osln1ikdeg05hq0@d0/summary?name=Thing.This -{ - "displayName": "Thing.This", - "hash": "#altimqs66j3dh94dpab5pg7j5adjrndq61n803j7fg0v0ohdiut6or66bu1fiongpd45s5euiuo8ru47b928aqv8osln1ikdeg05hq0#0", - "summary": { - "contents": [ - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "#altimqs66j3dh94dpab5pg7j5adjrndq61n803j7fg0v0ohdiut6or66bu1fiongpd45s5euiuo8ru47b928aqv8osln1ikdeg05hq0", - "tag": "TypeReference" - }, - "segment": "Thing" - } - ], - "tag": "UserObject" - }, - "tag": "DataConstructor" -} --- Long type signature -GET /api/non-project-code/definitions/terms/by-hash/@ieskgcjjvuegpecq9pbha59ttonke7pf31keeq0jlh31ijkfq00e06fdi36ae90u24pjva6ucqdbedropjgi3g3b75nu76ll5ls8ke8/summary?name=funcWithLongType -{ - "displayName": "funcWithLongType", - "hash": "#ieskgcjjvuegpecq9pbha59ttonke7pf31keeq0jlh31ijkfq00e06fdi36ae90u24pjva6ucqdbedropjgi3g3b75nu76ll5ls8ke8", - "summary": { - "contents": [ - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - } - ], - "tag": "UserObject" - }, - "tag": "Plain" -} --- Long type signature with render width -GET /api/non-project-code/definitions/terms/by-hash/@ieskgcjjvuegpecq9pbha59ttonke7pf31keeq0jlh31ijkfq00e06fdi36ae90u24pjva6ucqdbedropjgi3g3b75nu76ll5ls8ke8/summary?renderWidth=20&name=funcWithLongType -{ - "displayName": "funcWithLongType", - "hash": "#ieskgcjjvuegpecq9pbha59ttonke7pf31keeq0jlh31ijkfq00e06fdi36ae90u24pjva6ucqdbedropjgi3g3b75nu76ll5ls8ke8", - "summary": { - "contents": [ - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - } - ], - "tag": "UserObject" - }, - "tag": "Plain" -} --- Builtin Term -GET /api/non-project-code/definitions/terms/by-hash/@@IO.putBytes.impl.v3/summary?name=putBytesImpl -{ - "displayName": "putBytesImpl", - "hash": "##IO.putBytes.impl.v3", - "summary": { - "contents": [ - { - "annotation": { - "contents": "##Handle", - "tag": "TypeReference" - }, - "segment": "Handle" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Bytes", - "tag": "TypeReference" - }, - "segment": "Bytes" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TypeOperator" - }, - "segment": "->" - }, - { - "annotation": { - "tag": "AbilityBraces" - }, - "segment": "{" - }, - { - "annotation": { - "contents": "##IO", - "tag": "TypeReference" - }, - "segment": "IO" - }, - { - "annotation": { - "tag": "AbilityBraces" - }, - "segment": "}" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "#0o7mf021foma9acqdaibmlh1jidlijq08uf7f5se9tssttqs546pfunjpk6s31mqoq8s2o1natede8hkk6he45l95fibglidikt44v8", - "tag": "TypeReference" - }, - "segment": "Either" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "#r29dja8j9dmjjp45trccchaata8eo1h6d6haar1eai74pq1jt4m7u3ldhlq79f7phfo57eq4bau39vqotl2h63k7ff1m5sj5o9ajuf8", - "tag": "TypeReference" - }, - "segment": "Failure" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": null, - "segment": "(" - }, - { - "annotation": null, - "segment": ")" - } - ], - "tag": "BuiltinObject" - }, - "tag": "Plain" -} -```## Type Summary APIs - -```api --- data -GET /api/non-project-code/definitions/types/by-hash/@altimqs66j3dh94dpab5pg7j5adjrndq61n803j7fg0v0ohdiut6or66bu1fiongpd45s5euiuo8ru47b928aqv8osln1ikdeg05hq0/summary?name=Thing -{ - "displayName": "Thing", - "hash": "#altimqs66j3dh94dpab5pg7j5adjrndq61n803j7fg0v0ohdiut6or66bu1fiongpd45s5euiuo8ru47b928aqv8osln1ikdeg05hq0", - "summary": { - "contents": [ - { - "annotation": { - "tag": "DataTypeModifier" - }, - "segment": "structural" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "DataTypeKeyword" - }, - "segment": "type" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "Thing", - "tag": "HashQualifier" - }, - "segment": "Thing" - } - ], - "tag": "UserObject" - }, - "tag": "Data" -} --- data with type args -GET /api/non-project-code/definitions/types/by-hash/@nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg/summary?name=Maybe -{ - "displayName": "Maybe", - "hash": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg", - "summary": { - "contents": [ - { - "annotation": { - "tag": "DataTypeModifier" - }, - "segment": "structural" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "DataTypeKeyword" - }, - "segment": "type" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "Maybe", - "tag": "HashQualifier" - }, - "segment": "Maybe" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "DataTypeParams" - }, - "segment": "a" - } - ], - "tag": "UserObject" - }, - "tag": "Data" -} --- ability -GET /api/non-project-code/definitions/types/by-hash/@rfi1v9429f9qluv533l2iba77aadttilrpmnhljfapfnfa6sru2nr8ibpqvib9nc4s4nb9s1as45upsfqfqe6ivqi2p82b2vd866it8/summary?name=Stream -{ - "displayName": "Stream", - "hash": "#rfi1v9429f9qluv533l2iba77aadttilrpmnhljfapfnfa6sru2nr8ibpqvib9nc4s4nb9s1as45upsfqfqe6ivqi2p82b2vd866it8", - "summary": { - "contents": [ - { - "annotation": { - "tag": "DataTypeModifier" - }, - "segment": "structural" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "DataTypeKeyword" - }, - "segment": "ability" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "Stream", - "tag": "HashQualifier" - }, - "segment": "Stream" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "DataTypeParams" - }, - "segment": "s" - } - ], - "tag": "UserObject" - }, - "tag": "Ability" -} --- builtin type -GET /api/non-project-code/definitions/types/by-hash/@@Nat/summary?name=Nat -{ - "displayName": "Nat", - "hash": "##Nat", - "summary": { - "contents": [ - { - "annotation": null, - "segment": "Nat" - } - ], - "tag": "BuiltinObject" - }, - "tag": "Data" -} -``` \ No newline at end of file diff --git a/unison-src/transcripts/block-on-required-update.md b/unison-src/transcripts/block-on-required-update.md deleted file mode 100644 index 1027188b06..0000000000 --- a/unison-src/transcripts/block-on-required-update.md +++ /dev/null @@ -1,28 +0,0 @@ -# Block on required update - -Should block an `add` if it requires an update on an in-file dependency. - -```ucm:hide -.> builtins.merge -``` - -```unison -x = 1 -``` - -```ucm -.> add -``` - -Update `x`, and add a new `y` which depends on the update - -```unison -x = 10 -y = x + 1 -``` - -Try to add only the new `y`. This should fail because it requires an update to `x`, but we only ran an 'add'. - -```ucm:error -.> add y -``` diff --git a/unison-src/transcripts/block-on-required-update.output.md b/unison-src/transcripts/block-on-required-update.output.md deleted file mode 100644 index 254a281e87..0000000000 --- a/unison-src/transcripts/block-on-required-update.output.md +++ /dev/null @@ -1,68 +0,0 @@ -# Block on required update - -Should block an `add` if it requires an update on an in-file dependency. - -```unison -x = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - x : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - x : Nat - -``` -Update `x`, and add a new `y` which depends on the update - -```unison -x = 10 -y = x + 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - y : Nat - - ⍟ These names already exist. You can `update` them to your - new definition: - - x : Nat - -``` -Try to add only the new `y`. This should fail because it requires an update to `x`, but we only ran an 'add'. - -```ucm -.> add y - - x These definitions failed: - - Reason - needs update x : Nat - blocked y : Nat - - Tip: Use `help filestatus` to learn more. - -``` diff --git a/unison-src/transcripts/blocks.md b/unison-src/transcripts/blocks.md deleted file mode 100644 index bac7ef1874..0000000000 --- a/unison-src/transcripts/blocks.md +++ /dev/null @@ -1,177 +0,0 @@ -## Blocks and scoping - -```ucm:hide -.> builtins.merge -``` - -### Names introduced by a block shadow names introduced in outer scopes - -For example: - -```unison -ex thing = - thing y = y - -- refers to `thing` in this block - -- not the argument to `ex` - bar x = thing x + 1 - bar 42 - -> ex "hello" -``` - -### Whether a block shadows outer names doesn't depend on the order of bindings in the block - -The `thing` reference in `bar` refers to the one declared locally in the block that `bar` is part of. This is true even if the declaration which shadows the outer name appears later in the block, for instance: - -```unison -ex thing = - bar x = thing x + 1 - thing y = y - bar 42 - -> ex "hello" -``` - -### Blocks use lexical scoping and can only reference definitions in parent scopes or in the same block - -This is just the normal lexical scoping behavior. For example: - -```unison -ex thing = - bar x = thing x + 1 -- references outer `thing` - baz z = - thing y = y -- shadows the outer `thing` - thing z -- references the inner `thing` - bar 42 - -> ex (x -> x * 100) -``` - -Here's another example, showing that bindings cannot reference bindings declared in blocks nested in the _body_ (the final expression) of a block: - -```unison -ex thing = - bar x = thing x + 1 -- refers to outer thing - let - thing y = y - bar 42 - -> ex (x -> x * 100) -``` - -### Blocks can define one or more functions which are recursive or mutually recursive - -We call these groups of definitions that reference each other in a block _cycles_. For instance: - -```unison -sumTo n = - -- A recursive function, defined inside a block - go acc n = - if n == 0 then acc - else go (acc + n) (drop n 1) - go 0 n - -ex n = - -- Two mutually recursive functions, defined in a block - ping x = pong (x + 1) - pong x = ping (x + 2) - ping 42 -``` - -The `go` function is a one-element cycle (it reference itself), and `ping` and `pong` form a two-element cycle. - -### Cyclic references or forward reference must be guarded - -For instance, this works: - -```unison -ex n = - ping x = pong + 1 + x - pong = 42 - ping 0 -``` - -Since the forward reference to `pong` appears inside `ping`. - -This, however, will not compile: - -```unison:error -ex n = - pong = ping + 1 - ping = 42 - pong -``` - -This also won't compile; it's a cyclic reference that isn't guarded: - -```unison:error -ex n = - loop = loop - loop -``` - -This, however, will compile. This also shows that `'expr` is another way of guarding a definition. - -```unison -ex n = - loop = '(!loop) - !loop -``` - -Just don't try to run it as it's an infinite loop! - -### Cyclic definitions in a block don't have access to any abilities - -The reason is it's unclear what the order should be of any requests that are made. It can also be viewed of a special case of the restriction that elements of a cycle must all be guarded. Here's an example: - -```unison:error -structural ability SpaceAttack where - launchMissiles : Text -> Nat - -ex n = - zap1 = launchMissiles "neptune" + zap2 - zap2 = launchMissiles "pluto" + zap1 - zap1 -``` - -### The _body_ of recursive functions can certainly access abilities - -For instance, this works fine: - -```unison -structural ability SpaceAttack where - launchMissiles : Text -> Nat - -ex n = - zap1 planet = launchMissiles planet + zap2 planet - zap2 planet = launchMissiles planet + zap1 planet - zap1 "pluto" -``` - -### Unrelated definitions not part of a cycle and are moved after the cycle - -For instance, `zap` here isn't considered part of the cycle (it doesn't reference `ping` or `pong`), so this typechecks fine: - -```unison -structural ability SpaceAttack where - launchMissiles : Text -> Nat - -ex n = - ping x = pong (x + 1) - zap = launchMissiles "neptune" - pong x = ping (x + 2) - ping 42 -``` - -This is actually parsed as if you moved `zap` after the cycle it find itself a part of: - -```unison -structural ability SpaceAttack where - launchMissiles : Text -> Nat - -ex n = - ping x = pong (x + 1) - pong x = ping (x + 2) - zap = launchMissiles "neptune" - ping 42 -``` diff --git a/unison-src/transcripts/blocks.output.md b/unison-src/transcripts/blocks.output.md deleted file mode 100644 index 687ca98067..0000000000 --- a/unison-src/transcripts/blocks.output.md +++ /dev/null @@ -1,365 +0,0 @@ -## Blocks and scoping - -### Names introduced by a block shadow names introduced in outer scopes - -For example: - -```unison -ex thing = - thing y = y - -- refers to `thing` in this block - -- not the argument to `ex` - bar x = thing x + 1 - bar 42 - -> ex "hello" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex : thing -> Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 8 | > ex "hello" - ⧩ - 43 - -``` -### Whether a block shadows outer names doesn't depend on the order of bindings in the block - -The `thing` reference in `bar` refers to the one declared locally in the block that `bar` is part of. This is true even if the declaration which shadows the outer name appears later in the block, for instance: - -```unison -ex thing = - bar x = thing x + 1 - thing y = y - bar 42 - -> ex "hello" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex : thing -> Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 6 | > ex "hello" - ⧩ - 43 - -``` -### Blocks use lexical scoping and can only reference definitions in parent scopes or in the same block - -This is just the normal lexical scoping behavior. For example: - -```unison -ex thing = - bar x = thing x + 1 -- references outer `thing` - baz z = - thing y = y -- shadows the outer `thing` - thing z -- references the inner `thing` - bar 42 - -> ex (x -> x * 100) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex : (Nat ->{g} Nat) ->{g} Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 8 | > ex (x -> x * 100) - ⧩ - 4201 - -``` -Here's another example, showing that bindings cannot reference bindings declared in blocks nested in the _body_ (the final expression) of a block: - -```unison -ex thing = - bar x = thing x + 1 -- refers to outer thing - let - thing y = y - bar 42 - -> ex (x -> x * 100) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex : (Nat ->{g} Nat) ->{g} Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 7 | > ex (x -> x * 100) - ⧩ - 4201 - -``` -### Blocks can define one or more functions which are recursive or mutually recursive - -We call these groups of definitions that reference each other in a block _cycles_. For instance: - -```unison -sumTo n = - -- A recursive function, defined inside a block - go acc n = - if n == 0 then acc - else go (acc + n) (drop n 1) - go 0 n - -ex n = - -- Two mutually recursive functions, defined in a block - ping x = pong (x + 1) - pong x = ping (x + 2) - ping 42 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex : n -> r - sumTo : Nat -> Nat - -``` -The `go` function is a one-element cycle (it reference itself), and `ping` and `pong` form a two-element cycle. - -### Cyclic references or forward reference must be guarded - -For instance, this works: - -```unison -ex n = - ping x = pong + 1 + x - pong = 42 - ping 0 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex : n -> Nat - -``` -Since the forward reference to `pong` appears inside `ping`. - -This, however, will not compile: - -```unison -ex n = - pong = ping + 1 - ping = 42 - pong -``` - -```ucm - - Loading changes detected in scratch.u. - - These definitions depend on each other cyclically but aren't guarded by a lambda: pong8 - 2 | pong = ping + 1 - 3 | ping = 42 - - -``` -This also won't compile; it's a cyclic reference that isn't guarded: - -```unison -ex n = - loop = loop - loop -``` - -```ucm - - Loading changes detected in scratch.u. - - These definitions depend on each other cyclically but aren't guarded by a lambda: loop8 - 2 | loop = loop - - -``` -This, however, will compile. This also shows that `'expr` is another way of guarding a definition. - -```unison -ex n = - loop = '(!loop) - !loop -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex : n -> r - -``` -Just don't try to run it as it's an infinite loop! - -### Cyclic definitions in a block don't have access to any abilities - -The reason is it's unclear what the order should be of any requests that are made. It can also be viewed of a special case of the restriction that elements of a cycle must all be guarded. Here's an example: - -```unison -structural ability SpaceAttack where - launchMissiles : Text -> Nat - -ex n = - zap1 = launchMissiles "neptune" + zap2 - zap2 = launchMissiles "pluto" + zap1 - zap1 -``` - -```ucm - - Loading changes detected in scratch.u. - - The expression in red needs the {SpaceAttack} ability, but this location does not have access to any abilities. - - 5 | zap1 = launchMissiles "neptune" + zap2 - - -``` -### The _body_ of recursive functions can certainly access abilities - -For instance, this works fine: - -```unison -structural ability SpaceAttack where - launchMissiles : Text -> Nat - -ex n = - zap1 planet = launchMissiles planet + zap2 planet - zap2 planet = launchMissiles planet + zap1 planet - zap1 "pluto" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability SpaceAttack - ex : n ->{SpaceAttack} Nat - -``` -### Unrelated definitions not part of a cycle and are moved after the cycle - -For instance, `zap` here isn't considered part of the cycle (it doesn't reference `ping` or `pong`), so this typechecks fine: - -```unison -structural ability SpaceAttack where - launchMissiles : Text -> Nat - -ex n = - ping x = pong (x + 1) - zap = launchMissiles "neptune" - pong x = ping (x + 2) - ping 42 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability SpaceAttack - ex : n ->{SpaceAttack} r - -``` -This is actually parsed as if you moved `zap` after the cycle it find itself a part of: - -```unison -structural ability SpaceAttack where - launchMissiles : Text -> Nat - -ex n = - ping x = pong (x + 1) - pong x = ping (x + 2) - zap = launchMissiles "neptune" - ping 42 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability SpaceAttack - ex : n ->{SpaceAttack} r - -``` diff --git a/unison-src/transcripts/boolean-op-pretty-print-2819.md b/unison-src/transcripts/boolean-op-pretty-print-2819.md deleted file mode 100644 index efdf493e9f..0000000000 --- a/unison-src/transcripts/boolean-op-pretty-print-2819.md +++ /dev/null @@ -1,18 +0,0 @@ -Regression test for https://github.com/unisonweb/unison/pull/2819 - -```ucm:hide -.> builtins.merge -``` - -```unison -hangExample : Boolean -hangExample = - ("a long piece of text to hang the line" == "") - && ("a long piece of text to hang the line" == "") -``` - -```ucm -.> add -.> view hangExample -``` - diff --git a/unison-src/transcripts/boolean-op-pretty-print-2819.output.md b/unison-src/transcripts/boolean-op-pretty-print-2819.output.md deleted file mode 100644 index 690b9fdc6b..0000000000 --- a/unison-src/transcripts/boolean-op-pretty-print-2819.output.md +++ /dev/null @@ -1,37 +0,0 @@ -Regression test for https://github.com/unisonweb/unison/pull/2819 - -```unison -hangExample : Boolean -hangExample = - ("a long piece of text to hang the line" == "") - && ("a long piece of text to hang the line" == "") -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - hangExample : Boolean - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - hangExample : Boolean - -.> view hangExample - - hangExample : Boolean - hangExample = - ("a long piece of text to hang the line" == "") - && ("a long piece of text to hang the line" == "") - -``` diff --git a/unison-src/transcripts/branch-command.md b/unison-src/transcripts/branch-command.md deleted file mode 100644 index 4b1636be41..0000000000 --- a/unison-src/transcripts/branch-command.md +++ /dev/null @@ -1,66 +0,0 @@ -The `branch` command creates a new branch. - -```ucm:hide -.> project.create-empty foo -.> project.create-empty bar -``` - -First, we'll just create a loose code namespace with a term in it for later. - -```unison:hide -someterm = 18 -``` - -```ucm -.some.loose.code.lib> builtins.merge -.some.loose.code> add -``` - -Now, the `branch` demo: - -`branch` can create a branch from a different branch in the same project, from a different branch in a different -project, or from loose code. It can also create an empty branch. - -```ucm -foo/main> branch topic1 -foo/main> branch /topic2 -foo/main> branch foo/topic3 -foo/main> branch main topic4 -foo/main> branch main /topic5 -foo/main> branch main foo/topic6 -foo/main> branch /main topic7 -foo/main> branch /main /topic8 -foo/main> branch /main foo/topic9 -foo/main> branch foo/main topic10 -foo/main> branch foo/main /topic11 -.> branch foo/main foo/topic12 - -foo/main> branch bar/topic -bar/main> branch foo/main topic2 -bar/main> branch foo/main /topic3 -.> branch foo/main bar/topic4 - -.some.loose.code> branch foo/topic13 -foo/main> branch .some.loose.code topic14 -foo/main> branch .some.loose.code /topic15 -.> branch .some.loose.code foo/topic16 - -foo/main> branch.empty empty1 -foo/main> branch.empty /empty2 -foo/main> branch.empty foo/empty3 -.> branch.empty foo/empty4 -``` - -The `branch` command can create branches named `releases/drafts/*` (because why not). - -```ucm -foo/main> branch releases/drafts/1.2.3 -foo/main> switch /releases/drafts/1.2.3 -``` - -The `branch` command can't create branches named `releases/*` nor `releases/drafts/*`. - -```ucm:error -foo/main> branch releases/1.2.3 -foo/main> switch /releases/1.2.3 -``` diff --git a/unison-src/transcripts/branch-command.output.md b/unison-src/transcripts/branch-command.output.md deleted file mode 100644 index c074134bbb..0000000000 --- a/unison-src/transcripts/branch-command.output.md +++ /dev/null @@ -1,204 +0,0 @@ -The `branch` command creates a new branch. - -First, we'll just create a loose code namespace with a term in it for later. - -```unison -someterm = 18 -``` - -```ucm - ☝️ The namespace .some.loose.code.lib is empty. - -.some.loose.code.lib> builtins.merge - - Done. - -.some.loose.code> add - - ⍟ I've added these definitions: - - someterm : Nat - -``` -Now, the `branch` demo: - -`branch` can create a branch from a different branch in the same project, from a different branch in a different -project, or from loose code. It can also create an empty branch. - -```ucm -foo/main> branch topic1 - - Done. I've created the topic1 branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic1`. - -foo/main> branch /topic2 - - Done. I've created the topic2 branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic2`. - -foo/main> branch foo/topic3 - - Done. I've created the topic3 branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic3`. - -foo/main> branch main topic4 - - Done. I've created the topic4 branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic4`. - -foo/main> branch main /topic5 - - Done. I've created the topic5 branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic5`. - -foo/main> branch main foo/topic6 - - Done. I've created the topic6 branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic6`. - -foo/main> branch /main topic7 - - Done. I've created the topic7 branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic7`. - -foo/main> branch /main /topic8 - - Done. I've created the topic8 branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic8`. - -foo/main> branch /main foo/topic9 - - Done. I've created the topic9 branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic9`. - -foo/main> branch foo/main topic10 - - Done. I've created the topic10 branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic10`. - -foo/main> branch foo/main /topic11 - - Done. I've created the topic11 branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic11`. - -.> branch foo/main foo/topic12 - - Done. I've created the topic12 branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic12`. - -foo/main> branch bar/topic - - Done. I've created the bar/topic branch based off foo/main. - -bar/main> branch foo/main topic2 - - Done. I've created the bar/topic2 branch based off foo/main. - -bar/main> branch foo/main /topic3 - - Done. I've created the bar/topic3 branch based off foo/main. - -.> branch foo/main bar/topic4 - - Done. I've created the bar/topic4 branch based off foo/main. - -.some.loose.code> branch foo/topic13 - - Done. I've created the foo/topic13 branch from the namespace - .some.loose.code. - -foo/main> branch .some.loose.code topic14 - - Done. I've created the foo/topic14 branch from the namespace - .some.loose.code. - -foo/main> branch .some.loose.code /topic15 - - Done. I've created the foo/topic15 branch from the namespace - .some.loose.code. - -.> branch .some.loose.code foo/topic16 - - Done. I've created the foo/topic16 branch from the namespace - .some.loose.code. - -foo/main> branch.empty empty1 - - Done. I've created an empty branch foo/empty1. - - Tip: Use `merge /somebranch` to initialize this branch. - -foo/main> branch.empty /empty2 - - Done. I've created an empty branch foo/empty2. - - Tip: Use `merge /somebranch` to initialize this branch. - -foo/main> branch.empty foo/empty3 - - Done. I've created an empty branch foo/empty3. - - Tip: Use `merge /somebranch` to initialize this branch. - -.> branch.empty foo/empty4 - - Done. I've created an empty branch foo/empty4. - - Tip: Use `merge /somebranch` to initialize this branch. - -``` -The `branch` command can create branches named `releases/drafts/*` (because why not). - -```ucm -foo/main> branch releases/drafts/1.2.3 - - Done. I've created the releases/drafts/1.2.3 branch based off - of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /releases/drafts/1.2.3`. - -foo/main> switch /releases/drafts/1.2.3 - -``` -The `branch` command can't create branches named `releases/*` nor `releases/drafts/*`. - -```ucm -foo/main> branch releases/1.2.3 - - Branch names like releases/1.2.3 are reserved for releases. - - Tip: to download an existing release, try - `clone /releases/1.2.3`. - - Tip: to draft a new release, try `release.draft 1.2.3`. - -foo/main> switch /releases/1.2.3 - - foo/releases/1.2.3 does not exist. - -``` diff --git a/unison-src/transcripts/branch-relative-path.md b/unison-src/transcripts/branch-relative-path.md deleted file mode 100644 index 8414db2f16..0000000000 --- a/unison-src/transcripts/branch-relative-path.md +++ /dev/null @@ -1,31 +0,0 @@ -```ucm:hide -.> builtins.merge -.> project.create-empty p0 -.> project.create-empty p1 -``` - -```unison -foo = 5 -foo.bar = 1 -``` - -```ucm -p0/main> add -``` - -```unison -bonk = 5 -donk.bonk = 1 -``` - -```ucm -p1/main> add -p1/main> fork p0/main: zzz -p1/main> find zzz -p1/main> fork p0/main:foo yyy -p1/main> find yyy -p0/main> fork p1/main: p0/main:p1 -p0/main> ls p1 -p0/main> ls p1.zzz -p0/main> ls p1.yyy -``` diff --git a/unison-src/transcripts/branch-relative-path.output.md b/unison-src/transcripts/branch-relative-path.output.md deleted file mode 100644 index 4f2be5861a..0000000000 --- a/unison-src/transcripts/branch-relative-path.output.md +++ /dev/null @@ -1,97 +0,0 @@ -```unison -foo = 5 -foo.bar = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo : ##Nat - foo.bar : ##Nat - -``` -```ucm -p0/main> add - - ⍟ I've added these definitions: - - foo : ##Nat - foo.bar : ##Nat - -``` -```unison -bonk = 5 -donk.bonk = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bonk : ##Nat - (also named foo) - donk.bonk : ##Nat - (also named foo.bar) - -``` -```ucm -p1/main> add - - ⍟ I've added these definitions: - - bonk : ##Nat - donk.bonk : ##Nat - -p1/main> fork p0/main: zzz - - Done. - -p1/main> find zzz - - 1. zzz.foo : ##Nat - 2. zzz.foo.bar : ##Nat - - -p1/main> fork p0/main:foo yyy - - Done. - -p1/main> find yyy - - 1. yyy.bar : ##Nat - - -p0/main> fork p1/main: p0/main:p1 - - Done. - -p0/main> ls p1 - - 1. bonk (##Nat) - 2. donk/ (1 term) - 3. yyy/ (1 term) - 4. zzz/ (2 terms) - -p0/main> ls p1.zzz - - 1. foo (##Nat) - 2. foo/ (1 term) - -p0/main> ls p1.yyy - - 1. bar (##Nat) - -``` diff --git a/unison-src/transcripts/bug-fix-4354.md b/unison-src/transcripts/bug-fix-4354.md deleted file mode 100644 index c1d603258d..0000000000 --- a/unison-src/transcripts/bug-fix-4354.md +++ /dev/null @@ -1,13 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison -bonk : forall a. a -> a -bonk x = - zonk : forall a. a -> a - zonk z = z - honk : a - honk = x - x -``` diff --git a/unison-src/transcripts/bug-fix-4354.output.md b/unison-src/transcripts/bug-fix-4354.output.md deleted file mode 100644 index ca99d870dd..0000000000 --- a/unison-src/transcripts/bug-fix-4354.output.md +++ /dev/null @@ -1,23 +0,0 @@ -```unison -bonk : forall a. a -> a -bonk x = - zonk : forall a. a -> a - zonk z = z - honk : a - honk = x - x -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bonk : a -> a - -``` diff --git a/unison-src/transcripts/bug-strange-closure.md b/unison-src/transcripts/bug-strange-closure.md deleted file mode 100644 index f2f805d682..0000000000 --- a/unison-src/transcripts/bug-strange-closure.md +++ /dev/null @@ -1,34 +0,0 @@ - -```ucm:hide -.> builtins.mergeio -.> load unison-src/transcripts-using-base/doc.md.files/syntax.u -``` - -We can display the guide before and after adding it to the codebase: - -```ucm -.> display doc.guide -.> add -.> display doc.guide -``` - -But we can't display this due to a decompilation problem. - -```unison -rendered = Pretty.get (docFormatConsole doc.guide) -``` - -```ucm -.> display rendered -.> add -.> display rendered -.> undo -``` - -And then this sometimes generates a GHC crash "strange closure error" but doesn't seem deterministic. - -```unison -rendered = Pretty.get (docFormatConsole doc.guide) - -> rendered -``` diff --git a/unison-src/transcripts/bug-strange-closure.output.md b/unison-src/transcripts/bug-strange-closure.output.md deleted file mode 100644 index 8b9f7fa75c..0000000000 --- a/unison-src/transcripts/bug-strange-closure.output.md +++ /dev/null @@ -1,4524 +0,0 @@ - -We can display the guide before and after adding it to the codebase: - -```ucm -.> display doc.guide - - # Unison computable documentation - - # Basic formatting - - Paragraphs are separated by one or more blanklines. - Sections have a title and 0 or more paragraphs or other - section elements. - - Text can be bold, *italicized*, ~~strikethrough~~, or - `monospaced` (or `monospaced`). - - You can link to Unison terms, types, and external URLs: - - * An external url - * Some is a term link; Optional is a type link - * A named type link and a named term link. Term links are - handy for linking to other documents! - - You can use `{{ .. }}` to escape out to regular Unison - syntax, for instance __not bold__. This is useful for - creating documents programmatically or just including - other documents. - - *Next up:* lists - - # Lists - - # Bulleted lists - - Bulleted lists can use `+`, `-`, or `*` for the bullets - (though the choice will be normalized away by the - pretty-printer). They can be nested, to any depth: - - * A - * B - * C - * C1 - * C2 - - # Numbered lists - - 1. A - 2. B - 3. C - - The first number of the list determines the starting - number in the rendered output. The other numbers are - ignored: - - 10. A - 11. B - 12. C - - Numbered lists can be nested as well, and combined with - bulleted lists: - - 1. Wake up. - * What am I doing here? - * In this nested list. - 2. Take shower. - 3. Get dressed. - - # Evaluation - - Expressions can be evaluated inline, for instance `2`. - - Blocks of code can be evaluated as well, for instance: - - id x = x - id (sqr 10) - ⧨ - 100 - - also: - - match 1 with - 1 -> "hi" - _ -> "goodbye" - ⧨ - "hi" - - To include a typechecked snippet of code without - evaluating it, you can do: - - use Nat * - cube : Nat -> Nat - cube x = x * x * x - - # Including Unison source code - - Unison definitions can be included in docs. For instance: - - structural type Optional a = Some a | None - - sqr : Nat -> Nat - sqr x = - use Nat * - x * x - - Some rendering targets also support folded source: - - structural type Optional a = Some a | None - - sqr : Nat -> Nat - sqr x = - use Nat * - x * x - - You can also include just a signature, inline, with - `sqr : Nat -> Nat`, or you can include one or more - signatures as a block: - - sqr : Nat -> Nat - - Nat.+ : Nat -> Nat -> Nat - - Or alternately: - - List.map : (a ->{e} b) -> [a] ->{e} [b] - - # Inline snippets - - You can include typechecked code snippets inline, for - instance: - - * `f x Nat.+ sqr 1` - the `2` says to ignore the first - two arguments when rendering. In richer renderers, the - `sqr` link will be clickable. - * If your snippet expression is just a single function - application, you can put it in double backticks, like - so: `sqr x`. This is equivalent to `sqr x`. - - # Non-Unison code blocks - - Use three or more single quotes to start a block with no - syntax highlighting: - - ``` raw - _____ _ - | | |___|_|___ ___ ___ - | | | | |_ -| . | | - |_____|_|_|_|___|___|_|_| - - ``` - - You can use three or more backticks plus a language name - for blocks with syntax highlighting: - - ``` Haskell - -- A fenced code block which isn't parsed by Unison - reverse = foldl (flip (:)) [] - ``` - - ``` Scala - // A fenced code block which isn't parsed by Unison - def reverse[A](xs: List[A]) = - xs.foldLeft(Nil : List[A])((acc,a) => a +: acc) - ``` - - There are also asides, callouts, tables, tooltips, and more. - These don't currently have special syntax; just use the - `{{ }}` syntax to call these functions directly. - - docAside : Doc2 -> Doc2 - - docCallout : Optional Doc2 -> Doc2 -> Doc2 - - docBlockquote : Doc2 -> Doc2 - - docTooltip : Doc2 -> Doc2 -> Doc2 - - docTable : [[Doc2]] -> Doc2 - - This is an aside. ( - Some extra detail that doesn't belong in main text. ) - - | This is an important callout, with no icon. - - | 🌻 - | - | This is an important callout, with an icon. The text - | wraps onto multiple lines. - - > "And what is the use of a book," thought Alice, "without - > pictures or conversation?" - > - > *Lewis Carroll, Alice's Adventures in Wonderland* - - Hover over me - - a b A longer paragraph that will split - onto multiple lines, such that this - row occupies multiple lines in the - rendered table. - Some text More text Zounds! - -.> add - - ⍟ I've added these definitions: - - basicFormatting : Doc2 - doc.guide : Doc2 - evaluation : Doc2 - includingSource : Doc2 - lists : Doc2 - nonUnisonCodeBlocks : Doc2 - otherElements : Doc2 - sqr : Nat -> Nat - -.> display doc.guide - - # Unison computable documentation - - # Basic formatting - - Paragraphs are separated by one or more blanklines. - Sections have a title and 0 or more paragraphs or other - section elements. - - Text can be bold, *italicized*, ~~strikethrough~~, or - `monospaced` (or `monospaced`). - - You can link to Unison terms, types, and external URLs: - - * An external url - * Some is a term link; Optional is a type link - * A named type link and a named term link. Term links are - handy for linking to other documents! - - You can use `{{ .. }}` to escape out to regular Unison - syntax, for instance __not bold__. This is useful for - creating documents programmatically or just including - other documents. - - *Next up:* lists - - # Lists - - # Bulleted lists - - Bulleted lists can use `+`, `-`, or `*` for the bullets - (though the choice will be normalized away by the - pretty-printer). They can be nested, to any depth: - - * A - * B - * C - * C1 - * C2 - - # Numbered lists - - 1. A - 2. B - 3. C - - The first number of the list determines the starting - number in the rendered output. The other numbers are - ignored: - - 10. A - 11. B - 12. C - - Numbered lists can be nested as well, and combined with - bulleted lists: - - 1. Wake up. - * What am I doing here? - * In this nested list. - 2. Take shower. - 3. Get dressed. - - # Evaluation - - Expressions can be evaluated inline, for instance `2`. - - Blocks of code can be evaluated as well, for instance: - - id x = x - id (sqr 10) - ⧨ - 100 - - also: - - match 1 with - 1 -> "hi" - _ -> "goodbye" - ⧨ - "hi" - - To include a typechecked snippet of code without - evaluating it, you can do: - - use Nat * - cube : Nat -> Nat - cube x = x * x * x - - # Including Unison source code - - Unison definitions can be included in docs. For instance: - - structural type Optional a = Some a | None - - sqr : Nat -> Nat - sqr x = - use Nat * - x * x - - Some rendering targets also support folded source: - - structural type Optional a = Some a | None - - sqr : Nat -> Nat - sqr x = - use Nat * - x * x - - You can also include just a signature, inline, with - `sqr : Nat -> Nat`, or you can include one or more - signatures as a block: - - sqr : Nat -> Nat - - Nat.+ : Nat -> Nat -> Nat - - Or alternately: - - List.map : (a ->{e} b) -> [a] ->{e} [b] - - # Inline snippets - - You can include typechecked code snippets inline, for - instance: - - * `f x Nat.+ sqr 1` - the `2` says to ignore the first - two arguments when rendering. In richer renderers, the - `sqr` link will be clickable. - * If your snippet expression is just a single function - application, you can put it in double backticks, like - so: `sqr x`. This is equivalent to `sqr x`. - - # Non-Unison code blocks - - Use three or more single quotes to start a block with no - syntax highlighting: - - ``` raw - _____ _ - | | |___|_|___ ___ ___ - | | | | |_ -| . | | - |_____|_|_|_|___|___|_|_| - - ``` - - You can use three or more backticks plus a language name - for blocks with syntax highlighting: - - ``` Haskell - -- A fenced code block which isn't parsed by Unison - reverse = foldl (flip (:)) [] - ``` - - ``` Scala - // A fenced code block which isn't parsed by Unison - def reverse[A](xs: List[A]) = - xs.foldLeft(Nil : List[A])((acc,a) => a +: acc) - ``` - - There are also asides, callouts, tables, tooltips, and more. - These don't currently have special syntax; just use the - `{{ }}` syntax to call these functions directly. - - docAside : Doc2 -> Doc2 - - docCallout : Optional Doc2 -> Doc2 -> Doc2 - - docBlockquote : Doc2 -> Doc2 - - docTooltip : Doc2 -> Doc2 -> Doc2 - - docTable : [[Doc2]] -> Doc2 - - This is an aside. ( - Some extra detail that doesn't belong in main text. ) - - | This is an important callout, with no icon. - - | 🌻 - | - | This is an important callout, with an icon. The text - | wraps onto multiple lines. - - > "And what is the use of a book," thought Alice, "without - > pictures or conversation?" - > - > *Lewis Carroll, Alice's Adventures in Wonderland* - - Hover over me - - a b A longer paragraph that will split - onto multiple lines, such that this - row occupies multiple lines in the - rendered table. - Some text More text Zounds! - -``` -But we can't display this due to a decompilation problem. - -```unison -rendered = Pretty.get (docFormatConsole doc.guide) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - rendered : Annotated () (Either SpecialForm ConsoleText) - -``` -```ucm -.> display rendered - - # Unison computable documentation - - # Basic formatting - - Paragraphs are separated by one or more blanklines. - Sections have a title and 0 or more paragraphs or other - section elements. - - Text can be bold, *italicized*, ~~strikethrough~~, or - `monospaced` (or `monospaced`). - - You can link to Unison terms, types, and external URLs: - - * An external url - * Some is a term link; Optional is a type link - * A named type link and a named term link. Term links are - handy for linking to other documents! - - You can use `{{ .. }}` to escape out to regular Unison - syntax, for instance __not bold__. This is useful for - creating documents programmatically or just including - other documents. - - *Next up:* lists - - # Lists - - # Bulleted lists - - Bulleted lists can use `+`, `-`, or `*` for the bullets - (though the choice will be normalized away by the - pretty-printer). They can be nested, to any depth: - - * A - * B - * C - * C1 - * C2 - - # Numbered lists - - 1. A - 2. B - 3. C - - The first number of the list determines the starting - number in the rendered output. The other numbers are - ignored: - - 10. A - 11. B - 12. C - - Numbered lists can be nested as well, and combined with - bulleted lists: - - 1. Wake up. - * What am I doing here? - * In this nested list. - 2. Take shower. - 3. Get dressed. - - # Evaluation - - Expressions can be evaluated inline, for instance `2`. - - Blocks of code can be evaluated as well, for instance: - - id x = x - id (sqr 10) - ⧨ - 100 - - also: - - match 1 with - 1 -> "hi" - _ -> "goodbye" - ⧨ - "hi" - - To include a typechecked snippet of code without - evaluating it, you can do: - - use Nat * - cube : Nat -> Nat - cube x = x * x * x - - # Including Unison source code - - Unison definitions can be included in docs. For instance: - - structural type Optional a = Some a | None - - sqr : Nat -> Nat - sqr x = - use Nat * - x * x - - Some rendering targets also support folded source: - - structural type Optional a = Some a | None - - sqr : Nat -> Nat - sqr x = - use Nat * - x * x - - You can also include just a signature, inline, with - `sqr : Nat -> Nat`, or you can include one or more - signatures as a block: - - sqr : Nat -> Nat - - Nat.+ : Nat -> Nat -> Nat - - Or alternately: - - List.map : (a ->{e} b) -> [a] ->{e} [b] - - # Inline snippets - - You can include typechecked code snippets inline, for - instance: - - * `f x Nat.+ sqr 1` - the `2` says to ignore the first - two arguments when rendering. In richer renderers, the - `sqr` link will be clickable. - * If your snippet expression is just a single function - application, you can put it in double backticks, like - so: `sqr x`. This is equivalent to `sqr x`. - - # Non-Unison code blocks - - Use three or more single quotes to start a block with no - syntax highlighting: - - ``` raw - _____ _ - | | |___|_|___ ___ ___ - | | | | |_ -| . | | - |_____|_|_|_|___|___|_|_| - - ``` - - You can use three or more backticks plus a language name - for blocks with syntax highlighting: - - ``` Haskell - -- A fenced code block which isn't parsed by Unison - reverse = foldl (flip (:)) [] - ``` - - ``` Scala - // A fenced code block which isn't parsed by Unison - def reverse[A](xs: List[A]) = - xs.foldLeft(Nil : List[A])((acc,a) => a +: acc) - ``` - - There are also asides, callouts, tables, tooltips, and more. - These don't currently have special syntax; just use the - `{{ }}` syntax to call these functions directly. - - docAside : Doc2 -> Doc2 - - docCallout : Optional Doc2 -> Doc2 -> Doc2 - - docBlockquote : Doc2 -> Doc2 - - docTooltip : Doc2 -> Doc2 -> Doc2 - - docTable : [[Doc2]] -> Doc2 - - This is an aside. ( - Some extra detail that doesn't belong in main text. ) - - | This is an important callout, with no icon. - - | 🌻 - | - | This is an important callout, with an icon. The text - | wraps onto multiple lines. - - > "And what is the use of a book," thought Alice, "without - > pictures or conversation?" - > - > *Lewis Carroll, Alice's Adventures in Wonderland* - - Hover over me - - a b A longer paragraph that will split - onto multiple lines, such that this - row occupies multiple lines in the - rendered table. - Some text More text Zounds! - -.> add - - ⍟ I've added these definitions: - - rendered : Annotated () (Either SpecialForm ConsoleText) - -.> display rendered - - # Unison computable documentation - - # Basic formatting - - Paragraphs are separated by one or more blanklines. - Sections have a title and 0 or more paragraphs or other - section elements. - - Text can be bold, *italicized*, ~~strikethrough~~, or - `monospaced` (or `monospaced`). - - You can link to Unison terms, types, and external URLs: - - * An external url - * Some is a term link; Optional is a type link - * A named type link and a named term link. Term links are - handy for linking to other documents! - - You can use `{{ .. }}` to escape out to regular Unison - syntax, for instance __not bold__. This is useful for - creating documents programmatically or just including - other documents. - - *Next up:* lists - - # Lists - - # Bulleted lists - - Bulleted lists can use `+`, `-`, or `*` for the bullets - (though the choice will be normalized away by the - pretty-printer). They can be nested, to any depth: - - * A - * B - * C - * C1 - * C2 - - # Numbered lists - - 1. A - 2. B - 3. C - - The first number of the list determines the starting - number in the rendered output. The other numbers are - ignored: - - 10. A - 11. B - 12. C - - Numbered lists can be nested as well, and combined with - bulleted lists: - - 1. Wake up. - * What am I doing here? - * In this nested list. - 2. Take shower. - 3. Get dressed. - - # Evaluation - - Expressions can be evaluated inline, for instance `2`. - - Blocks of code can be evaluated as well, for instance: - - id x = x - id (sqr 10) - ⧨ - 100 - - also: - - match 1 with - 1 -> "hi" - _ -> "goodbye" - ⧨ - "hi" - - To include a typechecked snippet of code without - evaluating it, you can do: - - use Nat * - cube : Nat -> Nat - cube x = x * x * x - - # Including Unison source code - - Unison definitions can be included in docs. For instance: - - structural type Optional a = Some a | None - - sqr : Nat -> Nat - sqr x = - use Nat * - x * x - - Some rendering targets also support folded source: - - structural type Optional a = Some a | None - - sqr : Nat -> Nat - sqr x = - use Nat * - x * x - - You can also include just a signature, inline, with - `sqr : Nat -> Nat`, or you can include one or more - signatures as a block: - - sqr : Nat -> Nat - - Nat.+ : Nat -> Nat -> Nat - - Or alternately: - - List.map : (a ->{e} b) -> [a] ->{e} [b] - - # Inline snippets - - You can include typechecked code snippets inline, for - instance: - - * `f x Nat.+ sqr 1` - the `2` says to ignore the first - two arguments when rendering. In richer renderers, the - `sqr` link will be clickable. - * If your snippet expression is just a single function - application, you can put it in double backticks, like - so: `sqr x`. This is equivalent to `sqr x`. - - # Non-Unison code blocks - - Use three or more single quotes to start a block with no - syntax highlighting: - - ``` raw - _____ _ - | | |___|_|___ ___ ___ - | | | | |_ -| . | | - |_____|_|_|_|___|___|_|_| - - ``` - - You can use three or more backticks plus a language name - for blocks with syntax highlighting: - - ``` Haskell - -- A fenced code block which isn't parsed by Unison - reverse = foldl (flip (:)) [] - ``` - - ``` Scala - // A fenced code block which isn't parsed by Unison - def reverse[A](xs: List[A]) = - xs.foldLeft(Nil : List[A])((acc,a) => a +: acc) - ``` - - There are also asides, callouts, tables, tooltips, and more. - These don't currently have special syntax; just use the - `{{ }}` syntax to call these functions directly. - - docAside : Doc2 -> Doc2 - - docCallout : Optional Doc2 -> Doc2 -> Doc2 - - docBlockquote : Doc2 -> Doc2 - - docTooltip : Doc2 -> Doc2 -> Doc2 - - docTable : [[Doc2]] -> Doc2 - - This is an aside. ( - Some extra detail that doesn't belong in main text. ) - - | This is an important callout, with no icon. - - | 🌻 - | - | This is an important callout, with an icon. The text - | wraps onto multiple lines. - - > "And what is the use of a book," thought Alice, "without - > pictures or conversation?" - > - > *Lewis Carroll, Alice's Adventures in Wonderland* - - Hover over me - - a b A longer paragraph that will split - onto multiple lines, such that this - row occupies multiple lines in the - rendered table. - Some text More text Zounds! - -.> undo - - Here are the changes I undid - - Added definitions: - - 1. rendered : Annotated () (Either SpecialForm ConsoleText) - -``` -And then this sometimes generates a GHC crash "strange closure error" but doesn't seem deterministic. - -```unison -rendered = Pretty.get (docFormatConsole doc.guide) - -> rendered -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - rendered : Annotated () (Either SpecialForm ConsoleText) - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 3 | > rendered - ⧩ - Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit () (Right (Plain "# "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (ConsoleText.Bold (Plain "Unison"))) - , Lit - () - (Right - (ConsoleText.Bold - (Plain "computable"))) - , Lit - () - (Right - (ConsoleText.Bold - (Plain "documentation"))) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit () (Right (Plain "# "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (ConsoleText.Bold - (Plain "Basic"))) - , Lit - () - (Right - (ConsoleText.Bold - (Plain "formatting"))) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain "Paragraphs")) - , Lit - () (Right (Plain "are")) - , Lit - () - (Right - (Plain "separated")) - , Lit - () (Right (Plain "by")) - , Lit - () (Right (Plain "one")) - , Lit - () (Right (Plain "or")) - , Lit - () - (Right (Plain "more")) - , Lit - () - (Right - (Plain "blanklines.")) - , Lit - () - (Right - (Plain "Sections")) - , Lit - () - (Right (Plain "have")) - , Lit () (Right (Plain "a")) - , Lit - () - (Right (Plain "title")) - , Lit - () (Right (Plain "and")) - , Lit () (Right (Plain "0")) - , Lit - () (Right (Plain "or")) - , Lit - () - (Right (Plain "more")) - , Lit - () - (Right - (Plain "paragraphs")) - , Lit - () (Right (Plain "or")) - , Lit - () - (Right (Plain "other")) - , Lit - () - (Right (Plain "section")) - , Lit - () - (Right - (Plain "elements.")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "Text")) - , Lit - () (Right (Plain "can")) - , Lit - () (Right (Plain "be")) - , Annotated.Group - () - (Annotated.Append - () - [ Wrap - () - (Lit - () - (Right - (ConsoleText.Bold - (Plain - "bold")))) - , Lit - () - (Right (Plain ",")) - ]) - , Annotated.Group - () - (Annotated.Append - () - [ Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain "*")) - , Wrap - () - (Lit - () - (Right - (Plain - "italicized"))) - , Lit - () - (Right - (Plain "*")) - ]) - , Lit - () - (Right (Plain ",")) - ]) - , Annotated.Group - () - (Annotated.Append - () - [ Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "~~")) - , Wrap - () - (Lit - () - (Right - (Plain - "strikethrough"))) - , Lit - () - (Right - (Plain - "~~")) - ]) - , Lit - () - (Right (Plain ",")) - ]) - , Lit - () (Right (Plain "or")) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "`")) - , Lit - () - (Right - (Plain - "monospaced")) - , Lit - () - (Right (Plain "`")) - ]) - , Lit - () (Right (Plain "(or")) - , Annotated.Group - () - (Annotated.Append - () - [ Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain "`")) - , Lit - () - (Right - (Plain - "monospaced")) - , Lit - () - (Right - (Plain "`")) - ]) - , Lit - () - (Right - (Plain ").")) - ]) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () (Right (Plain "You")) - , Lit - () (Right (Plain "can")) - , Lit - () - (Right (Plain "link")) - , Lit - () (Right (Plain "to")) - , Lit - () - (Right (Plain "Unison")) - , Lit - () - (Right (Plain "terms,")) - , Lit - () - (Right (Plain "types,")) - , Lit - () (Right (Plain "and")) - , Lit - () - (Right - (Plain "external")) - , Lit - () - (Right (Plain "URLs:")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit - () - (Right (Plain "* "))) - (Lit - () - (Right (Plain " "))) - (Wrap - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Underline - (Plain - "An"))) - , Lit - () - (Right - (Underline - (Plain - "external"))) - , Lit - () - (Right - (Underline - (Plain - "url"))) - ]))) - , Lit - () (Right (Plain "\n")) - , Indent - () - (Lit - () - (Right (Plain "* "))) - (Lit - () - (Right (Plain " "))) - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Left - (SpecialForm.Link - (Right - (Term.Term - (Any - (do - Some)))))) - , Lit - () - (Right - (Plain "is")) - , Lit - () - (Right - (Plain "a")) - , Lit - () - (Right - (Plain "term")) - , Lit - () - (Right - (Plain "link;")) - , Lit - () - (Left - (SpecialForm.Link - (Left - (typeLink Optional)))) - , Lit - () - (Right - (Plain "is")) - , Lit - () - (Right - (Plain "a")) - , Lit - () - (Right - (Plain "type")) - , Lit - () - (Right - (Plain "link")) - ])) - , Lit - () (Right (Plain "\n")) - , Indent - () - (Lit - () - (Right (Plain "* "))) - (Lit - () - (Right (Plain " "))) - (Wrap - () - (Annotated.Append - () - [ Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Underline - (Plain - "A"))) - , Lit - () - (Right - (Underline - (Plain - "named"))) - , Lit - () - (Right - (Underline - (Plain - "type"))) - , Lit - () - (Right - (Underline - (Plain - "link"))) - ]) - , Lit - () - (Right - (Plain "and")) - , Annotated.Group - () - (Annotated.Append - () - [ Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Underline - (Plain - "a"))) - , Lit - () - (Right - (Underline - (Plain - "named"))) - , Lit - () - (Right - (Underline - (Plain - "term"))) - , Lit - () - (Right - (Underline - (Plain - "link"))) - ]) - , Lit - () - (Right - (Plain - ".")) - ]) - , Lit - () - (Right - (Plain "Term")) - , Lit - () - (Right - (Plain "links")) - , Lit - () - (Right - (Plain "are")) - , Lit - () - (Right - (Plain "handy")) - , Lit - () - (Right - (Plain "for")) - , Lit - () - (Right - (Plain - "linking")) - , Lit - () - (Right - (Plain "to")) - , Lit - () - (Right - (Plain "other")) - , Lit - () - (Right - (Plain - "documents!")) - ])) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () (Right (Plain "You")) - , Lit - () (Right (Plain "can")) - , Lit - () (Right (Plain "use")) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "`")) - , Lit - () - (Right - (Plain - "{{ .. }}")) - , Lit - () - (Right (Plain "`")) - ]) - , Lit - () (Right (Plain "to")) - , Lit - () - (Right (Plain "escape")) - , Lit - () (Right (Plain "out")) - , Lit - () (Right (Plain "to")) - , Lit - () - (Right (Plain "regular")) - , Lit - () - (Right (Plain "Unison")) - , Lit - () - (Right (Plain "syntax,")) - , Lit - () (Right (Plain "for")) - , Lit - () - (Right - (Plain "instance")) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "__not bold__")) - , Lit - () - (Right (Plain ".")) - ]) - , Lit - () - (Right (Plain "This")) - , Lit - () (Right (Plain "is")) - , Lit - () - (Right (Plain "useful")) - , Lit - () (Right (Plain "for")) - , Lit - () - (Right - (Plain "creating")) - , Lit - () - (Right - (Plain "documents")) - , Lit - () - (Right - (Plain - "programmatically")) - , Lit - () (Right (Plain "or")) - , Lit - () - (Right (Plain "just")) - , Lit - () - (Right - (Plain "including")) - , Lit - () - (Right (Plain "other")) - , Lit - () - (Right - (Plain "documents.")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "*")) - , Lit - () - (Right - (Plain "Next")) - ]) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain "up:")) - , Lit - () - (Right (Plain "*")) - ]) - , Lit - () - (Left - (SpecialForm.Link - (Right - (Term.Term - (Any (do lists)))))) - ]))) - ])))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit () (Right (Plain "# "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Lit - () - (Right - (ConsoleText.Bold - (Plain "Lists")))))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit - () - (Right (Plain "# "))) - (Lit - () - (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (ConsoleText.Bold - (Plain - "Bulleted"))) - , Lit - () - (Right - (ConsoleText.Bold - (Plain - "lists"))) - ]))) - , Lit - () (Right (Plain "\n")) - , Lit - () (Right (Plain "\n")) - , Indent - () - (Lit - () - (Right (Plain " "))) - (Lit - () - (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "Bulleted")) - , Lit - () - (Right - (Plain - "lists")) - , Lit - () - (Right - (Plain "can")) - , Lit - () - (Right - (Plain "use")) - , Annotated.Group - () - (Annotated.Append - () - [ Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "`")) - , Lit - () - (Right - (Plain - "+")) - , Lit - () - (Right - (Plain - "`")) - ]) - , Lit - () - (Right - (Plain - ",")) - ]) - , Annotated.Group - () - (Annotated.Append - () - [ Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "`")) - , Lit - () - (Right - (Plain - "-")) - , Lit - () - (Right - (Plain - "`")) - ]) - , Lit - () - (Right - (Plain - ",")) - ]) - , Lit - () - (Right - (Plain "or")) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "`")) - , Lit - () - (Right - (Plain - "*")) - , Lit - () - (Right - (Plain - "`")) - ]) - , Lit - () - (Right - (Plain "for")) - , Lit - () - (Right - (Plain "the")) - , Lit - () - (Right - (Plain - "bullets")) - , Lit - () - (Right - (Plain - "(though")) - , Lit - () - (Right - (Plain "the")) - , Lit - () - (Right - (Plain - "choice")) - , Lit - () - (Right - (Plain - "will")) - , Lit - () - (Right - (Plain "be")) - , Lit - () - (Right - (Plain - "normalized")) - , Lit - () - (Right - (Plain - "away")) - , Lit - () - (Right - (Plain "by")) - , Lit - () - (Right - (Plain "the")) - , Lit - () - (Right - (Plain - "pretty-printer).")) - , Lit - () - (Right - (Plain - "They")) - , Lit - () - (Right - (Plain "can")) - , Lit - () - (Right - (Plain "be")) - , Lit - () - (Right - (Plain - "nested,")) - , Lit - () - (Right - (Plain "to")) - , Lit - () - (Right - (Plain "any")) - , Lit - () - (Right - (Plain - "depth:")) - ]))) - , Lit - () (Right (Plain "\n")) - , Lit - () (Right (Plain "\n")) - , Indent - () - (Lit - () - (Right (Plain " "))) - (Lit - () - (Right (Plain " "))) - (Annotated.Group - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit - () - (Right - (Plain - "* "))) - (Lit - () - (Right - (Plain - " "))) - (Wrap - () - (Lit - () - (Right - (Plain - "A")))) - , Lit - () - (Right - (Plain "\n")) - , Indent - () - (Lit - () - (Right - (Plain - "* "))) - (Lit - () - (Right - (Plain - " "))) - (Wrap - () - (Lit - () - (Right - (Plain - "B")))) - , Lit - () - (Right - (Plain "\n")) - , Indent - () - (Lit - () - (Right - (Plain - "* "))) - (Lit - () - (Right - (Plain - " "))) - (Annotated.Append - () - [ Wrap - () - (Lit - () - (Right - (Plain - "C"))) - , Lit - () - (Right - (Plain - "\n")) - , Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit - ( - ) - (Right - (Plain - "* "))) - (Lit - ( - ) - (Right - (Plain - " "))) - (Wrap - ( - ) - (Lit - ( - ) - (Right - (Plain - "C1")))) - , Lit - () - (Right - (Plain - "\n")) - , Indent - () - (Lit - ( - ) - (Right - (Plain - "* "))) - (Lit - ( - ) - (Right - (Plain - " "))) - (Wrap - ( - ) - (Lit - ( - ) - (Right - (Plain - "C2")))) - ]) - ]) - ]))) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit - () - (Right (Plain "# "))) - (Lit - () - (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (ConsoleText.Bold - (Plain - "Numbered"))) - , Lit - () - (Right - (ConsoleText.Bold - (Plain - "lists"))) - ]))) - , Lit - () (Right (Plain "\n")) - , Lit - () (Right (Plain "\n")) - , Indent - () - (Lit - () - (Right (Plain " "))) - (Lit - () - (Right (Plain " "))) - (Annotated.Group - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit - () - (Right - (Plain - "1. "))) - (Lit - () - (Right - (Plain - " "))) - (Wrap - () - (Lit - () - (Right - (Plain - "A")))) - , Lit - () - (Right - (Plain "\n")) - , Indent - () - (Lit - () - (Right - (Plain - "2. "))) - (Lit - () - (Right - (Plain - " "))) - (Wrap - () - (Lit - () - (Right - (Plain - "B")))) - , Lit - () - (Right - (Plain "\n")) - , Indent - () - (Lit - () - (Right - (Plain - "3. "))) - (Lit - () - (Right - (Plain - " "))) - (Wrap - () - (Lit - () - (Right - (Plain - "C")))) - ]))) - , Lit - () (Right (Plain "\n")) - , Lit - () (Right (Plain "\n")) - , Indent - () - (Lit - () - (Right (Plain " "))) - (Lit - () - (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain "The")) - , Lit - () - (Right - (Plain - "first")) - , Lit - () - (Right - (Plain - "number")) - , Lit - () - (Right - (Plain "of")) - , Lit - () - (Right - (Plain "the")) - , Lit - () - (Right - (Plain - "list")) - , Lit - () - (Right - (Plain - "determines")) - , Lit - () - (Right - (Plain "the")) - , Lit - () - (Right - (Plain - "starting")) - , Lit - () - (Right - (Plain - "number")) - , Lit - () - (Right - (Plain "in")) - , Lit - () - (Right - (Plain "the")) - , Lit - () - (Right - (Plain - "rendered")) - , Lit - () - (Right - (Plain - "output.")) - , Lit - () - (Right - (Plain "The")) - , Lit - () - (Right - (Plain - "other")) - , Lit - () - (Right - (Plain - "numbers")) - , Lit - () - (Right - (Plain "are")) - , Lit - () - (Right - (Plain - "ignored:")) - ]))) - , Lit - () (Right (Plain "\n")) - , Lit - () (Right (Plain "\n")) - , Indent - () - (Lit - () - (Right (Plain " "))) - (Lit - () - (Right (Plain " "))) - (Annotated.Group - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit - () - (Right - (Plain - "10. "))) - (Lit - () - (Right - (Plain - " "))) - (Wrap - () - (Lit - () - (Right - (Plain - "A")))) - , Lit - () - (Right - (Plain "\n")) - , Indent - () - (Lit - () - (Right - (Plain - "11. "))) - (Lit - () - (Right - (Plain - " "))) - (Wrap - () - (Lit - () - (Right - (Plain - "B")))) - , Lit - () - (Right - (Plain "\n")) - , Indent - () - (Lit - () - (Right - (Plain - "12. "))) - (Lit - () - (Right - (Plain - " "))) - (Wrap - () - (Lit - () - (Right - (Plain - "C")))) - ]))) - , Lit - () (Right (Plain "\n")) - , Lit - () (Right (Plain "\n")) - , Indent - () - (Lit - () - (Right (Plain " "))) - (Lit - () - (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "Numbered")) - , Lit - () - (Right - (Plain - "lists")) - , Lit - () - (Right - (Plain "can")) - , Lit - () - (Right - (Plain "be")) - , Lit - () - (Right - (Plain - "nested")) - , Lit - () - (Right - (Plain "as")) - , Lit - () - (Right - (Plain - "well,")) - , Lit - () - (Right - (Plain "and")) - , Lit - () - (Right - (Plain - "combined")) - , Lit - () - (Right - (Plain - "with")) - , Lit - () - (Right - (Plain - "bulleted")) - , Lit - () - (Right - (Plain - "lists:")) - ]))) - , Lit - () (Right (Plain "\n")) - , Lit - () (Right (Plain "\n")) - , Indent - () - (Lit - () - (Right (Plain " "))) - (Lit - () - (Right (Plain " "))) - (Annotated.Group - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit - () - (Right - (Plain - "1. "))) - (Lit - () - (Right - (Plain - " "))) - (Annotated.Append - () - [ Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "Wake")) - , Lit - () - (Right - (Plain - "up.")) - ]) - , Lit - () - (Right - (Plain - "\n")) - , Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit - ( - ) - (Right - (Plain - "* "))) - (Lit - ( - ) - (Right - (Plain - " "))) - (Wrap - ( - ) - (Annotated.Append - ( - ) - [ Lit - ( - ) - (Right - (Plain - "What")) - , Lit - ( - ) - (Right - (Plain - "am")) - , Lit - ( - ) - (Right - (Plain - "I")) - , Lit - ( - ) - (Right - (Plain - "doing")) - , Lit - ( - ) - (Right - (Plain - "here?")) - ])) - , Lit - () - (Right - (Plain - "\n")) - , Indent - () - (Lit - ( - ) - (Right - (Plain - "* "))) - (Lit - ( - ) - (Right - (Plain - " "))) - (Wrap - ( - ) - (Annotated.Append - ( - ) - [ Lit - ( - ) - (Right - (Plain - "In")) - , Lit - ( - ) - (Right - (Plain - "this")) - , Lit - ( - ) - (Right - (Plain - "nested")) - , Lit - ( - ) - (Right - (Plain - "list.")) - ])) - ]) - ]) - , Lit - () - (Right - (Plain "\n")) - , Indent - () - (Lit - () - (Right - (Plain - "2. "))) - (Lit - () - (Right - (Plain - " "))) - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "Take")) - , Lit - () - (Right - (Plain - "shower.")) - ])) - , Lit - () - (Right - (Plain "\n")) - , Indent - () - (Lit - () - (Right - (Plain - "3. "))) - (Lit - () - (Right - (Plain - " "))) - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "Get")) - , Lit - () - (Right - (Plain - "dressed.")) - ])) - ]))) - ]))) - ])))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit () (Right (Plain "# "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Lit - () - (Right - (ConsoleText.Bold - (Plain "Evaluation")))))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain "Expressions")) - , Lit - () (Right (Plain "can")) - , Lit - () (Right (Plain "be")) - , Lit - () - (Right - (Plain "evaluated")) - , Lit - () - (Right (Plain "inline,")) - , Lit - () (Right (Plain "for")) - , Lit - () - (Right - (Plain "instance")) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Left - (EvalInline - (Term.Term - (Any - (do - 1 - Nat.+ 1))))) - , Lit - () - (Right (Plain ".")) - ]) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "Blocks")) - , Lit - () (Right (Plain "of")) - , Lit - () - (Right (Plain "code")) - , Lit - () (Right (Plain "can")) - , Lit - () (Right (Plain "be")) - , Lit - () - (Right - (Plain "evaluated")) - , Lit - () (Right (Plain "as")) - , Lit - () - (Right (Plain "well,")) - , Lit - () (Right (Plain "for")) - , Lit - () - (Right - (Plain "instance:")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () (Lit - () (Left - (Eval - (Term.Term - (Any - (do - id x = x - id (sqr 10)))))))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Lit - () (Right (Plain "also:"))))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () (Lit - () (Left - (Eval - (Term.Term - (Any - (do match 1 with - 1 -> "hi" - _ -> "goodbye"))))))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () (Right (Plain "To")) - , Lit - () - (Right (Plain "include")) - , Lit () (Right (Plain "a")) - , Lit - () - (Right - (Plain "typechecked")) - , Lit - () - (Right (Plain "snippet")) - , Lit - () (Right (Plain "of")) - , Lit - () - (Right (Plain "code")) - , Lit - () - (Right (Plain "without")) - , Lit - () - (Right - (Plain "evaluating")) - , Lit - () (Right (Plain "it,")) - , Lit - () (Right (Plain "you")) - , Lit - () (Right (Plain "can")) - , Lit - () (Right (Plain "do:")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () (Lit - () (Left - (ExampleBlock - 0 (Term.Term - (Any - (do - use Nat * - cube : Nat -> Nat - cube x = x * x * x - ()))))))) - ])))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit () (Right (Plain "# "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (ConsoleText.Bold - (Plain "Including"))) - , Lit - () - (Right - (ConsoleText.Bold - (Plain "Unison"))) - , Lit - () - (Right - (ConsoleText.Bold - (Plain "source"))) - , Lit - () - (Right - (ConsoleText.Bold - (Plain "code"))) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "Unison")) - , Lit - () - (Right - (Plain "definitions")) - , Lit - () (Right (Plain "can")) - , Lit - () (Right (Plain "be")) - , Lit - () - (Right - (Plain "included")) - , Lit - () (Right (Plain "in")) - , Lit - () - (Right (Plain "docs.")) - , Lit - () (Right (Plain "For")) - , Lit - () - (Right - (Plain "instance:")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Lit - () - (Left - (SpecialForm.Source - [ ( Left - (typeLink Optional) - , [] - ) - , ( Right - (Term.Term - (Any (do sqr))) - , [] - ) - ]))))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "Some")) - , Lit - () - (Right - (Plain "rendering")) - , Lit - () - (Right (Plain "targets")) - , Lit - () - (Right (Plain "also")) - , Lit - () - (Right (Plain "support")) - , Lit - () - (Right (Plain "folded")) - , Lit - () - (Right (Plain "source:")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Lit - () - (Left - (FoldedSource - [ ( Left - (typeLink Optional) - , [] - ) - , ( Right - (Term.Term - (Any (do sqr))) - , [] - ) - ]))))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () (Right (Plain "You")) - , Lit - () (Right (Plain "can")) - , Lit - () - (Right (Plain "also")) - , Lit - () - (Right (Plain "include")) - , Lit - () - (Right (Plain "just")) - , Lit () (Right (Plain "a")) - , Lit - () - (Right - (Plain "signature,")) - , Lit - () - (Right (Plain "inline,")) - , Lit - () - (Right (Plain "with")) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Left - (SignatureInline - (Term.Term - (Any - (do sqr))))) - , Lit - () - (Right (Plain ",")) - ]) - , Lit - () (Right (Plain "or")) - , Lit - () (Right (Plain "you")) - , Lit - () (Right (Plain "can")) - , Lit - () - (Right (Plain "include")) - , Lit - () (Right (Plain "one")) - , Lit - () (Right (Plain "or")) - , Lit - () - (Right (Plain "more")) - , Lit - () - (Right - (Plain "signatures")) - , Lit - () (Right (Plain "as")) - , Lit () (Right (Plain "a")) - , Lit - () - (Right (Plain "block:")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Lit - () - (Left - (SpecialForm.Signature - [ Term.Term - (Any (do sqr)) - , Term.Term - (Any (do (Nat.+))) - ]))))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () (Right (Plain "Or")) - , Lit - () - (Right - (Plain "alternately:")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Lit - () - (Left - (SpecialForm.Signature - [ Term.Term - (Any (do List.map)) - ]))))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit - () - (Right (Plain "# "))) - (Lit - () - (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (ConsoleText.Bold - (Plain - "Inline"))) - , Lit - () - (Right - (ConsoleText.Bold - (Plain - "snippets"))) - ]))) - , Lit - () (Right (Plain "\n")) - , Lit - () (Right (Plain "\n")) - , Indent - () - (Lit - () - (Right (Plain " "))) - (Lit - () - (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain "You")) - , Lit - () - (Right - (Plain "can")) - , Lit - () - (Right - (Plain - "include")) - , Lit - () - (Right - (Plain - "typechecked")) - , Lit - () - (Right - (Plain - "code")) - , Lit - () - (Right - (Plain - "snippets")) - , Lit - () - (Right - (Plain - "inline,")) - , Lit - () - (Right - (Plain "for")) - , Lit - () - (Right - (Plain - "instance:")) - ]))) - , Lit - () (Right (Plain "\n")) - , Lit - () (Right (Plain "\n")) - , Indent - () - (Lit - () - (Right (Plain " "))) - (Lit - () - (Right (Plain " "))) - (Annotated.Group - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit - () - (Right - (Plain - "* "))) - (Lit - () - (Right - (Plain - " "))) - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Left - (Example - 2 - (Term.Term - (Any - (do - f - x -> - f - x - Nat.+ sqr - 1))))) - , Lit - () - (Right - (Plain - "-")) - , Lit - () - (Right - (Plain - "the")) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - ( - ) - (Right - (Plain - "`")) - , Lit - ( - ) - (Right - (Plain - "2")) - , Lit - ( - ) - (Right - (Plain - "`")) - ]) - , Lit - () - (Right - (Plain - "says")) - , Lit - () - (Right - (Plain - "to")) - , Lit - () - (Right - (Plain - "ignore")) - , Lit - () - (Right - (Plain - "the")) - , Lit - () - (Right - (Plain - "first")) - , Lit - () - (Right - (Plain - "two")) - , Lit - () - (Right - (Plain - "arguments")) - , Lit - () - (Right - (Plain - "when")) - , Lit - () - (Right - (Plain - "rendering.")) - , Lit - () - (Right - (Plain - "In")) - , Lit - () - (Right - (Plain - "richer")) - , Lit - () - (Right - (Plain - "renderers,")) - , Lit - () - (Right - (Plain - "the")) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - ( - ) - (Right - (Plain - "`")) - , Lit - ( - ) - (Right - (Plain - "sqr")) - , Lit - ( - ) - (Right - (Plain - "`")) - ]) - , Lit - () - (Right - (Plain - "link")) - , Lit - () - (Right - (Plain - "will")) - , Lit - () - (Right - (Plain - "be")) - , Lit - () - (Right - (Plain - "clickable.")) - ])) - , Lit - () - (Right - (Plain "\n")) - , Indent - () - (Lit - () - (Right - (Plain - "* "))) - (Lit - () - (Right - (Plain - " "))) - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "If")) - , Lit - () - (Right - (Plain - "your")) - , Lit - () - (Right - (Plain - "snippet")) - , Lit - () - (Right - (Plain - "expression")) - , Lit - () - (Right - (Plain - "is")) - , Lit - () - (Right - (Plain - "just")) - , Lit - () - (Right - (Plain - "a")) - , Lit - () - (Right - (Plain - "single")) - , Lit - () - (Right - (Plain - "function")) - , Lit - () - (Right - (Plain - "application,")) - , Lit - () - (Right - (Plain - "you")) - , Lit - () - (Right - (Plain - "can")) - , Lit - () - (Right - (Plain - "put")) - , Lit - () - (Right - (Plain - "it")) - , Lit - () - (Right - (Plain - "in")) - , Lit - () - (Right - (Plain - "double")) - , Lit - () - (Right - (Plain - "backticks,")) - , Lit - () - (Right - (Plain - "like")) - , Lit - () - (Right - (Plain - "so:")) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - ( - ) - (Left - (Example - 1 - (Term.Term - (Any - (do - x -> - sqr - x))))) - , Lit - ( - ) - (Right - (Plain - ".")) - ]) - , Lit - () - (Right - (Plain - "This")) - , Lit - () - (Right - (Plain - "is")) - , Lit - () - (Right - (Plain - "equivalent")) - , Lit - () - (Right - (Plain - "to")) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - ( - ) - (Left - (Example - 1 - (Term.Term - (Any - (do - x -> - sqr - x))))) - , Lit - ( - ) - (Right - (Plain - ".")) - ]) - ])) - ]))) - ]))) - ])))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Group - () - (Annotated.Append - () - [ Indent - () - (Lit () (Right (Plain "# "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (ConsoleText.Bold - (Plain "Non-Unison"))) - , Lit - () - (Right - (ConsoleText.Bold - (Plain "code"))) - , Lit - () - (Right - (ConsoleText.Bold - (Plain "blocks"))) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () (Right (Plain "Use")) - , Lit - () - (Right (Plain "three")) - , Lit - () (Right (Plain "or")) - , Lit - () - (Right (Plain "more")) - , Lit - () - (Right (Plain "single")) - , Lit - () - (Right (Plain "quotes")) - , Lit - () (Right (Plain "to")) - , Lit - () - (Right (Plain "start")) - , Lit () (Right (Plain "a")) - , Lit - () - (Right (Plain "block")) - , Lit - () - (Right (Plain "with")) - , Lit - () (Right (Plain "no")) - , Lit - () - (Right (Plain "syntax")) - , Lit - () - (Right - (Plain "highlighting:")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "``` ")) - , Annotated.Group - () - (Lit - () - (Right (Plain "raw"))) - , Lit - () - (Right (Plain "\n")) - , Lit - () - (Right - (Plain - " _____ _ \n | | |___|_|___ ___ ___ \n | | | | |_ -| . | |\n |_____|_|_|_|___|___|_|_|\n ")) - , Lit - () - (Right (Plain "\n")) - , Lit - () - (Right (Plain "```")) - ])))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () (Right (Plain "You")) - , Lit - () (Right (Plain "can")) - , Lit - () (Right (Plain "use")) - , Lit - () - (Right (Plain "three")) - , Lit - () (Right (Plain "or")) - , Lit - () - (Right (Plain "more")) - , Lit - () - (Right - (Plain "backticks")) - , Lit - () - (Right (Plain "plus")) - , Lit () (Right (Plain "a")) - , Lit - () - (Right - (Plain "language")) - , Lit - () - (Right (Plain "name")) - , Lit - () (Right (Plain "for")) - , Lit - () - (Right (Plain "blocks")) - , Lit - () - (Right (Plain "with")) - , Lit - () - (Right (Plain "syntax")) - , Lit - () - (Right - (Plain "highlighting:")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "``` ")) - , Annotated.Group - () - (Lit - () - (Right - (Plain "Haskell"))) - , Lit - () (Right (Plain "\n")) - , Lit - () - (Right - (Plain - "-- A fenced code block which isn't parsed by Unison\nreverse = foldl (flip (:)) []")) - , Lit - () (Right (Plain "\n")) - , Lit - () (Right (Plain "```")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "``` ")) - , Annotated.Group - () - (Lit - () - (Right (Plain "Scala"))) - , Lit - () (Right (Plain "\n")) - , Lit - () - (Right - (Plain - "// A fenced code block which isn't parsed by Unison\ndef reverse[A](xs: List[A]) = \n xs.foldLeft(Nil : List[A])((acc,a) => a +: acc)")) - , Lit - () (Right (Plain "\n")) - , Lit - () (Right (Plain "```")) - ]))) - ])))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Indent - () - (Lit () (Right (Plain " "))) - (Lit () (Right (Plain " "))) - (Annotated.Group - () - (Wrap - () - (Annotated.Group - () - (Annotated.Append - () - [ Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () (Right (Plain "There")) - , Lit () (Right (Plain "are")) - , Lit - () (Right (Plain "also")) - , Lit - () - (Right (Plain "asides,")) - , Lit - () - (Right (Plain "callouts,")) - , Lit - () - (Right (Plain "tables,")) - , Lit - () - (Right (Plain "tooltips,")) - , Lit () (Right (Plain "and")) - , Lit - () (Right (Plain "more.")) - , Lit - () (Right (Plain "These")) - , Lit - () (Right (Plain "don't")) - , Lit - () - (Right (Plain "currently")) - , Lit - () (Right (Plain "have")) - , Lit - () - (Right (Plain "special")) - , Lit - () - (Right (Plain "syntax;")) - , Lit - () (Right (Plain "just")) - , Lit () (Right (Plain "use")) - , Lit () (Right (Plain "the")) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "`")) - , Lit - () - (Right - (Plain "{{ }}")) - , Lit - () - (Right (Plain "`")) - ]) - , Lit - () - (Right (Plain "syntax")) - , Lit () (Right (Plain "to")) - , Lit - () (Right (Plain "call")) - , Lit - () (Right (Plain "these")) - , Lit - () - (Right (Plain "functions")) - , Lit - () - (Right (Plain "directly.")) - ])) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Annotated.Group - () - (Wrap - () - (Lit - () - (Left - (SpecialForm.Signature - [ Term.Term - (Any (do docAside)) - , Term.Term - (Any (do docCallout)) - , Term.Term - (Any - (do docBlockquote)) - , Term.Term - (Any (do docTooltip)) - , Term.Term - (Any (do docTable)) - ])))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () (Right (Plain "This")) - , Lit () (Right (Plain "is")) - , Lit () (Right (Plain "an")) - , Lit - () - (Right (Plain "aside.")) - , Lit - () - (Right - (Foreground - BrightBlack - (Plain "("))) - , Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Foreground - BrightBlack - (Plain "Some"))) - , Lit - () - (Right - (Foreground - BrightBlack - (Plain "extra"))) - , Lit - () - (Right - (Foreground - BrightBlack - (Plain "detail"))) - , Lit - () - (Right - (Foreground - BrightBlack - (Plain "that"))) - , Lit - () - (Right - (Foreground - BrightBlack - (Plain "doesn't"))) - , Lit - () - (Right - (Foreground - BrightBlack - (Plain "belong"))) - , Lit - () - (Right - (Foreground - BrightBlack - (Plain "in"))) - , Lit - () - (Right - (Foreground - BrightBlack - (Plain "main"))) - , Lit - () - (Right - (Foreground - BrightBlack - (Plain "text."))) - ]) - , Lit - () - (Right - (Foreground - BrightBlack - (Plain ")"))) - ])) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Annotated.Group - () - (Wrap - () - (Annotated.Group - () - (Indent - () - (Lit - () (Right (Plain " | "))) - (Lit - () (Right (Plain " | "))) - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain "This")) - , Lit - () - (Right (Plain "is")) - , Lit - () - (Right (Plain "an")) - , Lit - () - (Right - (Plain "important")) - , Lit - () - (Right - (Plain "callout,")) - , Lit - () - (Right - (Plain "with")) - , Lit - () - (Right (Plain "no")) - , Lit - () - (Right - (Plain "icon.")) - ]))))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Annotated.Group - () - (Wrap - () - (Annotated.Group - () - (Indent - () - (Lit - () (Right (Plain " | "))) - (Lit - () (Right (Plain " | "))) - (Annotated.Append - () - [ Wrap - () - (Lit - () - (Right - (ConsoleText.Bold - (Plain "🌻")))) - , Lit - () - (Right (Plain "\n")) - , Lit - () (Right (Plain "")) - , Lit - () - (Right (Plain "\n")) - , Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain "This")) - , Lit - () - (Right - (Plain "is")) - , Lit - () - (Right - (Plain "an")) - , Lit - () - (Right - (Plain - "important")) - , Lit - () - (Right - (Plain - "callout,")) - , Lit - () - (Right - (Plain "with")) - , Lit - () - (Right - (Plain "an")) - , Lit - () - (Right - (Plain "icon.")) - , Lit - () - (Right - (Plain "The")) - , Lit - () - (Right - (Plain "text")) - , Lit - () - (Right - (Plain "wraps")) - , Lit - () - (Right - (Plain "onto")) - , Lit - () - (Right - (Plain - "multiple")) - , Lit - () - (Right - (Plain - "lines.")) - ]) - ])))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Annotated.Group - () - (Wrap - () - (Annotated.Group - () - (Indent - () - (Lit () (Right (Plain "> "))) - (Lit () (Right (Plain "> "))) - (Annotated.Group - () - (Annotated.Append - () - [ Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "\"And")) - , Lit - () - (Right - (Plain - "what")) - , Lit - () - (Right - (Plain - "is")) - , Lit - () - (Right - (Plain - "the")) - , Lit - () - (Right - (Plain - "use")) - , Lit - () - (Right - (Plain - "of")) - , Lit - () - (Right - (Plain "a")) - , Lit - () - (Right - (Plain - "book,\"")) - , Lit - () - (Right - (Plain - "thought")) - , Lit - () - (Right - (Plain - "Alice,")) - , Lit - () - (Right - (Plain - "\"without")) - , Lit - () - (Right - (Plain - "pictures")) - , Lit - () - (Right - (Plain - "or")) - , Lit - () - (Right - (Plain - "conversation?\"")) - ])) - , Lit - () - (Right (Plain "\n")) - , Lit - () - (Right (Plain "\n")) - , Annotated.Group - () - (Wrap - () - (Annotated.Append - () - [ Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "*")) - , Lit - () - (Right - (Plain - "Lewis")) - ]) - , Lit - () - (Right - (Plain - "Carroll,")) - , Lit - () - (Right - (Plain - "Alice's")) - , Lit - () - (Right - (Plain - "Adventures")) - , Lit - () - (Right - (Plain - "in")) - , Annotated.Group - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain - "Wonderland")) - , Lit - () - (Right - (Plain - "*")) - ]) - ])) - ]))))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Annotated.Group - () - (Wrap - () - (Wrap - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "Hover")) - , Lit - () - (Right (Plain "over")) - , Lit - () (Right (Plain "me")) - ]))) - , Lit () (Right (Plain "\n")) - , Lit () (Right (Plain "\n")) - , Annotated.Group - () - (Wrap - () - (Annotated.Table - () - [ [ Wrap - () - (Lit - () (Right (Plain "a"))) - , Wrap - () - (Lit - () (Right (Plain "b"))) - , Wrap - () - (Annotated.Append - () - [ Lit - () - (Right (Plain "A")) - , Lit - () - (Right - (Plain "longer")) - , Lit - () - (Right - (Plain - "paragraph")) - , Lit - () - (Right - (Plain "that")) - , Lit - () - (Right - (Plain "will")) - , Lit - () - (Right - (Plain "split")) - , Lit - () - (Right - (Plain "onto")) - , Lit - () - (Right - (Plain - "multiple")) - , Lit - () - (Right - (Plain "lines,")) - , Lit - () - (Right - (Plain "such")) - , Lit - () - (Right - (Plain "that")) - , Lit - () - (Right - (Plain "this")) - , Lit - () - (Right - (Plain "row")) - , Lit - () - (Right - (Plain - "occupies")) - , Lit - () - (Right - (Plain - "multiple")) - , Lit - () - (Right - (Plain "lines")) - , Lit - () - (Right - (Plain "in")) - , Lit - () - (Right - (Plain "the")) - , Lit - () - (Right - (Plain - "rendered")) - , Lit - () - (Right - (Plain "table.")) - ]) - ] - , [ Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain "Some")) - , Lit - () - (Right - (Plain "text")) - ]) - , Wrap - () - (Annotated.Append - () - [ Lit - () - (Right - (Plain "More")) - , Lit - () - (Right - (Plain "text")) - ]) - , Wrap - () - (Lit - () - (Right - (Plain "Zounds!"))) - ] - ])) - ])))) - ]) - -``` diff --git a/unison-src/transcripts/builtins-merge.md b/unison-src/transcripts/builtins-merge.md deleted file mode 100644 index 28bfb426ca..0000000000 --- a/unison-src/transcripts/builtins-merge.md +++ /dev/null @@ -1,6 +0,0 @@ -The `builtins.merge` command adds the known builtins to a `builtin` subnamespace within the current namespace. - -```ucm -.tmp> builtins.merge -.tmp> ls builtin -``` diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md deleted file mode 100644 index 7bcf4910ec..0000000000 --- a/unison-src/transcripts/builtins-merge.output.md +++ /dev/null @@ -1,93 +0,0 @@ -The `builtins.merge` command adds the known builtins to a `builtin` subnamespace within the current namespace. - -```ucm - ☝️ The namespace .tmp is empty. - -.tmp> builtins.merge - - Done. - -.tmp> ls builtin - - 1. Any (builtin type) - 2. Any/ (2 terms) - 3. Boolean (builtin type) - 4. Boolean/ (1 term) - 5. Bytes (builtin type) - 6. Bytes/ (34 terms) - 7. Char (builtin type) - 8. Char/ (22 terms, 1 type) - 9. ClientSockAddr (builtin type) - 10. Code (builtin type) - 11. Code/ (9 terms) - 12. Debug/ (3 terms) - 13. Doc (type) - 14. Doc/ (6 terms) - 15. Either (type) - 16. Either/ (2 terms) - 17. Exception (type) - 18. Exception/ (1 term) - 19. Float (builtin type) - 20. Float/ (38 terms) - 21. Handle/ (1 term) - 22. ImmutableArray (builtin type) - 23. ImmutableArray/ (3 terms) - 24. ImmutableByteArray (builtin type) - 25. ImmutableByteArray/ (8 terms) - 26. Int (builtin type) - 27. Int/ (31 terms) - 28. IsPropagated (type) - 29. IsPropagated/ (1 term) - 30. IsTest (type) - 31. IsTest/ (1 term) - 32. Link (type) - 33. Link/ (3 terms, 2 types) - 34. List (builtin type) - 35. List/ (10 terms) - 36. ListenSocket (builtin type) - 37. MutableArray (builtin type) - 38. MutableArray/ (6 terms) - 39. MutableByteArray (builtin type) - 40. MutableByteArray/ (14 terms) - 41. Nat (builtin type) - 42. Nat/ (28 terms) - 43. Optional (type) - 44. Optional/ (2 terms) - 45. Pattern (builtin type) - 46. Pattern/ (9 terms) - 47. Ref (builtin type) - 48. Ref/ (2 terms) - 49. Request (builtin type) - 50. RewriteCase (type) - 51. RewriteCase/ (1 term) - 52. RewriteSignature (type) - 53. RewriteSignature/ (1 term) - 54. RewriteTerm (type) - 55. RewriteTerm/ (1 term) - 56. Rewrites (type) - 57. Rewrites/ (1 term) - 58. Scope (builtin type) - 59. Scope/ (6 terms) - 60. SeqView (type) - 61. SeqView/ (2 terms) - 62. Socket/ (1 term) - 63. Test/ (2 terms, 1 type) - 64. Text (builtin type) - 65. Text/ (34 terms) - 66. ThreadId/ (1 term) - 67. Tuple (type) - 68. Tuple/ (1 term) - 69. UDPSocket (builtin type) - 70. Unit (type) - 71. Unit/ (1 term) - 72. Universal/ (7 terms) - 73. Value (builtin type) - 74. Value/ (5 terms) - 75. bug (a -> b) - 76. crypto/ (17 terms, 2 types) - 77. io2/ (146 terms, 32 types) - 78. metadata/ (2 terms) - 79. todo (a -> b) - 80. unsafe/ (1 term) - -``` diff --git a/unison-src/transcripts/builtins.md b/unison-src/transcripts/builtins.md deleted file mode 100644 index ab854be39d..0000000000 --- a/unison-src/transcripts/builtins.md +++ /dev/null @@ -1,462 +0,0 @@ -# Unit tests for builtin functions - -```ucm:hide -.> builtins.mergeio -.> load unison-src/transcripts-using-base/base.u -.> add -``` - -This transcript defines unit tests for builtin functions. There's a single `.> test` execution at the end that will fail the transcript with a nice report if any of the tests fail. - -## `Int` functions - -```unison:hide -use Int - --- used for some take/drop tests later -bigN = Nat.shiftLeft 1 63 - --- Note: you can make the tests more fine-grained if you --- want to be able to tell which one is failing -test> Int.tests.arithmetic = - checks [ - eq (+1 + +1) +2, - +10 - +4 == +6, - eq (+11 * +6) +66, - eq (+11 * +6) +66, - +10 / +3 == +3, - +10 / +5 == +2, - mod +10 +3 == +1, - mod +10 +2 == +0, - mod -13 +3 == +2, - mod -13 -3 == -1, - mod -13 -5 == -3, - mod -13 +5 == +2, - negate +99 == -99, - increment +99 == +100, - not (isEven +99), - isEven +100, - isOdd +105, - not (isOdd +108), - signum +99 == +1, - signum -3949 == -1, - signum +0 == +0, - gt +42 -1, - lt +42 +1000, - lteq +43 +43, - lteq +43 +44, - gteq +43 +43, - gteq +43 +41 - ] - -test> Int.tests.bitTwiddling = - checks [ - and +5 +4 == +4, - and +5 +1 == +1, - or +4 +1 == +5, - xor +5 +1 == +4, - complement -1 == +0, - popCount +1 == 1, - popCount +2 == 1, - popCount +4 == 1, - popCount +5 == 2, - popCount -1 == 64, - leadingZeros +1 == 63, - trailingZeros +1 == 0, - leadingZeros +2 == 62, - trailingZeros +2 == 1, - pow +2 6 == +64, - shiftLeft +1 6 == +64, - shiftRight +64 6 == +1 - ] - -test> Int.tests.conversions = - checks [ - truncate0 -2438344 == 0, - truncate0 +999 == 999, - toText +0 == "0", - toText +10 == "10", - toText -1039 == "-1039", - fromText "+0" == Some +0, - fromText "a8f9djasdlfkj" == None, - fromText "3940" == Some +3940, - fromText "1000000000000000000000000000" == None, - fromText "-1000000000000000000000000000" == None, - toFloat +9394 == 9394.0, - toFloat -20349 == -20349.0 - ] -``` - -```ucm:hide -.> add -``` - -## `Nat` functions - -```unison:hide -use Nat - -test> Nat.tests.arithmetic = - checks [ - eq (1 + 1) 2, - drop 10 4 == 6, - sub 10 12 == -2, - eq (11 * 6) 66, - 10 / 3 == 3, - 10 / 5 == 2, - mod 10 3 == 1, - mod 10 2 == 0, - 18446744073709551615 / 2 == 9223372036854775807, - mod 18446744073709551615 2 == 1, - increment 99 == 100, - not (isEven 99), - isEven 100, - isOdd 105, - not (isOdd 108), - gt 42 1, - lt 42 1000, - lteq 43 43, - lteq 43 44, - gteq 43 43, - gteq 43 41, - ] - -test> Nat.tests.bitTwiddling = - checks [ - and 5 4 == 4, - and 5 1 == 1, - or 4 1 == 5, - xor 5 1 == 4, - complement (complement 0) == 0, - popCount 1 == 1, - popCount 2 == 1, - popCount 4 == 1, - popCount 5 == 2, - popCount (complement 0) == 64, - leadingZeros 1 == 63, - trailingZeros 1 == 0, - leadingZeros 2 == 62, - trailingZeros 2 == 1, - pow 2 6 == 64, - shiftLeft 1 6 == 64, - shiftRight 64 6 == 1 - ] - -test> Nat.tests.conversions = - checks [ - toFloat 2438344 == 2438344.0, - toFloat 0 == 0.0, - toText 0 == "0", - toText 32939 == "32939", - toText 10 == "10", - fromText "ooga" == None, - fromText "90" == Some 90, - fromText "-1" == None, - fromText "100000000000000000000000000" == None, - unsnoc "abc" == Some ("ab", ?c), - uncons "abc" == Some (?a, "bc"), - unsnoc "" == None, - uncons "" == None, - Text.fromCharList (Text.toCharList "abc") == "abc", - Bytes.fromList (Bytes.toList 0xsACE0BA5E) == 0xsACE0BA5E - ] -``` - -```ucm:hide -.> add -``` - -## `Boolean` functions -```unison:hide -test> Boolean.tests.orTable = - checks [ - true || true == true, - true || false == true, - false || true == true, - false || false == false - ] -test> Boolean.tests.andTable = - checks [ - true && true == true, - false && true == false, - true && false == false, - false && false == false - ] -test> Boolean.tests.notTable = - checks [ - not true == false, - not false == true - ] -``` - -```ucm:hide -.> add -``` - -## `Text` functions - -```unison:hide -test> Text.tests.takeDropAppend = - checks [ - "yabba" ++ "dabba" == "yabbadabba", - Text.take 0 "yabba" == "", - Text.take 2 "yabba" == "ya", - Text.take 99 "yabba" == "yabba", - Text.drop 0 "yabba" == "yabba", - Text.drop 2 "yabba" == "bba", - Text.drop 99 "yabba" == "", - Text.take bigN "yabba" == "yabba", - Text.drop bigN "yabba" == "" - ] - -test> Text.tests.repeat = - checks [ - Text.repeat 4 "o" == "oooo", - Text.repeat 0 "o" == "" - ] - -test> Text.tests.alignment = - checks [ - Text.alignLeftWith 5 ?\s "a" == "a ", - Text.alignRightWith 5 ?_ "ababa" == "ababa", - Text.alignRightWith 5 ?_ "ab" == "___ab" - ] - -test> Text.tests.literalsEq = checks [":)" == ":)"] - -test> Text.tests.patterns = - use Pattern many or run isMatch capture join replicate - use Text.patterns literal digit letter anyChar space punctuation notCharIn charIn charRange notCharRange eof - l = literal - checks [ - run digit "1abc" == Some ([], "abc"), - run (capture (many digit)) "11234abc" == Some (["11234"], "abc"), - run (many letter) "abc11234abc" == Some ([], "11234abc"), - run (join [many space, capture (many anyChar)]) " abc123" == Some (["abc123"], ""), - run (many punctuation) "!!!!,,,..." == Some ([], ""), - run (charIn [?0,?1]) "0" == Some ([], ""), - run (notCharIn [?0,?1]) "0" == None, - run (many (notCharIn [?0,?1])) "asjdfskdfjlskdjflskdjf011" == Some ([], "011"), - run (capture (many (charRange ?a ?z))) "hi123" == Some (["hi"], "123"), - run (capture (many (notCharRange ?, ?,))) "abc123," == Some (["abc123"], ","), - run (capture (many (notCharIn [?,,]))) "abracadabra,123" == Some (["abracadabra"], ",123"), - run (capture (many (or digit letter))) "11234abc,remainder" == Some (["11234abc"], ",remainder"), - run (capture (replicate 1 5 (or digit letter))) "1a2ba aaa" == Some (["1a2ba"], " aaa"), - run (captureAs "foo" (many (or digit letter))) "11234abc,remainder" == Some (["foo"], ",remainder"), - run (join [(captureAs "foo" (many digit)), captureAs "bar" (many letter)]) "11234abc,remainder" == Some (["foo", "bar"], ",remainder"), - -- Regression test for: https://github.com/unisonweb/unison/issues/3530 - run (capture (replicate 0 1 (join [literal "a", literal "b"]))) "ac" == Some ([""], "ac"), - isMatch (join [many letter, eof]) "aaaaabbbb" == true, - isMatch (join [many letter, eof]) "aaaaabbbb1" == false, - isMatch (join [l "abra", many (l "cadabra")]) "abracadabracadabra" == true, - - ] - - -test> Text.tests.indexOf = - haystack = "01020304" ++ "05060708" ++ "090a0b0c01" - needle1 = "01" - needle2 = "02" - needle3 = "0304" - needle4 = "05" - needle5 = "0405" - needle6 = "0c" - needle7 = haystack - needle8 = "lopez" - needle9 = "" - checks [ - Text.indexOf needle1 haystack == Some 0, - Text.indexOf needle2 haystack == Some 2, - Text.indexOf needle3 haystack == Some 4, - Text.indexOf needle4 haystack == Some 8, - Text.indexOf needle5 haystack == Some 6, - Text.indexOf needle6 haystack == Some 22, - Text.indexOf needle7 haystack == Some 0, - Text.indexOf needle8 haystack == None, - Text.indexOf needle9 haystack == Some 0, - ] - -test> Text.tests.indexOfEmoji = - haystack = "clap 👏 your 👏 hands 👏 if 👏 you 👏 love 👏 unison" - needle1 = "👏" - needle2 = "👏 " - checks [ - Text.indexOf needle1 haystack == Some 5, - Text.indexOf needle2 haystack == Some 5, - ] - -``` - -```ucm:hide -.> add -``` - -## `Bytes` functions - -```unison:hide -test> Bytes.tests.at = - bs = Bytes.fromList [77, 13, 12] - checks [ - Bytes.at 1 bs == Some 13, - Bytes.at 0 bs == Some 77, - Bytes.at 99 bs == None, - Bytes.take bigN bs == bs, - Bytes.drop bigN bs == empty - ] - -test> Bytes.tests.compression = - roundTrip b = - (Bytes.zlib.decompress (Bytes.zlib.compress b) == Right b) - && (Bytes.gzip.decompress (Bytes.gzip.compress b) == Right b) - - checks [ - roundTrip 0xs2093487509823745709827345789023457892345, - roundTrip 0xs00000000000000000000000000000000000000000000, - roundTrip 0xs, - roundTrip 0xs11111111111111111111111111, - roundTrip 0xsffffffffffffffffffffffffffffff, - roundTrip 0xs222222222fffffffffffffffffffffffffffffff, - -- these fail due to bad checksums and/or headers - isLeft (zlib.decompress 0xs2093487509823745709827345789023457892345), - isLeft (gzip.decompress 0xs201209348750982374593939393939709827345789023457892345) - ] - -test> Bytes.tests.fromBase64UrlUnpadded = - checks [Exception.catch - '(fromUtf8 - (raiseMessage () (Bytes.fromBase64UrlUnpadded (toUtf8 "aGVsbG8gd29ybGQ")))) == Right "hello world" - , isLeft (Bytes.fromBase64UrlUnpadded (toUtf8 "aGVsbG8gd29ybGQ="))] - -test> Bytes.tests.indexOf = - haystack = 0xs01020304 ++ 0xs05060708 ++ 0xs090a0b0c01 - needle1 = 0xs01 - needle2 = 0xs02 - needle3 = 0xs0304 - needle4 = 0xs05 - needle5 = 0xs0405 - needle6 = 0xs0c - needle7 = haystack - needle8 = 0xsffffff - checks [ - Bytes.indexOf needle1 haystack == Some 0, - Bytes.indexOf needle2 haystack == Some 1, - Bytes.indexOf needle3 haystack == Some 2, - Bytes.indexOf needle4 haystack == Some 4, - Bytes.indexOf needle5 haystack == Some 3, - Bytes.indexOf needle6 haystack == Some 11, - Bytes.indexOf needle7 haystack == Some 0, - Bytes.indexOf needle8 haystack == None, - - ] - -``` - -```ucm:hide -.> add -``` - -## `List` comparison - -```unison:hide -test> checks [ - compare [] [1,2,3] == -1, - compare [1,2,3] [1,2,3,4] == -1, - compare [1,2,3,4] [1,2,3] == +1, - compare [1,2,3] [1,2,3] == +0, - compare [3] [1,2,3] == +1, - compare [1,2,3] [1,2,4] == -1, - compare [1,2,2] [1,2,1,2] == +1, - compare [1,2,3,4] [3,2,1] == -1 - ] -``` - -```ucm:hide -.> add -``` - -Other list functions -```unison:hide -test> checks [ - List.take bigN [1,2,3] == [1,2,3], - List.drop bigN [1,2,3] == [] - ] -``` - -## `Any` functions - -```unison -> [Any "hi", Any (41 + 1)] - -test> Any.test1 = checks [(Any "hi" == Any "hi")] -test> Any.test2 = checks [(not (Any "hi" == Any 42))] -``` - -```ucm:hide -.> add -``` - -## Sandboxing functions - -```unison -openFile1 t = openFile t -openFile2 t = openFile1 t - -validateSandboxedSimpl ok v = - match Value.validateSandboxed ok v with - Right [] -> true - _ -> false - -openFiles = - [ not (validateSandboxed [] openFile) - , not (validateSandboxed [] openFile1) - , not (validateSandboxed [] openFile2) - ] - -test> Sandbox.test1 = checks [validateSandboxed [] "hello"] -test> Sandbox.test2 = checks openFiles -test> Sandbox.test3 = checks [validateSandboxed [termLink openFile.impl] -openFile] -``` - -```ucm:hide -.> add -``` - -```unison -openFilesIO = do - checks - [ not (validateSandboxedSimpl [] (value openFile)) - , not (validateSandboxedSimpl [] (value openFile1)) - , not (validateSandboxedSimpl [] (value openFile2)) - , sandboxLinks (termLink openFile) - == sandboxLinks (termLink openFile1) - , sandboxLinks (termLink openFile1) - == sandboxLinks (termLink openFile2) - ] -``` - -```ucm -.> add -.> io.test openFilesIO -``` - -## Universal hash functions - -Just exercises the function - -```unison -> Universal.murmurHash 1 -test> Universal.murmurHash.tests = checks [Universal.murmurHash [1,2,3] == Universal.murmurHash [1,2,3]] -``` - -```ucm:hide -.> add -``` - -## Run the tests - -Now that all the tests have been added to the codebase, let's view the test report. This will fail the transcript (with a nice message) if any of the tests are failing. - -```ucm -.> test -``` diff --git a/unison-src/transcripts/builtins.output.md b/unison-src/transcripts/builtins.output.md deleted file mode 100644 index 4d3089d35e..0000000000 --- a/unison-src/transcripts/builtins.output.md +++ /dev/null @@ -1,574 +0,0 @@ -# Unit tests for builtin functions - -This transcript defines unit tests for builtin functions. There's a single `.> test` execution at the end that will fail the transcript with a nice report if any of the tests fail. - -## `Int` functions - -```unison -use Int - --- used for some take/drop tests later -bigN = Nat.shiftLeft 1 63 - --- Note: you can make the tests more fine-grained if you --- want to be able to tell which one is failing -test> Int.tests.arithmetic = - checks [ - eq (+1 + +1) +2, - +10 - +4 == +6, - eq (+11 * +6) +66, - eq (+11 * +6) +66, - +10 / +3 == +3, - +10 / +5 == +2, - mod +10 +3 == +1, - mod +10 +2 == +0, - mod -13 +3 == +2, - mod -13 -3 == -1, - mod -13 -5 == -3, - mod -13 +5 == +2, - negate +99 == -99, - increment +99 == +100, - not (isEven +99), - isEven +100, - isOdd +105, - not (isOdd +108), - signum +99 == +1, - signum -3949 == -1, - signum +0 == +0, - gt +42 -1, - lt +42 +1000, - lteq +43 +43, - lteq +43 +44, - gteq +43 +43, - gteq +43 +41 - ] - -test> Int.tests.bitTwiddling = - checks [ - and +5 +4 == +4, - and +5 +1 == +1, - or +4 +1 == +5, - xor +5 +1 == +4, - complement -1 == +0, - popCount +1 == 1, - popCount +2 == 1, - popCount +4 == 1, - popCount +5 == 2, - popCount -1 == 64, - leadingZeros +1 == 63, - trailingZeros +1 == 0, - leadingZeros +2 == 62, - trailingZeros +2 == 1, - pow +2 6 == +64, - shiftLeft +1 6 == +64, - shiftRight +64 6 == +1 - ] - -test> Int.tests.conversions = - checks [ - truncate0 -2438344 == 0, - truncate0 +999 == 999, - toText +0 == "0", - toText +10 == "10", - toText -1039 == "-1039", - fromText "+0" == Some +0, - fromText "a8f9djasdlfkj" == None, - fromText "3940" == Some +3940, - fromText "1000000000000000000000000000" == None, - fromText "-1000000000000000000000000000" == None, - toFloat +9394 == 9394.0, - toFloat -20349 == -20349.0 - ] -``` - -## `Nat` functions - -```unison -use Nat - -test> Nat.tests.arithmetic = - checks [ - eq (1 + 1) 2, - drop 10 4 == 6, - sub 10 12 == -2, - eq (11 * 6) 66, - 10 / 3 == 3, - 10 / 5 == 2, - mod 10 3 == 1, - mod 10 2 == 0, - 18446744073709551615 / 2 == 9223372036854775807, - mod 18446744073709551615 2 == 1, - increment 99 == 100, - not (isEven 99), - isEven 100, - isOdd 105, - not (isOdd 108), - gt 42 1, - lt 42 1000, - lteq 43 43, - lteq 43 44, - gteq 43 43, - gteq 43 41, - ] - -test> Nat.tests.bitTwiddling = - checks [ - and 5 4 == 4, - and 5 1 == 1, - or 4 1 == 5, - xor 5 1 == 4, - complement (complement 0) == 0, - popCount 1 == 1, - popCount 2 == 1, - popCount 4 == 1, - popCount 5 == 2, - popCount (complement 0) == 64, - leadingZeros 1 == 63, - trailingZeros 1 == 0, - leadingZeros 2 == 62, - trailingZeros 2 == 1, - pow 2 6 == 64, - shiftLeft 1 6 == 64, - shiftRight 64 6 == 1 - ] - -test> Nat.tests.conversions = - checks [ - toFloat 2438344 == 2438344.0, - toFloat 0 == 0.0, - toText 0 == "0", - toText 32939 == "32939", - toText 10 == "10", - fromText "ooga" == None, - fromText "90" == Some 90, - fromText "-1" == None, - fromText "100000000000000000000000000" == None, - unsnoc "abc" == Some ("ab", ?c), - uncons "abc" == Some (?a, "bc"), - unsnoc "" == None, - uncons "" == None, - Text.fromCharList (Text.toCharList "abc") == "abc", - Bytes.fromList (Bytes.toList 0xsACE0BA5E) == 0xsACE0BA5E - ] -``` - -## `Boolean` functions -```unison -test> Boolean.tests.orTable = - checks [ - true || true == true, - true || false == true, - false || true == true, - false || false == false - ] -test> Boolean.tests.andTable = - checks [ - true && true == true, - false && true == false, - true && false == false, - false && false == false - ] -test> Boolean.tests.notTable = - checks [ - not true == false, - not false == true - ] -``` - -## `Text` functions - -```unison -test> Text.tests.takeDropAppend = - checks [ - "yabba" ++ "dabba" == "yabbadabba", - Text.take 0 "yabba" == "", - Text.take 2 "yabba" == "ya", - Text.take 99 "yabba" == "yabba", - Text.drop 0 "yabba" == "yabba", - Text.drop 2 "yabba" == "bba", - Text.drop 99 "yabba" == "", - Text.take bigN "yabba" == "yabba", - Text.drop bigN "yabba" == "" - ] - -test> Text.tests.repeat = - checks [ - Text.repeat 4 "o" == "oooo", - Text.repeat 0 "o" == "" - ] - -test> Text.tests.alignment = - checks [ - Text.alignLeftWith 5 ?\s "a" == "a ", - Text.alignRightWith 5 ?_ "ababa" == "ababa", - Text.alignRightWith 5 ?_ "ab" == "___ab" - ] - -test> Text.tests.literalsEq = checks [":)" == ":)"] - -test> Text.tests.patterns = - use Pattern many or run isMatch capture join replicate - use Text.patterns literal digit letter anyChar space punctuation notCharIn charIn charRange notCharRange eof - l = literal - checks [ - run digit "1abc" == Some ([], "abc"), - run (capture (many digit)) "11234abc" == Some (["11234"], "abc"), - run (many letter) "abc11234abc" == Some ([], "11234abc"), - run (join [many space, capture (many anyChar)]) " abc123" == Some (["abc123"], ""), - run (many punctuation) "!!!!,,,..." == Some ([], ""), - run (charIn [?0,?1]) "0" == Some ([], ""), - run (notCharIn [?0,?1]) "0" == None, - run (many (notCharIn [?0,?1])) "asjdfskdfjlskdjflskdjf011" == Some ([], "011"), - run (capture (many (charRange ?a ?z))) "hi123" == Some (["hi"], "123"), - run (capture (many (notCharRange ?, ?,))) "abc123," == Some (["abc123"], ","), - run (capture (many (notCharIn [?,,]))) "abracadabra,123" == Some (["abracadabra"], ",123"), - run (capture (many (or digit letter))) "11234abc,remainder" == Some (["11234abc"], ",remainder"), - run (capture (replicate 1 5 (or digit letter))) "1a2ba aaa" == Some (["1a2ba"], " aaa"), - run (captureAs "foo" (many (or digit letter))) "11234abc,remainder" == Some (["foo"], ",remainder"), - run (join [(captureAs "foo" (many digit)), captureAs "bar" (many letter)]) "11234abc,remainder" == Some (["foo", "bar"], ",remainder"), - -- Regression test for: https://github.com/unisonweb/unison/issues/3530 - run (capture (replicate 0 1 (join [literal "a", literal "b"]))) "ac" == Some ([""], "ac"), - isMatch (join [many letter, eof]) "aaaaabbbb" == true, - isMatch (join [many letter, eof]) "aaaaabbbb1" == false, - isMatch (join [l "abra", many (l "cadabra")]) "abracadabracadabra" == true, - - ] - - -test> Text.tests.indexOf = - haystack = "01020304" ++ "05060708" ++ "090a0b0c01" - needle1 = "01" - needle2 = "02" - needle3 = "0304" - needle4 = "05" - needle5 = "0405" - needle6 = "0c" - needle7 = haystack - needle8 = "lopez" - needle9 = "" - checks [ - Text.indexOf needle1 haystack == Some 0, - Text.indexOf needle2 haystack == Some 2, - Text.indexOf needle3 haystack == Some 4, - Text.indexOf needle4 haystack == Some 8, - Text.indexOf needle5 haystack == Some 6, - Text.indexOf needle6 haystack == Some 22, - Text.indexOf needle7 haystack == Some 0, - Text.indexOf needle8 haystack == None, - Text.indexOf needle9 haystack == Some 0, - ] - -test> Text.tests.indexOfEmoji = - haystack = "clap 👏 your 👏 hands 👏 if 👏 you 👏 love 👏 unison" - needle1 = "👏" - needle2 = "👏 " - checks [ - Text.indexOf needle1 haystack == Some 5, - Text.indexOf needle2 haystack == Some 5, - ] - -``` - -## `Bytes` functions - -```unison -test> Bytes.tests.at = - bs = Bytes.fromList [77, 13, 12] - checks [ - Bytes.at 1 bs == Some 13, - Bytes.at 0 bs == Some 77, - Bytes.at 99 bs == None, - Bytes.take bigN bs == bs, - Bytes.drop bigN bs == empty - ] - -test> Bytes.tests.compression = - roundTrip b = - (Bytes.zlib.decompress (Bytes.zlib.compress b) == Right b) - && (Bytes.gzip.decompress (Bytes.gzip.compress b) == Right b) - - checks [ - roundTrip 0xs2093487509823745709827345789023457892345, - roundTrip 0xs00000000000000000000000000000000000000000000, - roundTrip 0xs, - roundTrip 0xs11111111111111111111111111, - roundTrip 0xsffffffffffffffffffffffffffffff, - roundTrip 0xs222222222fffffffffffffffffffffffffffffff, - -- these fail due to bad checksums and/or headers - isLeft (zlib.decompress 0xs2093487509823745709827345789023457892345), - isLeft (gzip.decompress 0xs201209348750982374593939393939709827345789023457892345) - ] - -test> Bytes.tests.fromBase64UrlUnpadded = - checks [Exception.catch - '(fromUtf8 - (raiseMessage () (Bytes.fromBase64UrlUnpadded (toUtf8 "aGVsbG8gd29ybGQ")))) == Right "hello world" - , isLeft (Bytes.fromBase64UrlUnpadded (toUtf8 "aGVsbG8gd29ybGQ="))] - -test> Bytes.tests.indexOf = - haystack = 0xs01020304 ++ 0xs05060708 ++ 0xs090a0b0c01 - needle1 = 0xs01 - needle2 = 0xs02 - needle3 = 0xs0304 - needle4 = 0xs05 - needle5 = 0xs0405 - needle6 = 0xs0c - needle7 = haystack - needle8 = 0xsffffff - checks [ - Bytes.indexOf needle1 haystack == Some 0, - Bytes.indexOf needle2 haystack == Some 1, - Bytes.indexOf needle3 haystack == Some 2, - Bytes.indexOf needle4 haystack == Some 4, - Bytes.indexOf needle5 haystack == Some 3, - Bytes.indexOf needle6 haystack == Some 11, - Bytes.indexOf needle7 haystack == Some 0, - Bytes.indexOf needle8 haystack == None, - - ] - -``` - -## `List` comparison - -```unison -test> checks [ - compare [] [1,2,3] == -1, - compare [1,2,3] [1,2,3,4] == -1, - compare [1,2,3,4] [1,2,3] == +1, - compare [1,2,3] [1,2,3] == +0, - compare [3] [1,2,3] == +1, - compare [1,2,3] [1,2,4] == -1, - compare [1,2,2] [1,2,1,2] == +1, - compare [1,2,3,4] [3,2,1] == -1 - ] -``` - -Other list functions -```unison -test> checks [ - List.take bigN [1,2,3] == [1,2,3], - List.drop bigN [1,2,3] == [] - ] -``` - -## `Any` functions - -```unison -> [Any "hi", Any (41 + 1)] - -test> Any.test1 = checks [(Any "hi" == Any "hi")] -test> Any.test2 = checks [(not (Any "hi" == Any 42))] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - Any.test1 : [Result] - Any.test2 : [Result] - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > [Any "hi", Any (41 + 1)] - ⧩ - [Any "hi", Any 42] - - 3 | test> Any.test1 = checks [(Any "hi" == Any "hi")] - - ✅ Passed Passed - - 4 | test> Any.test2 = checks [(not (Any "hi" == Any 42))] - - ✅ Passed Passed - -``` -## Sandboxing functions - -```unison -openFile1 t = openFile t -openFile2 t = openFile1 t - -validateSandboxedSimpl ok v = - match Value.validateSandboxed ok v with - Right [] -> true - _ -> false - -openFiles = - [ not (validateSandboxed [] openFile) - , not (validateSandboxed [] openFile1) - , not (validateSandboxed [] openFile2) - ] - -test> Sandbox.test1 = checks [validateSandboxed [] "hello"] -test> Sandbox.test2 = checks openFiles -test> Sandbox.test3 = checks [validateSandboxed [termLink openFile.impl] -openFile] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - Sandbox.test1 : [Result] - Sandbox.test2 : [Result] - Sandbox.test3 : [Result] - openFile1 : Text - -> FileMode - ->{IO, Exception} Handle - openFile2 : Text - -> FileMode - ->{IO, Exception} Handle - openFiles : [Boolean] - validateSandboxedSimpl : [Link.Term] - -> Value - ->{IO} Boolean - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 15 | test> Sandbox.test1 = checks [validateSandboxed [] "hello"] - - ✅ Passed Passed - - 16 | test> Sandbox.test2 = checks openFiles - - ✅ Passed Passed - - 17 | test> Sandbox.test3 = checks [validateSandboxed [termLink openFile.impl] - - ✅ Passed Passed - -``` -```unison -openFilesIO = do - checks - [ not (validateSandboxedSimpl [] (value openFile)) - , not (validateSandboxedSimpl [] (value openFile1)) - , not (validateSandboxedSimpl [] (value openFile2)) - , sandboxLinks (termLink openFile) - == sandboxLinks (termLink openFile1) - , sandboxLinks (termLink openFile1) - == sandboxLinks (termLink openFile2) - ] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - openFilesIO : '{IO} [Result] - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - openFilesIO : '{IO} [Result] - -.> io.test openFilesIO - - New test results: - - ◉ openFilesIO Passed - - ✅ 1 test(s) passing - - Tip: Use view openFilesIO to view the source of a test. - -``` -## Universal hash functions - -Just exercises the function - -```unison -> Universal.murmurHash 1 -test> Universal.murmurHash.tests = checks [Universal.murmurHash [1,2,3] == Universal.murmurHash [1,2,3]] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - Universal.murmurHash.tests : [Result] - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > Universal.murmurHash 1 - ⧩ - 1208954131003843843 - - 2 | test> Universal.murmurHash.tests = checks [Universal.murmurHash [1,2,3] == Universal.murmurHash [1,2,3]] - - ✅ Passed Passed - -``` -## Run the tests - -Now that all the tests have been added to the codebase, let's view the test report. This will fail the transcript (with a nice message) if any of the tests are failing. - -```ucm -.> test - - Cached test results (`help testcache` to learn more) - - ◉ Any.test1 Passed - ◉ Any.test2 Passed - ◉ Boolean.tests.andTable Passed - ◉ Boolean.tests.notTable Passed - ◉ Boolean.tests.orTable Passed - ◉ Bytes.tests.at Passed - ◉ Bytes.tests.compression Passed - ◉ Bytes.tests.fromBase64UrlUnpadded Passed - ◉ Bytes.tests.indexOf Passed - ◉ Int.tests.arithmetic Passed - ◉ Int.tests.bitTwiddling Passed - ◉ Int.tests.conversions Passed - ◉ Nat.tests.arithmetic Passed - ◉ Nat.tests.bitTwiddling Passed - ◉ Nat.tests.conversions Passed - ◉ Sandbox.test1 Passed - ◉ Sandbox.test2 Passed - ◉ Sandbox.test3 Passed - ◉ test.rtjqan7bcs Passed - ◉ Text.tests.alignment Passed - ◉ Text.tests.indexOf Passed - ◉ Text.tests.indexOfEmoji Passed - ◉ Text.tests.literalsEq Passed - ◉ Text.tests.patterns Passed - ◉ Text.tests.repeat Passed - ◉ Text.tests.takeDropAppend Passed - ◉ Universal.murmurHash.tests Passed - - ✅ 27 test(s) passing - - Tip: Use view Any.test1 to view the source of a test. - -``` diff --git a/unison-src/transcripts/bytesFromList.md b/unison-src/transcripts/bytesFromList.md deleted file mode 100644 index 9da15329f3..0000000000 --- a/unison-src/transcripts/bytesFromList.md +++ /dev/null @@ -1,11 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -This should render as `Bytes.fromList [1,2,3,4]`, not `##Bytes.fromSequence [1,2,3,4]`: - -```unison -> Bytes.fromList [1,2,3,4] -``` - diff --git a/unison-src/transcripts/bytesFromList.output.md b/unison-src/transcripts/bytesFromList.output.md deleted file mode 100644 index 7d28cfc07a..0000000000 --- a/unison-src/transcripts/bytesFromList.output.md +++ /dev/null @@ -1,23 +0,0 @@ - -This should render as `Bytes.fromList [1,2,3,4]`, not `##Bytes.fromSequence [1,2,3,4]`: - -```unison -> Bytes.fromList [1,2,3,4] -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > Bytes.fromList [1,2,3,4] - ⧩ - 0xs01020304 - -``` diff --git a/unison-src/transcripts/check763.md b/unison-src/transcripts/check763.md deleted file mode 100644 index 3bb162b344..0000000000 --- a/unison-src/transcripts/check763.md +++ /dev/null @@ -1,17 +0,0 @@ -Regression test for https://github.com/unisonweb/unison/issues/763 - -```ucm:hide -.> builtins.merge -``` - -```unison -(+-+) : Nat -> Nat -> Nat -(+-+) x y = x * y -``` - -```ucm -.> add -.> move.term +-+ boppitybeep -.> move.term boppitybeep +-+ -``` - diff --git a/unison-src/transcripts/check763.output.md b/unison-src/transcripts/check763.output.md deleted file mode 100644 index b8421509d9..0000000000 --- a/unison-src/transcripts/check763.output.md +++ /dev/null @@ -1,36 +0,0 @@ -Regression test for https://github.com/unisonweb/unison/issues/763 - -```unison -(+-+) : Nat -> Nat -> Nat -(+-+) x y = x * y -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - +-+ : Nat -> Nat -> Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - +-+ : Nat -> Nat -> Nat - -.> move.term +-+ boppitybeep - - Done. - -.> move.term boppitybeep +-+ - - Done. - -``` diff --git a/unison-src/transcripts/check873.md b/unison-src/transcripts/check873.md deleted file mode 100644 index 7145186286..0000000000 --- a/unison-src/transcripts/check873.md +++ /dev/null @@ -1,17 +0,0 @@ -See [this ticket](https://github.com/unisonweb/unison/issues/873); the point being, this shouldn't crash the runtime. :) - -```ucm:hide -.> builtins.merge -``` - -```unison -(-) = builtin.Nat.sub -``` - -```ucm -.> add -``` - -```unison -baz x = x - 1 -``` diff --git a/unison-src/transcripts/check873.output.md b/unison-src/transcripts/check873.output.md deleted file mode 100644 index 289c592f30..0000000000 --- a/unison-src/transcripts/check873.output.md +++ /dev/null @@ -1,44 +0,0 @@ -See [this ticket](https://github.com/unisonweb/unison/issues/873); the point being, this shouldn't crash the runtime. :) - -```unison -(-) = builtin.Nat.sub -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - - : Nat -> Nat -> Int - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - - : Nat -> Nat -> Int - -``` -```unison -baz x = x - 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - baz : Nat -> Int - -``` diff --git a/unison-src/transcripts/child-namespace-history-merge.md b/unison-src/transcripts/child-namespace-history-merge.md deleted file mode 100644 index 6ed0e2400e..0000000000 --- a/unison-src/transcripts/child-namespace-history-merge.md +++ /dev/null @@ -1,99 +0,0 @@ -# Behaviour of namespace histories during a merge. - -Note: This is a descriptive test meant to capture the current behaviour of -branch histories during a merge. -It isn't prescriptive about how merges _should_ work with respect to child branches, -but I think we should at least notice if we change things by accident. - - -## Setting up some history - -```ucm:hide -.> builtins.merge -``` - -```unison:hide -parent.top = "top" -parent.child.thing = "parent.child.thing" -``` - -The child branch has a single history node representing the addition of `parent.child.thing`. - -```ucm -.> add -.> history parent.child -``` - -If we add another thing to the child namespace it should add another history node to both the child and parent. - -```unison:hide -parent.child.thing2 = "parent.child.thing2" -``` - -```ucm -.> add -.> history parent -.> history parent.child -``` - -## Forking off some history on a separate branch - -Now we fork the parent namespace to make some changes. - -```ucm -.> fork parent parent_fork -``` - -```unison:hide -parent_fork.child.thing3 = "parent_fork.child.thing3" -``` - -The child should have a new history node after adding `thing3` - -```ucm -.> add -.> history parent_fork.child -``` - -## Saving our parent state - -Split off two separate forks, one for testing squash merges, one for standard merges. - -```ucm:hide -.> fork parent parent_squash_base -.> fork parent parent_merge_base -``` - -## Squash merge - -For a squash merge, when I squash-merge back into parent, we expect `parent_fork.child.thing3` to be added. - -```ucm -.> merge.old.squash parent_fork parent_squash_base -.> history parent_squash_base -``` - -Notice that with the current behaviour, the history of `parent.child` is completely wiped out, containing nothing from the source OR destination. - -```ucm -.> history parent.child -.> history parent_fork.child -.> history parent_squash_base.child -``` - -## Standard merge - -For a standard merge, if I merge back into parent, we expect `parent_fork.child.thing3` to be added. - -```ucm -.> merge.old parent_fork parent_merge_base -.> history parent_merge_base -``` - -Child histories should also be *merged*. - -```ucm -.> history parent.child -.> history parent_fork.child -.> history parent_merge_base.child -``` diff --git a/unison-src/transcripts/child-namespace-history-merge.output.md b/unison-src/transcripts/child-namespace-history-merge.output.md deleted file mode 100644 index 18e080e093..0000000000 --- a/unison-src/transcripts/child-namespace-history-merge.output.md +++ /dev/null @@ -1,302 +0,0 @@ -# Behaviour of namespace histories during a merge. - -Note: This is a descriptive test meant to capture the current behaviour of -branch histories during a merge. -It isn't prescriptive about how merges _should_ work with respect to child branches, -but I think we should at least notice if we change things by accident. - - -## Setting up some history - -```unison -parent.top = "top" -parent.child.thing = "parent.child.thing" -``` - -The child branch has a single history node representing the addition of `parent.child.thing`. - -```ucm -.> add - - ⍟ I've added these definitions: - - parent.child.thing : Text - parent.top : Text - -.> history parent.child - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #0r73mam57g (start of history) - -``` -If we add another thing to the child namespace it should add another history node to both the child and parent. - -```unison -parent.child.thing2 = "parent.child.thing2" -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - parent.child.thing2 : Text - -.> history parent - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #2hv7t9lp40 - - + Adds / updates: - - child.thing2 - - □ 2. #i9lji1bli0 (start of history) - -.> history parent.child - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #ggnrs01131 - - + Adds / updates: - - thing2 - - □ 2. #0r73mam57g (start of history) - -``` -## Forking off some history on a separate branch - -Now we fork the parent namespace to make some changes. - -```ucm -.> fork parent parent_fork - - Done. - -``` -```unison -parent_fork.child.thing3 = "parent_fork.child.thing3" -``` - -The child should have a new history node after adding `thing3` - -```ucm -.> add - - ⍟ I've added these definitions: - - parent_fork.child.thing3 : Text - -.> history parent_fork.child - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #9rcfgbsp81 - - + Adds / updates: - - thing3 - - ⊙ 2. #ggnrs01131 - - + Adds / updates: - - thing2 - - □ 3. #0r73mam57g (start of history) - -``` -## Saving our parent state - -Split off two separate forks, one for testing squash merges, one for standard merges. - -## Squash merge - -For a squash merge, when I squash-merge back into parent, we expect `parent_fork.child.thing3` to be added. - -```ucm -.> merge.old.squash parent_fork parent_squash_base - - Here's what's changed in parent_squash_base after the merge: - - Added definitions: - - 1. child.thing3 : Text - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.> history parent_squash_base - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #594e0e1p39 - - + Adds / updates: - - child.thing3 - - ⊙ 2. #2hv7t9lp40 - - + Adds / updates: - - child.thing2 - - □ 3. #i9lji1bli0 (start of history) - -``` -Notice that with the current behaviour, the history of `parent.child` is completely wiped out, containing nothing from the source OR destination. - -```ucm -.> history parent.child - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #ggnrs01131 - - + Adds / updates: - - thing2 - - □ 2. #0r73mam57g (start of history) - -.> history parent_fork.child - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #9rcfgbsp81 - - + Adds / updates: - - thing3 - - ⊙ 2. #ggnrs01131 - - + Adds / updates: - - thing2 - - □ 3. #0r73mam57g (start of history) - -.> history parent_squash_base.child - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #19fd4mhpp4 (start of history) - -``` -## Standard merge - -For a standard merge, if I merge back into parent, we expect `parent_fork.child.thing3` to be added. - -```ucm -.> merge.old parent_fork parent_merge_base - - Here's what's changed in parent_merge_base after the merge: - - Added definitions: - - 1. child.thing3 : Text - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.> history parent_merge_base - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #mtn8sha7gd - - + Adds / updates: - - child.thing3 - - ⊙ 2. #2hv7t9lp40 - - + Adds / updates: - - child.thing2 - - □ 3. #i9lji1bli0 (start of history) - -``` -Child histories should also be *merged*. - -```ucm -.> history parent.child - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #ggnrs01131 - - + Adds / updates: - - thing2 - - □ 2. #0r73mam57g (start of history) - -.> history parent_fork.child - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #9rcfgbsp81 - - + Adds / updates: - - thing3 - - ⊙ 2. #ggnrs01131 - - + Adds / updates: - - thing2 - - □ 3. #0r73mam57g (start of history) - -.> history parent_merge_base.child - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #9rcfgbsp81 - - + Adds / updates: - - thing3 - - ⊙ 2. #ggnrs01131 - - + Adds / updates: - - thing2 - - □ 3. #0r73mam57g (start of history) - -``` diff --git a/unison-src/transcripts/constructor-applied-to-unit.md b/unison-src/transcripts/constructor-applied-to-unit.md deleted file mode 100644 index df1341aa5c..0000000000 --- a/unison-src/transcripts/constructor-applied-to-unit.md +++ /dev/null @@ -1,11 +0,0 @@ -```ucm:hide -.> alias.type ##Nat Nat -.> alias.term ##Any.Any Any -``` - -```unison -structural type Zoink a b c = Zoink a b c - -> Any () -> [ Zoink [0,1,2,3,4,5] [6,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,4,3] () ] -``` diff --git a/unison-src/transcripts/constructor-applied-to-unit.output.md b/unison-src/transcripts/constructor-applied-to-unit.output.md deleted file mode 100644 index 4acfdcd865..0000000000 --- a/unison-src/transcripts/constructor-applied-to-unit.output.md +++ /dev/null @@ -1,56 +0,0 @@ -```unison -structural type Zoink a b c = Zoink a b c - -> Any () -> [ Zoink [0,1,2,3,4,5] [6,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,4,3] () ] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type Zoink a b c - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 3 | > Any () - ⧩ - Any () - - 4 | > [ Zoink [0,1,2,3,4,5] [6,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,4,3] () ] - ⧩ - [ Zoink - [0, 1, 2, 3, 4, 5] - [ 6 - , 3 - , 3 - , 3 - , 3 - , 3 - , 3 - , 3 - , 3 - , 3 - , 3 - , 4 - , 4 - , 4 - , 4 - , 4 - , 4 - , 4 - , 4 - , 4 - , 3 - ] - () - ] - -``` diff --git a/unison-src/transcripts/contrabilities.md b/unison-src/transcripts/contrabilities.md deleted file mode 100644 index 795ec15566..0000000000 --- a/unison-src/transcripts/contrabilities.md +++ /dev/null @@ -1,8 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison -f : (() -> a) -> Nat -f x = 42 -``` diff --git a/unison-src/transcripts/contrabilities.output.md b/unison-src/transcripts/contrabilities.output.md deleted file mode 100644 index d8c725660c..0000000000 --- a/unison-src/transcripts/contrabilities.output.md +++ /dev/null @@ -1,18 +0,0 @@ -```unison -f : (() -> a) -> Nat -f x = 42 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - f : '{g} a -> Nat - -``` diff --git a/unison-src/transcripts/create-author.md b/unison-src/transcripts/create-author.md deleted file mode 100644 index d9a39c735f..0000000000 --- a/unison-src/transcripts/create-author.md +++ /dev/null @@ -1,10 +0,0 @@ -```ucm:hide -.> builtins.mergeio -``` - -Demonstrating `create.author`: - -```ucm -.foo> create.author alicecoder "Alice McGee" -.foo> view 2 -``` diff --git a/unison-src/transcripts/create-author.output.md b/unison-src/transcripts/create-author.output.md deleted file mode 100644 index 3a5635947b..0000000000 --- a/unison-src/transcripts/create-author.output.md +++ /dev/null @@ -1,22 +0,0 @@ -Demonstrating `create.author`: - -```ucm - ☝️ The namespace .foo is empty. - -.foo> create.author alicecoder "Alice McGee" - - Added definitions: - - 1. metadata.authors.alicecoder : #345f3nptqq - 2. metadata.copyrightHolders.alicecoder : #pgornst1pq - 3. metadata.authors.alicecoder.guid : #hqectlr3gt - - Tip: Add License values for alicecoder under metadata. - -.foo> view 2 - - .foo.metadata.copyrightHolders.alicecoder : CopyrightHolder - .foo.metadata.copyrightHolders.alicecoder = - CopyrightHolder alicecoder.guid "Alice McGee" - -``` diff --git a/unison-src/transcripts/cycle-update-1.md b/unison-src/transcripts/cycle-update-1.md deleted file mode 100644 index 5294f2e49b..0000000000 --- a/unison-src/transcripts/cycle-update-1.md +++ /dev/null @@ -1,27 +0,0 @@ -Update a member of a cycle, but retain the cycle. - -```ucm:hide -.> builtins.merge -``` - -```unison -ping : 'Nat -ping _ = !pong + 1 - -pong : 'Nat -pong _ = !ping + 2 -``` - -```ucm -.> add -``` - -```unison -ping : 'Nat -ping _ = !pong + 3 -``` - -```ucm -.> update -.> view ping pong -``` diff --git a/unison-src/transcripts/cycle-update-1.output.md b/unison-src/transcripts/cycle-update-1.output.md deleted file mode 100644 index 3906248333..0000000000 --- a/unison-src/transcripts/cycle-update-1.output.md +++ /dev/null @@ -1,77 +0,0 @@ -Update a member of a cycle, but retain the cycle. - -```unison -ping : 'Nat -ping _ = !pong + 1 - -pong : 'Nat -pong _ = !ping + 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ping : 'Nat - pong : 'Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - ping : 'Nat - pong : 'Nat - -``` -```unison -ping : 'Nat -ping _ = !pong + 3 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - ping : 'Nat - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Everything typechecks, so I'm saving the results... - - Done. - -.> view ping pong - - ping : 'Nat - ping _ = - use Nat + - !pong + 3 - - pong : 'Nat - pong _ = - use Nat + - !ping + 2 - -``` diff --git a/unison-src/transcripts/cycle-update-2.md b/unison-src/transcripts/cycle-update-2.md deleted file mode 100644 index bd8c6edc13..0000000000 --- a/unison-src/transcripts/cycle-update-2.md +++ /dev/null @@ -1,27 +0,0 @@ -Update a member of a cycle with a type-preserving update, but sever the cycle. - -```ucm:hide -.> builtins.merge -``` - -```unison -ping : 'Nat -ping _ = !pong + 1 - -pong : 'Nat -pong _ = !ping + 2 -``` - -```ucm -.> add -``` - -```unison -ping : 'Nat -ping _ = 3 -``` - -```ucm -.> update -.> view ping pong -``` diff --git a/unison-src/transcripts/cycle-update-2.output.md b/unison-src/transcripts/cycle-update-2.output.md deleted file mode 100644 index 6884788130..0000000000 --- a/unison-src/transcripts/cycle-update-2.output.md +++ /dev/null @@ -1,75 +0,0 @@ -Update a member of a cycle with a type-preserving update, but sever the cycle. - -```unison -ping : 'Nat -ping _ = !pong + 1 - -pong : 'Nat -pong _ = !ping + 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ping : 'Nat - pong : 'Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - ping : 'Nat - pong : 'Nat - -``` -```unison -ping : 'Nat -ping _ = 3 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - ping : 'Nat - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Everything typechecks, so I'm saving the results... - - Done. - -.> view ping pong - - ping : 'Nat - ping _ = 3 - - pong : 'Nat - pong _ = - use Nat + - !ping + 2 - -``` diff --git a/unison-src/transcripts/cycle-update-3.md b/unison-src/transcripts/cycle-update-3.md deleted file mode 100644 index dfcd87305e..0000000000 --- a/unison-src/transcripts/cycle-update-3.md +++ /dev/null @@ -1,27 +0,0 @@ -Update a member of a cycle with a type-changing update, thus severing the cycle. - -```ucm:hide -.> builtins.merge -``` - -```unison -ping : 'Nat -ping _ = !pong + 1 - -pong : 'Nat -pong _ = !ping + 2 -``` - -```ucm -.> add -``` - -```unison -ping : Nat -ping = 3 -``` - -```ucm -.> update.old -.> view ping pong -``` diff --git a/unison-src/transcripts/cycle-update-3.output.md b/unison-src/transcripts/cycle-update-3.output.md deleted file mode 100644 index 7a0a499dbc..0000000000 --- a/unison-src/transcripts/cycle-update-3.output.md +++ /dev/null @@ -1,70 +0,0 @@ -Update a member of a cycle with a type-changing update, thus severing the cycle. - -```unison -ping : 'Nat -ping _ = !pong + 1 - -pong : 'Nat -pong _ = !ping + 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ping : 'Nat - pong : 'Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - ping : 'Nat - pong : 'Nat - -``` -```unison -ping : Nat -ping = 3 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - ping : Nat - -``` -```ucm -.> update.old - - ⍟ I've updated these names to your new definition: - - ping : Nat - -.> view ping pong - - ping : Nat - ping = 3 - - pong : 'Nat - pong _ = - use Nat + - !#4t465jk908.1 + 2 - -``` diff --git a/unison-src/transcripts/cycle-update-4.md b/unison-src/transcripts/cycle-update-4.md deleted file mode 100644 index d2bf98f690..0000000000 --- a/unison-src/transcripts/cycle-update-4.md +++ /dev/null @@ -1,30 +0,0 @@ -`update` properly discovers and establishes new cycles. - -```ucm:hide -.> builtins.merge -``` - -```unison -ping : 'Nat -ping _ = 1 - -pong : 'Nat -pong _ = !ping + 2 -``` - -```ucm -.> add -``` - -```unison -ping : 'Nat -ping _ = !clang + 1 - -clang : 'Nat -clang _ = !pong + 3 -``` - -```ucm -.> update.old ping -.> view ping pong clang -``` diff --git a/unison-src/transcripts/cycle-update-4.output.md b/unison-src/transcripts/cycle-update-4.output.md deleted file mode 100644 index fd525176bf..0000000000 --- a/unison-src/transcripts/cycle-update-4.output.md +++ /dev/null @@ -1,89 +0,0 @@ -`update` properly discovers and establishes new cycles. - -```unison -ping : 'Nat -ping _ = 1 - -pong : 'Nat -pong _ = !ping + 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ping : 'Nat - pong : 'Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - ping : 'Nat - pong : 'Nat - -``` -```unison -ping : 'Nat -ping _ = !clang + 1 - -clang : 'Nat -clang _ = !pong + 3 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - clang : 'Nat - - ⍟ These names already exist. You can `update` them to your - new definition: - - ping : 'Nat - -``` -```ucm -.> update.old ping - - ⍟ I've added these definitions: - - clang : 'Nat - - ⍟ I've updated these names to your new definition: - - ping : 'Nat - pong : 'Nat - -.> view ping pong clang - - clang : 'Nat - clang _ = - use Nat + - !pong + 3 - - ping : 'Nat - ping _ = - use Nat + - !clang + 1 - - pong : 'Nat - pong _ = - use Nat + - !ping + 2 - -``` diff --git a/unison-src/transcripts/cycle-update-5.md b/unison-src/transcripts/cycle-update-5.md deleted file mode 100644 index c09a93c3d7..0000000000 --- a/unison-src/transcripts/cycle-update-5.md +++ /dev/null @@ -1,34 +0,0 @@ -Not yet working: properly updating nameless implicit terms. - -```ucm:hide -.> builtins.merge -``` - -```unison -inner.ping : 'Nat -inner.ping _ = !pong + 1 - -pong : 'Nat -pong _ = !inner.ping + 2 -``` - -```ucm -.> add -``` - -Here we queue up an update by saving in a namespace where `inner.ping` and `pong` both have names, but then apply the -update in a namespace where only `ping` has a name. - -```unison -inner.ping : 'Nat -inner.ping _ = !pong + 3 -``` - -```ucm -.inner> update.old -.> view inner.ping -``` - -The bug here is that `inner.ping` still refers to `pong` by name. But if we properly identified the nameless (in the -context that the update was applied) `pong` as an implicit term to include in the new `ping`'s cycle, then `ping` would -be left referring to a nameless thing (namely, `pong`, but updated to refer to the new `ping`). diff --git a/unison-src/transcripts/cycle-update-5.output.md b/unison-src/transcripts/cycle-update-5.output.md deleted file mode 100644 index 3e3361f70c..0000000000 --- a/unison-src/transcripts/cycle-update-5.output.md +++ /dev/null @@ -1,73 +0,0 @@ -Not yet working: properly updating nameless implicit terms. - -```unison -inner.ping : 'Nat -inner.ping _ = !pong + 1 - -pong : 'Nat -pong _ = !inner.ping + 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - inner.ping : 'Nat - pong : 'Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - inner.ping : 'Nat - pong : 'Nat - -``` -Here we queue up an update by saving in a namespace where `inner.ping` and `pong` both have names, but then apply the -update in a namespace where only `ping` has a name. - -```unison -inner.ping : 'Nat -inner.ping _ = !pong + 3 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - inner.ping : 'Nat - -``` -```ucm -.inner> update.old - - ⍟ I've added these definitions: - - inner.ping : '##Nat - -.> view inner.ping - - inner.ping : 'Nat - inner.ping _ = - use Nat + - !pong + 1 - -``` -The bug here is that `inner.ping` still refers to `pong` by name. But if we properly identified the nameless (in the -context that the update was applied) `pong` as an implicit term to include in the new `ping`'s cycle, then `ping` would -be left referring to a nameless thing (namely, `pong`, but updated to refer to the new `ping). diff --git a/unison-src/transcripts/debug-definitions.md b/unison-src/transcripts/debug-definitions.md deleted file mode 100644 index 4717486917..0000000000 --- a/unison-src/transcripts/debug-definitions.md +++ /dev/null @@ -1,28 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison:hide -x = 30 - -y : Nat -y = - z = x + 2 - z + 10 - -structural type Optional a = Some a | None - -ability Ask a where - ask : a -``` - -```ucm -.> add -.> debug.term.abt Nat.+ -.> debug.term.abt y -.> debug.term.abt Some -.> debug.term.abt ask -.> debug.type.abt Nat -.> debug.type.abt Optional -.> debug.type.abt Ask -``` diff --git a/unison-src/transcripts/debug-definitions.output.md b/unison-src/transcripts/debug-definitions.output.md deleted file mode 100644 index cb1b14d1a2..0000000000 --- a/unison-src/transcripts/debug-definitions.output.md +++ /dev/null @@ -1,154 +0,0 @@ -```unison -x = 30 - -y : Nat -y = - z = x + 2 - z + 10 - -structural type Optional a = Some a | None - -ability Ask a where - ask : a -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - ability Ask a - structural type Optional a - (also named builtin.Optional) - x : Nat - y : Nat - -.> debug.term.abt Nat.+ - - Builtin term: ##Nat.+ - -.> debug.term.abt y - - (let Ref(ReferenceBuiltin "Nat.+") Ref(ReferenceDerived (Id "qpo3o788girkkbb43uf6ggqberfduhtnqbt7096eojlrp27jieco09mdasb7b0b06ej9hj60a00nnbbdo8he0b4e0m7vtopifiuhdig" 0)) 2 in (User "z". Ref(ReferenceBuiltin "Nat.+") (Var User "z") 10)):ReferenceBuiltin "Nat" - -.> debug.term.abt Some - - Constructor #0 of the following type: - DataDeclaration - { modifier = Structural - , annotation = External - , bound = - [ User "a" ] - , constructors' = - [ - ( External - , User "Constructor0" - , - ( User "a". Var User "a" -> ReferenceDerived - ( Id "nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg" 0 ) - ( Var User "a" ) - ) - ) - , - ( External - , User "Constructor1" - , - ( User "a". ReferenceDerived - ( Id "nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg" 0 ) - ( Var User "a" ) - ) - ) - ] - } - -.> debug.term.abt ask - - Constructor #0 of the following type: - EffectDeclaration - { toDataDecl = DataDeclaration - { modifier = Unique "a1ns7cunv2dvjmum0q8jbc54g6811cbh" - , annotation = External - , bound = - [ User "a" ] - , constructors' = - [ - ( External - , User "Constructor0" - , - ( User "a". - ( - { - [ ReferenceDerived - ( Id "d8m1kmiscgfrl5n9ruvq1432lntfntl7nnao45qlk2uqhparm0uq2im0kbspu6u6kv65hd0i5oljq9m4b78peh5ekpma7gkihtsmfh0" 0 ) - ( Var User "a" ) - ] - } Var User "a" - ) - ) - ) - ] - } - } - -.> debug.type.abt Nat - - Builtin type: ##Nat - -.> debug.type.abt Optional - - DataDeclaration - { modifier = Structural - , annotation = External - , bound = - [ User "a" ] - , constructors' = - [ - ( External - , User "Constructor0" - , - ( User "a". Var User "a" -> ReferenceDerived - ( Id "nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg" 0 ) - ( Var User "a" ) - ) - ) - , - ( External - , User "Constructor1" - , - ( User "a". ReferenceDerived - ( Id "nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg" 0 ) - ( Var User "a" ) - ) - ) - ] - } - -.> debug.type.abt Ask - - EffectDeclaration - { toDataDecl = DataDeclaration - { modifier = Unique "a1ns7cunv2dvjmum0q8jbc54g6811cbh" - , annotation = External - , bound = - [ User "a" ] - , constructors' = - [ - ( External - , User "Constructor0" - , - ( User "a". - ( - { - [ ReferenceDerived - ( Id "d8m1kmiscgfrl5n9ruvq1432lntfntl7nnao45qlk2uqhparm0uq2im0kbspu6u6kv65hd0i5oljq9m4b78peh5ekpma7gkihtsmfh0" 0 ) - ( Var User "a" ) - ] - } Var User "a" - ) - ) - ) - ] - } - } - -``` diff --git a/unison-src/transcripts/debug-name-diffs.md b/unison-src/transcripts/debug-name-diffs.md deleted file mode 100644 index 361142bf57..0000000000 --- a/unison-src/transcripts/debug-name-diffs.md +++ /dev/null @@ -1,19 +0,0 @@ -```unison -a.b.one = 1 -a.two = 2 - -a.x.three = 3 -a.x.four = 4 - -structural type a.x.Foo = Foo | Bar -structural type a.b.Baz = Boo -``` - -```ucm -.> add -.> delete.term.verbose a.b.one -.> alias.term a.two a.newtwo -.> move.namespace a.x a.y -.> history -.> debug.name-diff 4 1 -``` diff --git a/unison-src/transcripts/debug-name-diffs.output.md b/unison-src/transcripts/debug-name-diffs.output.md deleted file mode 100644 index ac6895c14e..0000000000 --- a/unison-src/transcripts/debug-name-diffs.output.md +++ /dev/null @@ -1,109 +0,0 @@ -```unison -a.b.one = 1 -a.two = 2 - -a.x.three = 3 -a.x.four = 4 - -structural type a.x.Foo = Foo | Bar -structural type a.b.Baz = Boo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type a.b.Baz - structural type a.x.Foo - a.b.one : ##Nat - a.two : ##Nat - a.x.four : ##Nat - a.x.three : ##Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - structural type a.b.Baz - structural type a.x.Foo - a.b.one : ##Nat - a.two : ##Nat - a.x.four : ##Nat - a.x.three : ##Nat - -.> delete.term.verbose a.b.one - - Removed definitions: - - 1. a.b.one : ##Nat - - Tip: You can use `undo` or `reflog` to undo this change. - -.> alias.term a.two a.newtwo - - Done. - -.> move.namespace a.x a.y - - Done. - -.> history - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #tteooc9j2d - - > Moves: - - Original name New name - a.x.Foo a.y.Foo - a.x.Foo.Bar a.y.Foo.Bar - a.x.Foo.Foo a.y.Foo.Foo - a.x.four a.y.four - a.x.three a.y.three - - ⊙ 2. #bicrtgqj12 - - + Adds / updates: - - a.newtwo - - = Copies: - - Original name New name(s) - a.two a.newtwo - - ⊙ 3. #bofp4huk1j - - - Deletes: - - a.b.one - - □ 4. #gss5s88mo3 (start of history) - -.> debug.name-diff 4 1 - - Kind Name Change Ref - Term a.newtwo Added #dcgdua2lj6upd1ah5v0qp09gjsej0d77d87fu6qn8e2qrssnlnmuinoio46hiu53magr7qn8vnqke8ndt0v76700o5u8gcvo7st28jg - Term a.y.four Added #vcfbbslncd2qloc03kalgsmufl3j5es6cehcrbmlj6t78d4uk5j9gpa3hhf2opln1u2kiepg5n2cn49ianf2oig0mi4c2ldn1r9lf40 - Term a.y.three Added #f3lgjvjqoocpt8v6kdgd2bgthh11a7md3qdp9rf5datccmo580btjd5bt5dro3irqs0is7vm7s1dphddjbtufch620te7ef7canmjj8 - Term a.y.Foo.Bar Added #6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0#d1 - Term a.y.Foo.Foo Added #6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0#d0 - Term a.b.one Removed #gjmq673r1vrurfotlnirv7vutdhm6sa3s02em5g22kk606mv6duvv8be402dv79312i4a0onepq5bo7citsodvq2g720nttj0ee9p0g - Term a.x.four Removed #vcfbbslncd2qloc03kalgsmufl3j5es6cehcrbmlj6t78d4uk5j9gpa3hhf2opln1u2kiepg5n2cn49ianf2oig0mi4c2ldn1r9lf40 - Term a.x.three Removed #f3lgjvjqoocpt8v6kdgd2bgthh11a7md3qdp9rf5datccmo580btjd5bt5dro3irqs0is7vm7s1dphddjbtufch620te7ef7canmjj8 - Term a.x.Foo.Bar Removed #6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0#d1 - Term a.x.Foo.Foo Removed #6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0#d0 - Type a.y.Foo Added #6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0 - Type a.x.Foo Removed #6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0 - -``` diff --git a/unison-src/transcripts/deep-names.md b/unison-src/transcripts/deep-names.md deleted file mode 100644 index 3487497cc3..0000000000 --- a/unison-src/transcripts/deep-names.md +++ /dev/null @@ -1,47 +0,0 @@ -First we'll set up two libraries, and then we'll use them in some projects and show what `names` are deep-loaded for them. - -Our two "libraries": -```unison:hide -text.a = 1 -text.b = 2 -text.c = 3 - -http.x = 6 -http.y = 7 -http.z = 8 -``` - -```ucm:hide -.> add -``` - -Our `app1` project includes the text library twice and the http library twice as direct dependencies. -```ucm -.app1> fork .text lib.text_v1 -.app1> fork .text lib.text_v2 -.app1> fork .http lib.http_v3 -.app1> fork .http lib.http_v4 -``` - -As such, we see two copies of `a` and two copies of `x` via these direct dependencies. -```ucm -.app1> names a -.app1> names x -``` - -Our `app2` project includes the `http` library twice as direct dependencies, and once as an indirect dependency via `webutil`. -It also includes the `text` library twice as indirect dependencies via `webutil` -```ucm -.app2> fork .http lib.http_v1 -.app2> fork .http lib.http_v2 -.app2> fork .text lib.webutil.lib.text_v1 -.app2> fork .text lib.webutil.lib.text_v2 -.app2> fork .http lib.webutil.lib.http -``` - -Now we see two copies of `x` via direct dependencies on `http`, and one copy of `a` via indirect dependency on `text` via `webutil`. -We see neither the second indirect copy of `a` nor the indirect copy of `x` via webutil because we already have names for them. -```ucm -.app2> names a -.app2> names x -``` diff --git a/unison-src/transcripts/deep-names.output.md b/unison-src/transcripts/deep-names.output.md deleted file mode 100644 index 3b6637d8a7..0000000000 --- a/unison-src/transcripts/deep-names.output.md +++ /dev/null @@ -1,99 +0,0 @@ -First we'll set up two libraries, and then we'll use them in some projects and show what `names` are deep-loaded for them. - -Our two "libraries": -```unison -text.a = 1 -text.b = 2 -text.c = 3 - -http.x = 6 -http.y = 7 -http.z = 8 -``` - -Our `app1` project includes the text library twice and the http library twice as direct dependencies. -```ucm - ☝️ The namespace .app1 is empty. - -.app1> fork .text lib.text_v1 - - Done. - -.app1> fork .text lib.text_v2 - - Done. - -.app1> fork .http lib.http_v3 - - Done. - -.app1> fork .http lib.http_v4 - - Done. - -``` -As such, we see two copies of `a` and two copies of `x` via these direct dependencies. -```ucm -.app1> names a - - Term - Hash: #gjmq673r1v - Names: lib.text_v1.a lib.text_v2.a - - Tip: Use `names.global` to see more results. - -.app1> names x - - Term - Hash: #nsmc4p1ra4 - Names: lib.http_v3.x lib.http_v4.x - - Tip: Use `names.global` to see more results. - -``` -Our `app2` project includes the `http` library twice as direct dependencies, and once as an indirect dependency via `webutil`. -It also includes the `text` library twice as indirect dependencies via `webutil` -```ucm - ☝️ The namespace .app2 is empty. - -.app2> fork .http lib.http_v1 - - Done. - -.app2> fork .http lib.http_v2 - - Done. - -.app2> fork .text lib.webutil.lib.text_v1 - - Done. - -.app2> fork .text lib.webutil.lib.text_v2 - - Done. - -.app2> fork .http lib.webutil.lib.http - - Done. - -``` -Now we see two copies of `x` via direct dependencies on `http`, and one copy of `a` via indirect dependency on `text` via `webutil`. -We see neither the second indirect copy of `a` nor the indirect copy of `x` via webutil because we already have names for them. -```ucm -.app2> names a - - Term - Hash: #gjmq673r1v - Names: lib.webutil.lib.text_v1.a - - Tip: Use `names.global` to see more results. - -.app2> names x - - Term - Hash: #nsmc4p1ra4 - Names: lib.http_v1.x lib.http_v2.x - - Tip: Use `names.global` to see more results. - -``` diff --git a/unison-src/transcripts/definition-diff-api.md b/unison-src/transcripts/definition-diff-api.md deleted file mode 100644 index f8d21d0687..0000000000 --- a/unison-src/transcripts/definition-diff-api.md +++ /dev/null @@ -1,40 +0,0 @@ -```ucm -diffs/main> builtins.merge -``` - -```unison -term = - _ = "Here's some text" - 1 + 1 - -type Type = Type Nat -``` - -```ucm -diffs/main> add -diffs/main> branch.create new -``` - -```unison -term = - _ = "Here's some different text" - 1 + 2 - -type Type a = Type a Text -``` - -```ucm -diffs/new> update -``` - -Diff terms - -```api -GET /api/projects/diffs/diff/terms?oldBranchRef=main&newBranchRef=new&oldTerm=term&newTerm=term -``` - -Diff types - -```api -GET /api/projects/diffs/diff/types?oldBranchRef=main&newBranchRef=new&oldType=Type&newType=Type -``` diff --git a/unison-src/transcripts/definition-diff-api.output.md b/unison-src/transcripts/definition-diff-api.output.md deleted file mode 100644 index 192367ff9f..0000000000 --- a/unison-src/transcripts/definition-diff-api.output.md +++ /dev/null @@ -1,807 +0,0 @@ -```ucm -diffs/main> builtins.merge - - Done. - -``` -```unison -term = - _ = "Here's some text" - 1 + 1 - -type Type = Type Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Type - term : Nat - -``` -```ucm -diffs/main> add - - ⍟ I've added these definitions: - - type Type - term : Nat - -diffs/main> branch.create new - - Done. I've created the new branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /new`. - -``` -```unison -term = - _ = "Here's some different text" - 1 + 2 - -type Type a = Type a Text -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Type a - term : Nat - -``` -```ucm -diffs/new> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -``` -Diff terms - -```api -GET /api/projects/diffs/diff/terms?oldBranchRef=main&newBranchRef=new&oldTerm=term&newTerm=term -{ - "diff": { - "contents": [ - { - "diffTag": "both", - "elements": [ - { - "annotation": { - "contents": "term", - "tag": "HashQualifier" - }, - "segment": "term" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "term", - "tag": "HashQualifier" - }, - "segment": "term" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseKeyword" - }, - "segment": "use " - }, - { - "annotation": { - "tag": "UsePrefix" - }, - "segment": "Nat" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseSuffix" - }, - "segment": "+" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "_", - "tag": "HashQualifier" - }, - "segment": "_" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": " " - } - ] - }, - { - "annotation": { - "tag": "TextLiteral" - }, - "diffTag": "segmentChange", - "fromSegment": "\"Here's some text\"", - "toSegment": "\"Here's some different text\"" - }, - { - "diffTag": "both", - "elements": [ - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "NumericLiteral" - }, - "segment": "1" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat.+", - "tag": "TermReference" - }, - "segment": "+" - }, - { - "annotation": null, - "segment": " " - } - ] - }, - { - "annotation": { - "tag": "NumericLiteral" - }, - "diffTag": "segmentChange", - "fromSegment": "1", - "toSegment": "2" - } - ], - "tag": "UserObject" - }, - "diffKind": "diff", - "newBranchRef": "new", - "newTerm": { - "bestTermName": "term", - "defnTermTag": "Plain", - "signature": [ - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - } - ], - "termDefinition": { - "contents": [ - { - "annotation": { - "contents": "term", - "tag": "HashQualifier" - }, - "segment": "term" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "term", - "tag": "HashQualifier" - }, - "segment": "term" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseKeyword" - }, - "segment": "use " - }, - { - "annotation": { - "tag": "UsePrefix" - }, - "segment": "Nat" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseSuffix" - }, - "segment": "+" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "_", - "tag": "HashQualifier" - }, - "segment": "_" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TextLiteral" - }, - "segment": "\"Here's some different text\"" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "NumericLiteral" - }, - "segment": "1" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat.+", - "tag": "TermReference" - }, - "segment": "+" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "NumericLiteral" - }, - "segment": "2" - } - ], - "tag": "UserObject" - }, - "termDocs": [], - "termNames": [ - "term" - ] - }, - "oldBranchRef": "main", - "oldTerm": { - "bestTermName": "term", - "defnTermTag": "Plain", - "signature": [ - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - } - ], - "termDefinition": { - "contents": [ - { - "annotation": { - "contents": "term", - "tag": "HashQualifier" - }, - "segment": "term" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "term", - "tag": "HashQualifier" - }, - "segment": "term" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseKeyword" - }, - "segment": "use " - }, - { - "annotation": { - "tag": "UsePrefix" - }, - "segment": "Nat" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseSuffix" - }, - "segment": "+" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "_", - "tag": "HashQualifier" - }, - "segment": "_" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "TextLiteral" - }, - "segment": "\"Here's some text\"" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "NumericLiteral" - }, - "segment": "1" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat.+", - "tag": "TermReference" - }, - "segment": "+" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "NumericLiteral" - }, - "segment": "1" - } - ], - "tag": "UserObject" - }, - "termDocs": [], - "termNames": [ - "term" - ] - }, - "project": "diffs" -} -```Diff types - -```api -GET /api/projects/diffs/diff/types?oldBranchRef=main&newBranchRef=new&oldType=Type&newType=Type -{ - "diff": { - "contents": [ - { - "diffTag": "both", - "elements": [ - { - "annotation": { - "tag": "DataTypeKeyword" - }, - "segment": "type" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "Type", - "tag": "HashQualifier" - }, - "segment": "Type" - } - ] - }, - { - "diffTag": "new", - "elements": [ - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "DataTypeParams" - }, - "segment": "a" - } - ] - }, - { - "diffTag": "both", - "elements": [ - { - "annotation": { - "tag": "DelimiterChar" - }, - "segment": " = " - } - ] - }, - { - "diffTag": "annotationChange", - "fromAnnotation": { - "contents": "#0tc9e438eurvtevfa6k9pg04qvv66is75hs8iqejkuoaef140g8vvu92hc1ks4gamgc3i1ukgdn0blchp3038l43vffijpsbjh14igo#d0", - "tag": "TermReference" - }, - "segment": "Type", - "toAnnotation": { - "contents": "#mft8mne9i92b6k4m512rn2608rsp6ilq4ejufeof6mbh5aintes4tih1fo93fospmu2t3f0h67uu0mrk2qj75o7k0lj1juefhaidt4g#d0", - "tag": "TermReference" - } - }, - { - "diffTag": "both", - "elements": [ - { - "annotation": null, - "segment": " " - } - ] - }, - { - "diffTag": "old", - "elements": [ - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - } - ] - }, - { - "diffTag": "new", - "elements": [ - { - "annotation": { - "tag": "Var" - }, - "segment": "a" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - } - ] - } - ], - "tag": "UserObject" - }, - "diffKind": "diff", - "newBranchRef": "new", - "newType": { - "bestTypeName": "Type", - "defnTypeTag": "Data", - "typeDefinition": { - "contents": [ - { - "annotation": { - "tag": "DataTypeKeyword" - }, - "segment": "type" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "Type", - "tag": "HashQualifier" - }, - "segment": "Type" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "DataTypeParams" - }, - "segment": "a" - }, - { - "annotation": { - "tag": "DelimiterChar" - }, - "segment": " = " - }, - { - "annotation": { - "contents": "#mft8mne9i92b6k4m512rn2608rsp6ilq4ejufeof6mbh5aintes4tih1fo93fospmu2t3f0h67uu0mrk2qj75o7k0lj1juefhaidt4g#d0", - "tag": "TermReference" - }, - "segment": "Type" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "Var" - }, - "segment": "a" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - } - ], - "tag": "UserObject" - }, - "typeDocs": [], - "typeNames": [ - "Type" - ] - }, - "oldBranchRef": "main", - "oldType": { - "bestTypeName": "Type", - "defnTypeTag": "Data", - "typeDefinition": { - "contents": [ - { - "annotation": { - "tag": "DataTypeKeyword" - }, - "segment": "type" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "Type", - "tag": "HashQualifier" - }, - "segment": "Type" - }, - { - "annotation": { - "tag": "DelimiterChar" - }, - "segment": " = " - }, - { - "annotation": { - "contents": "#0tc9e438eurvtevfa6k9pg04qvv66is75hs8iqejkuoaef140g8vvu92hc1ks4gamgc3i1ukgdn0blchp3038l43vffijpsbjh14igo#d0", - "tag": "TermReference" - }, - "segment": "Type" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - } - ], - "tag": "UserObject" - }, - "typeDocs": [], - "typeNames": [ - "Type" - ] - }, - "project": "diffs" -} -``` \ No newline at end of file diff --git a/unison-src/transcripts/delete-namespace-dependents-check.md b/unison-src/transcripts/delete-namespace-dependents-check.md deleted file mode 100644 index 72aacc311d..0000000000 --- a/unison-src/transcripts/delete-namespace-dependents-check.md +++ /dev/null @@ -1,22 +0,0 @@ - - -# Delete namespace dependents check - -This is a regression test, previously `delete.namespace` allowed a delete as long as the deletions had a name _anywhere_ in your codebase, it should only check the current project branch. - -```ucm:hide -myproject/main> builtins.merge -``` - -```unison -sub.dependency = 123 - -dependent = dependency + 99 -``` - -```ucm:error -myproject/main> add -myproject/main> branch /new -myproject/new> delete.namespace sub -myproject/new> view dependent -``` diff --git a/unison-src/transcripts/delete-namespace-dependents-check.output.md b/unison-src/transcripts/delete-namespace-dependents-check.output.md deleted file mode 100644 index 4ab6524093..0000000000 --- a/unison-src/transcripts/delete-namespace-dependents-check.output.md +++ /dev/null @@ -1,62 +0,0 @@ - - -# Delete namespace dependents check - -This is a regression test, previously `delete.namespace` allowed a delete as long as the deletions had a name _anywhere_ in your codebase, it should only check the current project branch. - -```unison -sub.dependency = 123 - -dependent = dependency + 99 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - dependent : Nat - sub.dependency : Nat - -``` -```ucm -myproject/main> add - - ⍟ I've added these definitions: - - dependent : Nat - sub.dependency : Nat - -myproject/main> branch /new - - Done. I've created the new branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /new`. - -myproject/new> delete.namespace sub - - ⚠️ - - I didn't delete the namespace because the following - definitions are still in use. - - Dependency Referenced In - dependency 1. dependent - - If you want to proceed anyways and leave those definitions - without names, use delete.namespace.force - -myproject/new> view dependent - - dependent : Nat - dependent = - use Nat + - dependency + 99 - -``` diff --git a/unison-src/transcripts/delete-namespace.md b/unison-src/transcripts/delete-namespace.md deleted file mode 100644 index fe8f346306..0000000000 --- a/unison-src/transcripts/delete-namespace.md +++ /dev/null @@ -1,61 +0,0 @@ -# delete.namespace.force - -```ucm:hide -.> builtins.merge -``` - -```unison:hide -no_dependencies.thing = "no dependents on this term" - -dependencies.term1 = 1 -dependencies.term2 = 2 - -dependents.usage1 = dependencies.term1 + dependencies.term2 -dependents.usage2 = dependencies.term1 * dependencies.term2 -``` - -```ucm:hide -.> add -``` - -Deleting a namespace with no external dependencies should succeed. - -```ucm -.> delete.namespace no_dependencies -``` - -Deleting a namespace with external dependencies should fail and list all dependents. - -```ucm:error -.> delete.namespace dependencies -``` - -Deleting a namespace with external dependencies should succeed when using `delete.namespace.force` - -```ucm -.> delete.namespace.force dependencies -``` - -I should be able to view an affected dependency by number - -```ucm -.> view 2 -``` - -Deleting the root namespace should require confirmation if not forced. - -```ucm -.> delete.namespace . -.> delete.namespace . --- Should have an empty history -.> history . -``` - -Deleting the root namespace shouldn't require confirmation if forced. - -```ucm -.> delete.namespace.force . --- Should have an empty history -.> history . -``` - diff --git a/unison-src/transcripts/delete-namespace.output.md b/unison-src/transcripts/delete-namespace.output.md deleted file mode 100644 index e7c09cbaed..0000000000 --- a/unison-src/transcripts/delete-namespace.output.md +++ /dev/null @@ -1,109 +0,0 @@ -# delete.namespace.force - -```unison -no_dependencies.thing = "no dependents on this term" - -dependencies.term1 = 1 -dependencies.term2 = 2 - -dependents.usage1 = dependencies.term1 + dependencies.term2 -dependents.usage2 = dependencies.term1 * dependencies.term2 -``` - -Deleting a namespace with no external dependencies should succeed. - -```ucm -.> delete.namespace no_dependencies - - Done. - -``` -Deleting a namespace with external dependencies should fail and list all dependents. - -```ucm -.> delete.namespace dependencies - - ⚠️ - - I didn't delete the namespace because the following - definitions are still in use. - - Dependency Referenced In - term2 1. dependents.usage1 - 2. dependents.usage2 - - term1 3. dependents.usage1 - 4. dependents.usage2 - - If you want to proceed anyways and leave those definitions - without names, use delete.namespace.force - -``` -Deleting a namespace with external dependencies should succeed when using `delete.namespace.force` - -```ucm -.> delete.namespace.force dependencies - - Done. - - ⚠️ - - Of the things I deleted, the following are still used in the - following definitions. They now contain un-named references. - - Dependency Referenced In - term2 1. dependents.usage1 - 2. dependents.usage2 - - term1 3. dependents.usage1 - 4. dependents.usage2 - -``` -I should be able to view an affected dependency by number - -```ucm -.> view 2 - - dependents.usage2 : Nat - dependents.usage2 = - use Nat * - #gjmq673r1v * #dcgdua2lj6 - -``` -Deleting the root namespace should require confirmation if not forced. - -```ucm -.> delete.namespace . - - ⚠️ - - Are you sure you want to clear away everything? - You could use `project.create` to switch to a new project instead. - -.> delete.namespace . - - Okay, I deleted everything except the history. Use `undo` to - undo, or `builtins.merge` to restore the absolute basics to - the current path. - --- Should have an empty history -.> history . - - ☝️ The namespace . is empty. - -``` -Deleting the root namespace shouldn't require confirmation if forced. - -```ucm -.> delete.namespace.force . - - Okay, I deleted everything except the history. Use `undo` to - undo, or `builtins.merge` to restore the absolute basics to - the current path. - --- Should have an empty history -.> history . - - ☝️ The namespace . is empty. - -``` diff --git a/unison-src/transcripts/delete-project-branch.md b/unison-src/transcripts/delete-project-branch.md deleted file mode 100644 index c84dc95cc2..0000000000 --- a/unison-src/transcripts/delete-project-branch.md +++ /dev/null @@ -1,27 +0,0 @@ -Deleting the branch you are on takes you to its parent (though this is impossible to see in a transcript, since we set -your working directory with each command). - -```ucm -foo/main> branch topic -foo/topic> delete.branch /topic -``` - -A branch need not be preceded by a forward slash. - -```ucm -foo/main> branch topic -foo/topic> delete.branch topic -``` - -You can precede the branch name by a project name. - -```ucm -foo/main> branch topic -.> delete.branch foo/topic -``` - -You can delete the only branch in a project. - -```ucm -foo/main> delete.branch /main -``` diff --git a/unison-src/transcripts/delete-project-branch.output.md b/unison-src/transcripts/delete-project-branch.output.md deleted file mode 100644 index d4458e8be0..0000000000 --- a/unison-src/transcripts/delete-project-branch.output.md +++ /dev/null @@ -1,48 +0,0 @@ -Deleting the branch you are on takes you to its parent (though this is impossible to see in a transcript, since we set -your working directory with each command). - -```ucm -foo/main> branch topic - - Done. I've created the topic branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic`. - -foo/topic> delete.branch /topic - -``` -A branch need not be preceded by a forward slash. - -```ucm -foo/main> branch topic - - Done. I've created the topic branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic`. - -foo/topic> delete.branch topic - -``` -You can precede the branch name by a project name. - -```ucm -foo/main> branch topic - - Done. I've created the topic branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic`. - - ☝️ The namespace . is empty. - -.> delete.branch foo/topic - -``` -You can delete the only branch in a project. - -```ucm -foo/main> delete.branch /main - -``` diff --git a/unison-src/transcripts/delete-project.md b/unison-src/transcripts/delete-project.md deleted file mode 100644 index df31873fb9..0000000000 --- a/unison-src/transcripts/delete-project.md +++ /dev/null @@ -1,9 +0,0 @@ -# delete.project - -```ucm -.> project.create-empty foo -.> project.create-empty bar -.> projects -foo/main> delete.project foo -.> projects -``` diff --git a/unison-src/transcripts/delete-project.output.md b/unison-src/transcripts/delete-project.output.md deleted file mode 100644 index 18af51f9c0..0000000000 --- a/unison-src/transcripts/delete-project.output.md +++ /dev/null @@ -1,51 +0,0 @@ -# delete.project - -```ucm -.> project.create-empty foo - - 🎉 I've created the project foo. - - 🎨 Type `ui` to explore this project's code in your browser. - 🔭 Discover libraries at https://share.unison-lang.org - 📖 Use `help-topic projects` to learn more about projects. - - Write your first Unison code with UCM: - - 1. Open scratch.u. - 2. Write some Unison code and save the file. - 3. In UCM, type `add` to save it to your new project. - - 🎉 🥳 Happy coding! - - ☝️ The namespace . is empty. - -.> project.create-empty bar - - 🎉 I've created the project bar. - - 🎨 Type `ui` to explore this project's code in your browser. - 🔭 Discover libraries at https://share.unison-lang.org - 📖 Use `help-topic projects` to learn more about projects. - - Write your first Unison code with UCM: - - 1. Open scratch.u. - 2. Write some Unison code and save the file. - 3. In UCM, type `add` to save it to your new project. - - 🎉 🥳 Happy coding! - - ☝️ The namespace . is empty. - -.> projects - - 1. bar - 2. foo - -foo/main> delete.project foo - -.> projects - - 1. bar - -``` diff --git a/unison-src/transcripts/delete-silent.md b/unison-src/transcripts/delete-silent.md deleted file mode 100644 index 33ec668de3..0000000000 --- a/unison-src/transcripts/delete-silent.md +++ /dev/null @@ -1,15 +0,0 @@ -```ucm:error -.> delete foo -``` - -```unison:hide -foo = 1 -structural type Foo = Foo () -``` - -```ucm -.> add -.> delete foo -.> delete.type Foo -.> delete.term Foo.Foo -``` diff --git a/unison-src/transcripts/delete-silent.output.md b/unison-src/transcripts/delete-silent.output.md deleted file mode 100644 index 7ea6d420d2..0000000000 --- a/unison-src/transcripts/delete-silent.output.md +++ /dev/null @@ -1,35 +0,0 @@ -```ucm -.> delete foo - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - foo - -``` -```unison -foo = 1 -structural type Foo = Foo () -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - structural type Foo - foo : ##Nat - -.> delete foo - - Done. - -.> delete.type Foo - - Done. - -.> delete.term Foo.Foo - - Done. - -``` diff --git a/unison-src/transcripts/delete.md b/unison-src/transcripts/delete.md deleted file mode 100644 index e3e27ede98..0000000000 --- a/unison-src/transcripts/delete.md +++ /dev/null @@ -1,209 +0,0 @@ -# Delete - -```ucm:hide -.> builtins.merge -``` - -The delete command can delete both terms and types. - -First, let's make sure it complains when we try to delete a name that doesn't -exist. - -```ucm:error -.> delete.verbose foo -``` - -Now for some easy cases. Deleting an unambiguous term, then deleting an -unambiguous type. - -```unison:hide -foo = 1 -structural type Foo = Foo () -``` - -```ucm -.> add -.> delete.verbose foo -.> delete.verbose Foo -.> delete.verbose Foo.Foo -``` - -How about an ambiguous term? - -```unison:hide -foo = 1 -``` - -```ucm -.a> add -``` - -```unison:hide -foo = 2 -``` - -```ucm -.b> add -.a> merge.old .b -``` - -A delete should remove both versions of the term. - -```ucm -.> delete.verbose a.foo -``` - -```ucm:error -.a> ls -``` - -Let's repeat all that on a type, for completeness. - -```unison:hide -structural type Foo = Foo () -``` - -```ucm -.a> add -``` - -```unison:hide -structural type Foo = Foo -``` - -```ucm -.b> add -.a> merge.old .b -``` - -```ucm -.> delete.verbose a.Foo -``` - -```ucm -.> delete.verbose a.Foo.Foo -``` - -Finally, let's try to delete a term and a type with the same name. - -```unison:hide -foo = 1 -structural type foo = Foo () -``` - -```ucm -.> add -``` - -```ucm -.> delete.verbose foo -``` - -We want to be able to delete multiple terms at once - -```unison:hide -a = "a" -b = "b" -c = "c" -``` - -```ucm -.> add -.> delete.verbose a b c -``` - -We can delete terms and types in the same invocation of delete - -```unison:hide -structural type Foo = Foo () -a = "a" -b = "b" -c = "c" -``` - -```ucm -.> add -.> delete.verbose a b c Foo -.> delete.verbose Foo.Foo -``` - -We can delete a type and its constructors - -```unison:hide -structural type Foo = Foo () -``` - -```ucm -.> add -.> delete.verbose Foo Foo.Foo -``` - -You should not be able to delete terms which are referenced by other terms - -```unison:hide -a = 1 -b = 2 -c = 3 -d = a + b + c -``` - -```ucm:error -.> add -.> delete.verbose a b c -``` - -But you should be able to delete all terms which reference each other in a single command - -```unison:hide -e = 11 -f = 12 + e -g = 13 + f -h = e + f + g -``` - -```ucm -.> add -.> delete.verbose e f g h -``` - -You should be able to delete a type and all the functions that reference it in a single command - -```unison:hide -structural type Foo = Foo Nat - -incrementFoo : Foo -> Nat -incrementFoo = cases - (Foo n) -> n + 1 -``` - -```ucm -.> add -.> delete.verbose Foo Foo.Foo incrementFoo -``` - -If you mess up on one of the names of your command, delete short circuits - -```unison:hide -e = 11 -f = 12 + e -g = 13 + f -h = e + f + g -``` - -```ucm:error -.> add -.> delete.verbose e f gg -``` - -Cyclical terms which are guarded by a lambda are allowed to be deleted - -```unison:hide -ping _ = 1 Nat.+ !pong -pong _ = 4 Nat.+ !ping -``` - -```ucm -.> add -.> delete.verbose ping -.> view pong -``` diff --git a/unison-src/transcripts/delete.output.md b/unison-src/transcripts/delete.output.md deleted file mode 100644 index 05a998cc1e..0000000000 --- a/unison-src/transcripts/delete.output.md +++ /dev/null @@ -1,491 +0,0 @@ -# Delete - -The delete command can delete both terms and types. - -First, let's make sure it complains when we try to delete a name that doesn't -exist. - -```ucm -.> delete.verbose foo - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - foo - -``` -Now for some easy cases. Deleting an unambiguous term, then deleting an -unambiguous type. - -```unison -foo = 1 -structural type Foo = Foo () -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - structural type Foo - foo : Nat - -.> delete.verbose foo - - Removed definitions: - - 1. foo : Nat - - Tip: You can use `undo` or `reflog` to undo this change. - -.> delete.verbose Foo - - Removed definitions: - - 1. structural type Foo - - Tip: You can use `undo` or `reflog` to undo this change. - -.> delete.verbose Foo.Foo - - Removed definitions: - - 1. Foo.Foo : '#089vmor9c5 - - Tip: You can use `undo` or `reflog` to undo this change. - -``` -How about an ambiguous term? - -```unison -foo = 1 -``` - -```ucm - ☝️ The namespace .a is empty. - -.a> add - - ⍟ I've added these definitions: - - foo : ##Nat - -``` -```unison -foo = 2 -``` - -```ucm - ☝️ The namespace .b is empty. - -.b> add - - ⍟ I've added these definitions: - - foo : ##Nat - -.a> merge.old .b - - Here's what's changed in the current namespace after the - merge: - - New name conflicts: - - 1. foo#gjmq673r1v : ##Nat - ↓ - 2. ┌ foo#dcgdua2lj6 : ##Nat - 3. └ foo#gjmq673r1v : ##Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` -A delete should remove both versions of the term. - -```ucm -.> delete.verbose a.foo - - Removed definitions: - - 1. a.foo#gjmq673r1v : Nat - - Name changes: - - Original Changes - 2. b.foo ┐ 3. a.foo#dcgdua2lj6 (removed) - 4. a.foo#dcgdua2lj6 ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -``` -```ucm - ☝️ The namespace .a is empty. - -.a> ls - - nothing to show - -``` -Let's repeat all that on a type, for completeness. - -```unison -structural type Foo = Foo () -``` - -```ucm -.a> add - - ⍟ I've added these definitions: - - structural type Foo - -``` -```unison -structural type Foo = Foo -``` - -```ucm -.b> add - - ⍟ I've added these definitions: - - structural type Foo - -.a> merge.old .b - - Here's what's changed in the current namespace after the - merge: - - New name conflicts: - - 1. structural type Foo#089vmor9c5 - ↓ - 2. ┌ structural type Foo#00nv2kob8f - 3. └ structural type Foo#089vmor9c5 - - 4. Foo.Foo#089vmor9c5#0 : 'Foo#089vmor9c5 - ↓ - 5. ┌ Foo.Foo#00nv2kob8f#0 : () - 6. └ Foo.Foo#089vmor9c5#0 : 'Foo#089vmor9c5 - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` -```ucm -.> delete.verbose a.Foo - - Removed definitions: - - 1. structural type a.Foo#089vmor9c5 - - Name changes: - - Original Changes - 2. b.Foo ┐ 3. a.Foo#00nv2kob8f (removed) - 4. builtin.Unit │ - 5. a.Foo#00nv2kob8f ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -``` -```ucm -.> delete.verbose a.Foo.Foo - - Removed definitions: - - 1. a.Foo.Foo#089vmor9c5#0 : '#089vmor9c5 - - Name changes: - - Original Changes - 2. b.Foo.Foo ┐ 3. a.Foo.Foo#00nv2kob8f#0 (removed) - 4. builtin.Unit.Unit │ - 5. a.Foo.Foo#00nv2kob8f#0 ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -``` -Finally, let's try to delete a term and a type with the same name. - -```unison -foo = 1 -structural type foo = Foo () -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - structural type foo - foo : Nat - -``` -```ucm -.> delete.verbose foo - - Removed definitions: - - 1. structural type foo - 2. foo : Nat - - Tip: You can use `undo` or `reflog` to undo this change. - -``` -We want to be able to delete multiple terms at once - -```unison -a = "a" -b = "b" -c = "c" -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - a : Text - b : Text - c : Text - -.> delete.verbose a b c - - Removed definitions: - - 1. a : Text - 2. b : Text - 3. c : Text - - Tip: You can use `undo` or `reflog` to undo this change. - -``` -We can delete terms and types in the same invocation of delete - -```unison -structural type Foo = Foo () -a = "a" -b = "b" -c = "c" -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - structural type Foo - a : Text - b : Text - c : Text - -.> delete.verbose a b c Foo - - Removed definitions: - - 1. structural type Foo - 2. a : Text - 3. b : Text - 4. c : Text - - Tip: You can use `undo` or `reflog` to undo this change. - -.> delete.verbose Foo.Foo - - Name changes: - - Original Changes - 1. Foo.Foo ┐ 2. Foo.Foo (removed) - 3. foo.Foo ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -``` -We can delete a type and its constructors - -```unison -structural type Foo = Foo () -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - structural type Foo - -.> delete.verbose Foo Foo.Foo - - Removed definitions: - - 1. structural type Foo - - Name changes: - - Original Changes - 2. Foo.Foo ┐ 3. Foo.Foo (removed) - 4. foo.Foo ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -``` -You should not be able to delete terms which are referenced by other terms - -```unison -a = 1 -b = 2 -c = 3 -d = a + b + c -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - a : Nat - b : Nat - (also named b.foo) - c : Nat - d : Nat - -.> delete.verbose a b c - - ⚠️ - - I didn't delete the following definitions because they are - still in use: - - Dependency Referenced In - c 1. d - - a 2. d - -``` -But you should be able to delete all terms which reference each other in a single command - -```unison -e = 11 -f = 12 + e -g = 13 + f -h = e + f + g -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - e : Nat - f : Nat - g : Nat - h : Nat - -.> delete.verbose e f g h - - Removed definitions: - - 1. e : Nat - 2. f : Nat - 3. g : Nat - 4. h : Nat - - Tip: You can use `undo` or `reflog` to undo this change. - -``` -You should be able to delete a type and all the functions that reference it in a single command - -```unison -structural type Foo = Foo Nat - -incrementFoo : Foo -> Nat -incrementFoo = cases - (Foo n) -> n + 1 -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - structural type Foo - incrementFoo : Foo -> Nat - -.> delete.verbose Foo Foo.Foo incrementFoo - - Removed definitions: - - 1. structural type Foo - 2. Foo.Foo : Nat -> #68k40ra7l7 - 3. incrementFoo : #68k40ra7l7 -> Nat - - Tip: You can use `undo` or `reflog` to undo this change. - -``` -If you mess up on one of the names of your command, delete short circuits - -```unison -e = 11 -f = 12 + e -g = 13 + f -h = e + f + g -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - e : Nat - f : Nat - g : Nat - h : Nat - -.> delete.verbose e f gg - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - gg - -``` -Cyclical terms which are guarded by a lambda are allowed to be deleted - -```unison -ping _ = 1 Nat.+ !pong -pong _ = 4 Nat.+ !ping -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - ping : 'Nat - pong : 'Nat - -.> delete.verbose ping - - Removed definitions: - - 1. ping : 'Nat - - Tip: You can use `undo` or `reflog` to undo this change. - -.> view pong - - pong : 'Nat - pong _ = - use Nat + - 4 + !#l9uq1dpl5v.1 - -``` diff --git a/unison-src/transcripts/dependents-dependencies-debugfile.md b/unison-src/transcripts/dependents-dependencies-debugfile.md deleted file mode 100644 index 46ffce8d30..0000000000 --- a/unison-src/transcripts/dependents-dependencies-debugfile.md +++ /dev/null @@ -1,38 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -### `debug.file` -I can use `debug.file` to see the hashes of the last typechecked file. - -Given this .u file: -```unison:hide -structural type outside.A = A Nat outside.B -structural type outside.B = B Int -outside.c = 3 -outside.d = c < (p + 1) - -structural type inside.M = M outside.A -inside.p = c -inside.q x = x + p * p -inside.r = d -``` -```ucm -.> debug.file -``` - -This will help me make progress in some situations when UCM is being deficient or broken. - -### `dependents` / `dependencies` -But wait, there's more. I can check the dependencies and dependents of a definition: -```ucm -.> add -.> dependents q -.> dependencies q -.> dependencies B -.> dependencies d -.> dependents d -.> -``` - -We don't have an index for dependents of constructors, but iirc if you ask for that, it will show you dependents of the structural type that provided the constructor. diff --git a/unison-src/transcripts/dependents-dependencies-debugfile.output.md b/unison-src/transcripts/dependents-dependencies-debugfile.output.md deleted file mode 100644 index 413c7c2108..0000000000 --- a/unison-src/transcripts/dependents-dependencies-debugfile.output.md +++ /dev/null @@ -1,112 +0,0 @@ -### `debug.file` -I can use `debug.file` to see the hashes of the last typechecked file. - -Given this .u file: -```unison -structural type outside.A = A Nat outside.B -structural type outside.B = B Int -outside.c = 3 -outside.d = c < (p + 1) - -structural type inside.M = M outside.A -inside.p = c -inside.q x = x + p * p -inside.r = d -``` - -```ucm -.> debug.file - - type inside.M#h37a56c5ep - type outside.A#6l6krl7n4l - type outside.B#eo6rj0lj1b - inside.p#htoo5rnb54 - inside.q#vtdbqaojv6 - inside.r#nkgohbke6n - outside.c#f3lgjvjqoo - outside.d#ukd7tu6kds - -``` -This will help me make progress in some situations when UCM is being deficient or broken. - -### `dependents` / `dependencies` -But wait, there's more. I can check the dependencies and dependents of a definition: -```ucm -.> add - - ⍟ I've added these definitions: - - structural type inside.M - structural type outside.A - structural type outside.B - inside.p : Nat - inside.q : Nat -> Nat - inside.r : Boolean - outside.c : Nat - outside.d : Boolean - -.> dependents q - - q has no dependents. - -.> dependencies q - - Dependencies of: q - - Types: - - 1. Nat - - Terms: - - 2. Nat.* - 3. Nat.+ - 4. p - - Tip: Try `view 4` to see the source of any numbered item in - the above list. - -.> dependencies B - - Dependencies of: type B, B - - Types: - - 1. B - 2. Int - - Tip: Try `view 2` to see the source of any numbered item in - the above list. - -.> dependencies d - - Dependencies of: d - - Types: - - 1. Boolean - 2. Nat - - Terms: - - 3. < - 4. c - 5. Nat.+ - 6. p - - Tip: Try `view 6` to see the source of any numbered item in - the above list. - -.> dependents d - - Dependents of: d - - Terms: - - 1. r - - Tip: Try `view 1` to see the source of any numbered item in - the above list. - -``` -We don't have an index for dependents of constructors, but iirc if you ask for that, it will show you dependents of the structural type that provided the constructor. diff --git a/unison-src/transcripts/destructuring-binds.md b/unison-src/transcripts/destructuring-binds.md deleted file mode 100644 index f9a1eef975..0000000000 --- a/unison-src/transcripts/destructuring-binds.md +++ /dev/null @@ -1,79 +0,0 @@ -# Destructuring binds - -```ucm:hide -.> builtins.merge -``` - -Here's a couple examples: - -```unison -ex0 : Nat -> Nat -ex0 n = - (a, _, (c,d)) = ("uno", "dos", (n, 7)) - c + d - -ex1 : (a,b,(Nat,Nat)) -> Nat -ex1 tup = - (a, b, (c,d)) = tup - c + d -``` - -```ucm -.> add -.> view ex0 ex1 -``` - -Notice that `ex0` is printed using the `cases` syntax (but `ex1` is not). The pretty-printer currently prefers the `cases` syntax if definition can be printed using either destructuring bind or `cases`. - -A destructuring bind is just syntax for a single branch pattern match. Notice that Unison detects this function as an alias of `ex1`: - -```unison -ex2 : (a,b,(Nat,Nat)) -> Nat -ex2 tup = match tup with - (a, b, (c,d)) -> c + d -``` - -## Corner cases - -Destructuring binds can't be recursive: the left-hand side bound variables aren't available on the right hand side. For instance, this doesn't typecheck: - -```unison:error -ex4 = - (a,b) = (a Nat.+ b, 19) - "Doesn't typecheck" -``` - -Even though the parser accepts any pattern on the LHS of a bind, it looks pretty weird to see things like `12 = x`, so we avoid showing a destructuring bind when the LHS is a "literal" pattern (like `42` or "hi"). Again these examples wouldn't compile with coverage checking. - -```unison -ex5 : 'Text -ex5 _ = match 99 + 1 with - 12 -> "Hi" - _ -> "Bye" - -ex5a : 'Text -ex5a _ = match (99 + 1, "hi") with - (x, "hi") -> "Not printed as a destructuring bind." - _ -> "impossible" -``` - -```ucm -.> add -.> view ex5 ex5a -``` - -Notice how it prints both an ordinary match. - -Also, for clarity, the pretty-printer shows a single-branch match if the match shadows free variables of the scrutinee, for example: - -```unison:hide -ex6 x = match x with - (x, y) -> x Nat.+ y -``` - -For clarity, the pretty-printer leaves this alone, even though in theory it could be written `(x,y) = x; x + y`: - -```ucm -.> add -.> view ex6 -``` diff --git a/unison-src/transcripts/destructuring-binds.output.md b/unison-src/transcripts/destructuring-binds.output.md deleted file mode 100644 index af097fc522..0000000000 --- a/unison-src/transcripts/destructuring-binds.output.md +++ /dev/null @@ -1,177 +0,0 @@ -# Destructuring binds - -Here's a couple examples: - -```unison -ex0 : Nat -> Nat -ex0 n = - (a, _, (c,d)) = ("uno", "dos", (n, 7)) - c + d - -ex1 : (a,b,(Nat,Nat)) -> Nat -ex1 tup = - (a, b, (c,d)) = tup - c + d -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex0 : Nat -> Nat - ex1 : (a, b, (Nat, Nat)) -> Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - ex0 : Nat -> Nat - ex1 : (a, b, (Nat, Nat)) -> Nat - -.> view ex0 ex1 - - ex0 : Nat -> Nat - ex0 n = - use Nat + - (a, _, (c, d)) = ("uno", "dos", (n, 7)) - c + d - - ex1 : (a, b, (Nat, Nat)) -> Nat - ex1 = cases (a, b, (c, d)) -> c Nat.+ d - -``` -Notice that `ex0` is printed using the `cases` syntax (but `ex1` is not). The pretty-printer currently prefers the `cases` syntax if definition can be printed using either destructuring bind or `cases`. - -A destructuring bind is just syntax for a single branch pattern match. Notice that Unison detects this function as an alias of `ex1`: - -```unison -ex2 : (a,b,(Nat,Nat)) -> Nat -ex2 tup = match tup with - (a, b, (c,d)) -> c + d -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex2 : (a, b, (Nat, Nat)) -> Nat - (also named ex1) - -``` -## Corner cases - -Destructuring binds can't be recursive: the left-hand side bound variables aren't available on the right hand side. For instance, this doesn't typecheck: - -```unison -ex4 = - (a,b) = (a Nat.+ b, 19) - "Doesn't typecheck" -``` - -```ucm - - Loading changes detected in scratch.u. - - I couldn't figure out what a refers to here: - - 2 | (a,b) = (a Nat.+ b, 19) - - I think its type should be: - - Nat - - Some common causes of this error include: - * Your current namespace is too deep to contain the - definition in its subtree - * The definition is part of a library which hasn't been - added to this project - * You have a typo in the name - -``` -Even though the parser accepts any pattern on the LHS of a bind, it looks pretty weird to see things like `12 = x`, so we avoid showing a destructuring bind when the LHS is a "literal" pattern (like `42` or "hi"). Again these examples wouldn't compile with coverage checking. - -```unison -ex5 : 'Text -ex5 _ = match 99 + 1 with - 12 -> "Hi" - _ -> "Bye" - -ex5a : 'Text -ex5a _ = match (99 + 1, "hi") with - (x, "hi") -> "Not printed as a destructuring bind." - _ -> "impossible" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex5 : 'Text - ex5a : 'Text - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - ex5 : 'Text - ex5a : 'Text - -.> view ex5 ex5a - - ex5 : 'Text - ex5 _ = match 99 Nat.+ 1 with - 12 -> "Hi" - _ -> "Bye" - - ex5a : 'Text - ex5a _ = match (99 Nat.+ 1, "hi") with - (x, "hi") -> "Not printed as a destructuring bind." - _ -> "impossible" - -``` -Notice how it prints both an ordinary match. - -Also, for clarity, the pretty-printer shows a single-branch match if the match shadows free variables of the scrutinee, for example: - -```unison -ex6 x = match x with - (x, y) -> x Nat.+ y -``` - -For clarity, the pretty-printer leaves this alone, even though in theory it could be written `(x,y) = x; x + y`: - -```ucm -.> add - - ⍟ I've added these definitions: - - ex6 : (Nat, Nat) -> Nat - -.> view ex6 - - ex6 : (Nat, Nat) -> Nat - ex6 = cases (x, y) -> x Nat.+ y - -``` diff --git a/unison-src/transcripts/diff-namespace.md b/unison-src/transcripts/diff-namespace.md deleted file mode 100644 index 5e938a79a5..0000000000 --- a/unison-src/transcripts/diff-namespace.md +++ /dev/null @@ -1,202 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison:hide -x = 23 -``` - -```ucm -.b1> add -.b1> alias.term x fslkdjflskdjflksjdf -.> fork b1 b2 -.b2> alias.term x abc -``` -```unison:hide -fslkdjflskdjflksjdf = 663 -``` -```ucm -.b0> add -.> merge.old b0 b1 -.> diff.namespace b1 b2 -.b2> diff.namespace .b1 -``` -Things we want to test: - -* Diffing identical namespaces -* Adds, removes, updates - * Adds with multiple names -* Moved and copied definitions - * Moves that have more that 1 initial or final name -* ... terms and types -* New patches, modified patches, deleted patches, moved patches -* With and without propagated updates - -```unison:hide -fromJust = 1 -b = 2 -bdependent = b -c = 3 -helloWorld = "Hello, world!" - -structural type A a = A () -structural ability X a1 a2 where x : () -``` - -```ucm -.ns1> add -.ns1> alias.term fromJust fromJust' -.ns1> alias.term helloWorld helloWorld2 -.ns1> fork .ns1 .ns2 -``` - -Here's what we've done so far: - -```ucm:error -.> diff.namespace nothing ns1 -``` - -```ucm:error -.> diff.namespace ns1 ns2 -``` - -```unison:hide -fromJust = "asldkfjasldkfj" -``` - -```ucm -.ns1b> add -.> merge.old ns1b ns1 -``` - -```unison:hide -fromJust = 99 -b = "oog" -d = 4 -e = 5 -f = 6 -unique type Y a b = Y a b -``` - -```ucm -.ns2> update.old -.> diff.namespace ns1 ns2 -.> alias.term ns2.d ns2.d' -.> alias.type ns2.A ns2.A' -.> alias.type ns2.X ns2.X' -.> diff.namespace ns1 ns2 -.> alias.type ns1.X ns1.X2 -.> alias.type ns2.A' ns2.A'' -.> fork ns2 ns3 -.> alias.term ns2.fromJust' ns2.yoohoo -.> delete.term.verbose ns2.fromJust' -.> diff.namespace ns3 ns2 -``` -```unison:hide -bdependent = "banana" -``` -```ucm -.ns3> update.old -.> diff.namespace ns2 ns3 -``` - - -## Two different auto-propagated changes creating a name conflict -Currently, the auto-propagated name-conflicted definitions are not explicitly -shown, only their also-conflicted dependency is shown. -```unison:hide -a = 333 -b = a + 1 -``` -```ucm -.nsx> add -.> fork nsx nsy -.> fork nsx nsz -``` -```unison:hide -a = 444 -``` -```ucm -.nsy> update.old -``` -```unison:hide -a = 555 -``` -```ucm -.nsz> update.old -.> merge.old nsy nsw -``` -```ucm:error -.> merge.old nsz nsw -``` -```ucm -.> diff.namespace nsx nsw -.nsw> view a b -``` - -## Should be able to diff a namespace hash from history. - -```unison -x = 1 -``` - -```ucm -.hashdiff> add -``` - -```unison -y = 2 -``` - -```ucm -.hashdiff> add -.hashdiff> history -.hashdiff> diff.namespace 2 1 -``` - -## - -Updates: -- 1 to 1 - -New name conflicts: -- updates where RHS has multiple hashes (excluding when RHS=LHS) - - 1. foo#jk19sm5bf8 : Nat - do we want to force a hashqualified? Arya thinks so - ↓ - 2. ┌ foo#0ja1qfpej6 : Nat - 3. └ foo#jk19sm5bf8 : Nat - -Resolved name conflicts: -- updates where LHS had multiple hashes and RHS has one - - 4. ┌ bar#0ja1qfpej6 : Nat - 5. └ bar#jk19sm5bf8 : Nat - ↓ - 6. bar#jk19sm5bf8 : Nat - -## Display issues to fixup - -- [d] Do we want to surface new edit conflicts in patches? -- [t] two different auto-propagated changes creating a name conflict should show - up somewhere besides the auto-propagate count -- [t] Things look screwy when the type signature doesn't fit and has to get broken - up into multiple lines. Maybe just disallow that? -- [d] Delete blank line in between copies / renames entries if all entries are 1 to 1 - see todo in the code -- [x] incorrectly calculated bracket alignment on hashqualified "Name changes" (delete.output.md) -- [x] just handle deletion of isPropagated in propagate function, leave HandleInput alone (assuming this does the trick) -- [x] might want unqualified names to be qualified sometimes: -- [x] if a name is updated to a not-yet-named reference, it's shown as both an update and an add -- [x] similarly, if a conflicted name is resolved by deleting the last name to - a reference, I (arya) suspect it will show up as a Remove -- [d] Maybe group and/or add headings to the types, constructors, terms -- [x] add tagging of propagated updates to test propagated updates output -- [x] missing old names in deletion ppe (delete.output.md) (superseded by \#1143) -- [x] delete.term has some bonkers output -- [x] Make a decision about how we want to show constructors in the diff -- [x] 12.patch patch needs a space -- [x] This looks like garbage -- [x] Extra 2 blank lines at the end of the add section -- [x] Fix alignment issues with buildTable, convert to column3M (to be written) -- [x] adding an alias is showing up as an Add and a Copy; should just show as Copy -- [x] removing one of multiple aliases appears in removes + moves + copies section -- [x] some overlapping cases between Moves and Copies^ -- [x] Maybe don't list the type signature twice for aliases? diff --git a/unison-src/transcripts/diff-namespace.output.md b/unison-src/transcripts/diff-namespace.output.md deleted file mode 100644 index cacb9d1fc4..0000000000 --- a/unison-src/transcripts/diff-namespace.output.md +++ /dev/null @@ -1,611 +0,0 @@ -```unison -x = 23 -``` - -```ucm - ☝️ The namespace .b1 is empty. - -.b1> add - - ⍟ I've added these definitions: - - x : ##Nat - -.b1> alias.term x fslkdjflskdjflksjdf - - Done. - -.> fork b1 b2 - - Done. - -.b2> alias.term x abc - - Done. - -``` -```unison -fslkdjflskdjflksjdf = 663 -``` - -```ucm - ☝️ The namespace .b0 is empty. - -.b0> add - - ⍟ I've added these definitions: - - fslkdjflskdjflksjdf : ##Nat - -.> merge.old b0 b1 - - Here's what's changed in b1 after the merge: - - New name conflicts: - - 1. fslkdjflskdjflksjdf#u520d1t9kc : Nat - ↓ - 2. ┌ fslkdjflskdjflksjdf#sekb3fdsvb : Nat - 3. └ fslkdjflskdjflksjdf#u520d1t9kc : Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.> diff.namespace b1 b2 - - Resolved name conflicts: - - 1. ┌ fslkdjflskdjflksjdf#sekb3fdsvb : Nat - 2. └ fslkdjflskdjflksjdf#u520d1t9kc : Nat - ↓ - 3. fslkdjflskdjflksjdf#u520d1t9kc : Nat - - Name changes: - - Original Changes - 4. x ┐ 5. abc (added) - 6. fslkdjflskdjflksjdf#u520d1t9kc ┘ 7. fslkdjflskdjflksjdf (added) - 8. fslkdjflskdjflksjdf#u520d1t9kc (removed) - -.b2> diff.namespace .b1 - - Resolved name conflicts: - - 1. ┌ fslkdjflskdjflksjdf#sekb3fdsvb : ##Nat - 2. └ fslkdjflskdjflksjdf#u520d1t9kc : ##Nat - ↓ - 3. fslkdjflskdjflksjdf#u520d1t9kc : ##Nat - - Name changes: - - Original Changes - 4. x ┐ 5. abc (added) - 6. fslkdjflskdjflksjdf#u520d1t9kc ┘ 7. fslkdjflskdjflksjdf (added) - 8. fslkdjflskdjflksjdf#u520d1t9kc (removed) - -``` -Things we want to test: - -* Diffing identical namespaces -* Adds, removes, updates - * Adds with multiple names -* Moved and copied definitions - * Moves that have more that 1 initial or final name -* ... terms and types -* New patches, modified patches, deleted patches, moved patches -* With and without propagated updates - -```unison -fromJust = 1 -b = 2 -bdependent = b -c = 3 -helloWorld = "Hello, world!" - -structural type A a = A () -structural ability X a1 a2 where x : () -``` - -```ucm - ☝️ The namespace .ns1 is empty. - -.ns1> add - - ⍟ I've added these definitions: - - structural type A a - structural ability X a1 a2 - b : ##Nat - bdependent : ##Nat - c : ##Nat - fromJust : ##Nat - helloWorld : ##Text - -.ns1> alias.term fromJust fromJust' - - Done. - -.ns1> alias.term helloWorld helloWorld2 - - Done. - -.ns1> fork .ns1 .ns2 - - Done. - -``` -Here's what we've done so far: - -```ucm -.> diff.namespace nothing ns1 - - ⚠️ - - The namespace .nothing is empty. Was there a typo? - -``` -```ucm -.> diff.namespace ns1 ns2 - - The namespaces are identical. - -``` -```unison -fromJust = "asldkfjasldkfj" -``` - -```ucm - ☝️ The namespace .ns1b is empty. - -.ns1b> add - - ⍟ I've added these definitions: - - fromJust : ##Text - -.> merge.old ns1b ns1 - - Here's what's changed in ns1 after the merge: - - New name conflicts: - - 1. fromJust#gjmq673r1v : Nat - ↓ - 2. ┌ fromJust#gjmq673r1v : Nat - 3. └ fromJust#rnbo52q2sh : Text - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` -```unison -fromJust = 99 -b = "oog" -d = 4 -e = 5 -f = 6 -unique type Y a b = Y a b -``` - -```ucm -.ns2> update.old - - ⍟ I've added these definitions: - - type Y a b - d : ##Nat - e : ##Nat - f : ##Nat - - ⍟ I've updated these names to your new definition: - - b : ##Text - fromJust : ##Nat - (The old definition was also named fromJust'.) - -.> diff.namespace ns1 ns2 - - Resolved name conflicts: - - 1. ┌ fromJust#gjmq673r1v : Nat - 2. └ fromJust#rnbo52q2sh : Text - ↓ - 3. fromJust#6gn1k53ie0 : Nat - - Updates: - - 4. b : Nat - ↓ - 5. b : Text - - 6. fromJust' : Nat - ↓ - 7. fromJust' : Nat - - Added definitions: - - 8. type Y a b - 9. Y.Y : a -> b -> Y a b - 10. d : Nat - 11. e : Nat - 12. f : Nat - - 13. patch patch (added 2 updates) - -.> alias.term ns2.d ns2.d' - - Done. - -.> alias.type ns2.A ns2.A' - - Done. - -.> alias.type ns2.X ns2.X' - - Done. - -.> diff.namespace ns1 ns2 - - Resolved name conflicts: - - 1. ┌ fromJust#gjmq673r1v : Nat - 2. └ fromJust#rnbo52q2sh : Text - ↓ - 3. fromJust#6gn1k53ie0 : Nat - - Updates: - - 4. b : Nat - ↓ - 5. b : Text - - 6. fromJust' : Nat - ↓ - 7. fromJust' : Nat - - Added definitions: - - 8. type Y a b - 9. Y.Y : a -> b -> Y a b - 10. ┌ d : Nat - 11. └ d' : Nat - 12. e : Nat - 13. f : Nat - - 14. patch patch (added 2 updates) - - Name changes: - - Original Changes - 15. A 16. A' (added) - - 17. X 18. X' (added) - -.> alias.type ns1.X ns1.X2 - - Done. - -.> alias.type ns2.A' ns2.A'' - - Done. - -.> fork ns2 ns3 - - Done. - -.> alias.term ns2.fromJust' ns2.yoohoo - - Done. - -.> delete.term.verbose ns2.fromJust' - - Name changes: - - Original Changes - 1. ns2.fromJust ┐ 2. ns2.fromJust' (removed) - 3. ns2.fromJust' │ - 4. ns2.yoohoo │ - 5. ns3.fromJust │ - 6. ns3.fromJust' ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -.> diff.namespace ns3 ns2 - - Name changes: - - Original Changes - 1. fromJust ┐ 2. yoohoo (added) - 3. fromJust' ┘ 4. fromJust' (removed) - -``` -```unison -bdependent = "banana" -``` - -```ucm -.ns3> update.old - - ⍟ I've updated these names to your new definition: - - bdependent : ##Text - -.> diff.namespace ns2 ns3 - - Updates: - - 1. bdependent : Nat - ↓ - 2. bdependent : Text - - 3. patch patch (added 1 updates) - - Name changes: - - Original Changes - 4. fromJust ┐ 5. fromJust' (added) - 6. yoohoo ┘ 7. yoohoo (removed) - -``` -## Two different auto-propagated changes creating a name conflict -Currently, the auto-propagated name-conflicted definitions are not explicitly -shown, only their also-conflicted dependency is shown. -```unison -a = 333 -b = a + 1 -``` - -```ucm - ☝️ The namespace .nsx is empty. - -.nsx> add - - ⍟ I've added these definitions: - - a : ##Nat - b : ##Nat - -.> fork nsx nsy - - Done. - -.> fork nsx nsz - - Done. - -``` -```unison -a = 444 -``` - -```ucm -.nsy> update.old - - ⍟ I've updated these names to your new definition: - - a : ##Nat - -``` -```unison -a = 555 -``` - -```ucm -.nsz> update.old - - ⍟ I've updated these names to your new definition: - - a : ##Nat - -.> merge.old nsy nsw - - Here's what's changed in nsw after the merge: - - Added definitions: - - 1. a : Nat - 2. b : Nat - - 3. patch patch (added 1 updates) - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` -```ucm -.> merge.old nsz nsw - - Here's what's changed in nsw after the merge: - - New name conflicts: - - 1. a#mdl4vqtu00 : Nat - ↓ - 2. ┌ a#mdl4vqtu00 : Nat - 3. └ a#vrs8gtkl2t : Nat - - 4. b#unkqhuu66p : Nat - ↓ - 5. ┌ b#aapqletas7 : Nat - 6. └ b#unkqhuu66p : Nat - - Updates: - - 7. patch patch (added 1 updates) - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - - I tried to auto-apply the patch, but couldn't because it - contained contradictory entries. - -``` -```ucm -.> diff.namespace nsx nsw - - New name conflicts: - - 1. a#uiiiv8a86s : Nat - ↓ - 2. ┌ a#mdl4vqtu00 : Nat - 3. └ a#vrs8gtkl2t : Nat - - 4. b#lhigeb1let : Nat - ↓ - 5. ┌ b#aapqletas7 : Nat - 6. └ b#unkqhuu66p : Nat - - Added definitions: - - 7. patch patch (added 2 updates) - -.nsw> view a b - - a#mdl4vqtu00 : ##Nat - a#mdl4vqtu00 = 444 - - a#vrs8gtkl2t : ##Nat - a#vrs8gtkl2t = 555 - - b#aapqletas7 : ##Nat - b#aapqletas7 = ##Nat.+ a#vrs8gtkl2t 1 - - b#unkqhuu66p : ##Nat - b#unkqhuu66p = ##Nat.+ a#mdl4vqtu00 1 - -``` -## Should be able to diff a namespace hash from history. - -```unison -x = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - x : ##Nat - -``` -```ucm - ☝️ The namespace .hashdiff is empty. - -.hashdiff> add - - ⍟ I've added these definitions: - - x : ##Nat - -``` -```unison -y = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - y : ##Nat - -``` -```ucm -.hashdiff> add - - ⍟ I've added these definitions: - - y : ##Nat - -.hashdiff> history - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #ru1hnjofdj - - + Adds / updates: - - y - - □ 2. #i52j9fd57b (start of history) - -.hashdiff> diff.namespace 2 1 - - Added definitions: - - 1. y : ##Nat - -``` -## - -Updates: -- 1 to 1 - -New name conflicts: -- updates where RHS has multiple hashes (excluding when RHS=LHS) - - 1. foo#jk19sm5bf8 : Nat - do we want to force a hashqualified? Arya thinks so - ↓ - 2. ┌ foo#0ja1qfpej6 : Nat - 3. └ foo#jk19sm5bf8 : Nat - -Resolved name conflicts: -- updates where LHS had multiple hashes and RHS has one - - 4. ┌ bar#0ja1qfpej6 : Nat - 5. └ bar#jk19sm5bf8 : Nat - ↓ - 6. bar#jk19sm5bf8 : Nat - -## Display issues to fixup - -- [d] Do we want to surface new edit conflicts in patches? -- [t] two different auto-propagated changes creating a name conflict should show - up somewhere besides the auto-propagate count -- [t] Things look screwy when the type signature doesn't fit and has to get broken - up into multiple lines. Maybe just disallow that? -- [d] Delete blank line in between copies / renames entries if all entries are 1 to 1 - see todo in the code -- [x] incorrectly calculated bracket alignment on hashqualified "Name changes" (delete.output.md) -- [x] just handle deletion of isPropagated in propagate function, leave HandleInput alone (assuming this does the trick) -- [x] might want unqualified names to be qualified sometimes: -- [x] if a name is updated to a not-yet-named reference, it's shown as both an update and an add -- [x] similarly, if a conflicted name is resolved by deleting the last name to - a reference, I (arya) suspect it will show up as a Remove -- [d] Maybe group and/or add headings to the types, constructors, terms -- [x] add tagging of propagated updates to test propagated updates output -- [x] missing old names in deletion ppe (delete.output.md) (superseded by \#1143) -- [x] delete.term has some bonkers output -- [x] Make a decision about how we want to show constructors in the diff -- [x] 12.patch patch needs a space -- [x] This looks like garbage -- [x] Extra 2 blank lines at the end of the add section -- [x] Fix alignment issues with buildTable, convert to column3M (to be written) -- [x] adding an alias is showing up as an Add and a Copy; should just show as Copy -- [x] removing one of multiple aliases appears in removes + moves + copies section -- [x] some overlapping cases between Moves and Copies^ -- [x] Maybe don't list the type signature twice for aliases? diff --git a/unison-src/transcripts/doc-formatting.md b/unison-src/transcripts/doc-formatting.md deleted file mode 100644 index 51f6c51bca..0000000000 --- a/unison-src/transcripts/doc-formatting.md +++ /dev/null @@ -1,254 +0,0 @@ -This transcript explains a few minor details about doc parsing and pretty-printing, both from a user point of view and with some implementation notes. The later stuff is meant more as unit testing than for human consumption. (The ucm `add` commands and their output are hidden for brevity.) - -Docs can be used as inline code comments. - -```ucm:hide -.> builtins.merge -``` - -```unison -foo : Nat -> Nat -foo n = - _ = [: do the thing :] - n + 1 -``` - -```ucm:hide -.> add -``` -```ucm -.> view foo -``` - -Note that `@` and `:]` must be escaped within docs. - -```unison -escaping = [: Docs look [: like \@this \:] :] -``` - -```ucm:hide -.> add -``` -```ucm -.> view escaping -``` - -(Alas you can't have `\@` or `\:]` in your doc, as there's currently no way to 'unescape' them.) - -```unison --- Note that -- comments are preserved within doc literals. -commented = [: - example: - - -- a comment - f x = x + 1 -:] -``` - -```ucm:hide -.> add -``` -```ucm -.> view commented -``` - -### Indenting, and paragraph reflow - -Handling of indenting in docs between the parser and pretty-printer is a bit fiddly. - -```unison --- The leading and trailing spaces are stripped from the stored Doc by the --- lexer, and one leading and trailing space is inserted again on view/edit --- by the pretty-printer. -doc1 = [: hi :] -``` - -```ucm:hide -.> add -``` -```ucm -.> view doc1 -``` - -```unison --- Lines (apart from the first line, i.e. the bit between the [: and the --- first newline) are unindented until at least one of --- them hits the left margin (by a post-processing step in the parser). --- You may not notice this because the pretty-printer indents them again on --- view/edit. -doc2 = [: hello - - foo - - bar - and the rest. :] -``` - -```ucm:hide -.> add -``` -```ucm -.> view doc2 -``` - -```unison -doc3 = [: When Unison identifies a paragraph, it removes any newlines from it before storing it, and then reflows the paragraph text to fit the display window on display/view/edit. - -For these purposes, a paragraph is any sequence of non-empty lines that have zero indent (after the unindenting mentioned above.) - - - So this is not a paragraph, even - though you might want it to be. - - And this text | as a paragraph - is not treated | either. - -Note that because of the special treatment of the first line mentioned above, where its leading space is removed, it is always treated as a paragraph. - :] -``` - -```ucm:hide -.> add -``` -```ucm -.> view doc3 -``` - -```unison -doc4 = [: Here's another example of some paragraphs. - - All these lines have zero indent. - - - Apart from this one. :] -``` - -```ucm:hide -.> add -``` -```ucm -.> view doc4 -``` - -```unison --- The special treatment of the first line does mean that the following --- is pretty-printed not so prettily. To fix that we'd need to get the --- lexer to help out with interpreting doc literal indentation (because --- it knows what columns the `[:` was in.) -doc5 = [: - foo - - bar - and the rest. :] -``` - -```ucm:hide -.> add -``` -```ucm -.> view doc5 -``` - -```unison --- You can do the following to avoid that problem. -doc6 = [: - - foo - - bar - and the rest. - :] -``` - -```ucm:hide -.> add -``` -```ucm -.> view doc6 -``` - -### More testing - -```unison --- Check empty doc works. -empty = [::] - -expr = foo 1 -``` -```ucm:hide -.> add -``` -```ucm -.> view empty -``` - -```unison -test1 = [: -The internal logic starts to get hairy when you use the \@ features, for example referencing a name like @List.take. Internally, the text between each such usage is its own blob (blob ends here --> @List.take), so paragraph reflow has to be aware of multiple blobs to do paragraph reflow (or, more accurately, to do the normalization step where newlines with a paragraph are removed.) - -Para to reflow: lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor ending in ref @List.take - -@List.take starting para lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor. - -Middle of para: lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor @List.take lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor. - - - non-para line (@List.take) with ref @List.take - Another non-para line - @List.take starting non-para line - - - non-para line with ref @List.take -before a para-line lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor. - - - non-para line followed by a para line starting with ref -@List.take lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor. - -a para-line ending with ref lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor @List.take - - non-para line - -para line lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor - @List.take followed by non-para line starting with ref. - -@[signature] List.take - -@[source] foo - -@[evaluate] expr - -@[include] doc1 - --- note the leading space below - @[signature] List.take - -:] -``` -```ucm:hide -.> add -``` -```ucm -.> view test1 -``` - -```unison --- Regression test for #1363 - preservation of spaces after @ directives in first line when unindenting -reg1363 = [: `@List.take foo` bar - baz :] -``` -```ucm:hide -.> add -``` -```ucm -.> view reg1363 -``` - -```unison --- Demonstrate doc display when whitespace follows a @[source] or @[evaluate] --- whose output spans multiple lines. - -test2 = [: - Take a look at this: - @[source] foo ▶ bar -:] -``` -```ucm:hide -.> add -``` -View is fine. -```ucm -.> view test2 -``` -But note it's not obvious how display should best be handling this. At the moment it just does the simplest thing: -```ucm -.> display test2 -``` diff --git a/unison-src/transcripts/doc-formatting.output.md b/unison-src/transcripts/doc-formatting.output.md deleted file mode 100644 index d4c000906f..0000000000 --- a/unison-src/transcripts/doc-formatting.output.md +++ /dev/null @@ -1,535 +0,0 @@ -This transcript explains a few minor details about doc parsing and pretty-printing, both from a user point of view and with some implementation notes. The later stuff is meant more as unit testing than for human consumption. (The ucm `add` commands and their output are hidden for brevity.) - -Docs can be used as inline code comments. - -```unison -foo : Nat -> Nat -foo n = - _ = [: do the thing :] - n + 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo : Nat -> Nat - -``` -```ucm -.> view foo - - foo : Nat -> Nat - foo n = - use Nat + - _ = [: do the thing :] - n + 1 - -``` -Note that `@` and `:]` must be escaped within docs. - -```unison -escaping = [: Docs look [: like \@this \:] :] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - escaping : Doc - -``` -```ucm -.> view escaping - - escaping : Doc - escaping = [: Docs look [: like \@this \:] :] - -``` -(Alas you can't have `\@` or `\:]` in your doc, as there's currently no way to 'unescape' them.) - -```unison --- Note that -- comments are preserved within doc literals. -commented = [: - example: - - -- a comment - f x = x + 1 -:] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - commented : Doc - -``` -```ucm -.> view commented - - commented : Doc - commented = - [: example: - - -- a comment f x = x + 1 - :] - -``` -### Indenting, and paragraph reflow - -Handling of indenting in docs between the parser and pretty-printer is a bit fiddly. - -```unison --- The leading and trailing spaces are stripped from the stored Doc by the --- lexer, and one leading and trailing space is inserted again on view/edit --- by the pretty-printer. -doc1 = [: hi :] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - doc1 : Doc - -``` -```ucm -.> view doc1 - - doc1 : Doc - doc1 = [: hi :] - -``` -```unison --- Lines (apart from the first line, i.e. the bit between the [: and the --- first newline) are unindented until at least one of --- them hits the left margin (by a post-processing step in the parser). --- You may not notice this because the pretty-printer indents them again on --- view/edit. -doc2 = [: hello - - foo - - bar - and the rest. :] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - doc2 : Doc - -``` -```ucm -.> view doc2 - - doc2 : Doc - doc2 = - [: hello - - foo - - bar - and the rest. :] - -``` -```unison -doc3 = [: When Unison identifies a paragraph, it removes any newlines from it before storing it, and then reflows the paragraph text to fit the display window on display/view/edit. - -For these purposes, a paragraph is any sequence of non-empty lines that have zero indent (after the unindenting mentioned above.) - - - So this is not a paragraph, even - though you might want it to be. - - And this text | as a paragraph - is not treated | either. - -Note that because of the special treatment of the first line mentioned above, where its leading space is removed, it is always treated as a paragraph. - :] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - doc3 : Doc - -``` -```ucm -.> view doc3 - - doc3 : Doc - doc3 = - [: When Unison identifies a paragraph, it removes any - newlines from it before storing it, and then reflows the - paragraph text to fit the display window on - display/view/edit. - - For these purposes, a paragraph is any sequence of non-empty - lines that have zero indent (after the unindenting mentioned - above.) - - - So this is not a paragraph, even - though you might want it to be. - - And this text | as a paragraph - is not treated | either. - - Note that because of the special treatment of the first line - mentioned above, where its leading space is removed, it is - always treated as a paragraph. - :] - -``` -```unison -doc4 = [: Here's another example of some paragraphs. - - All these lines have zero indent. - - - Apart from this one. :] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - doc4 : Doc - -``` -```ucm -.> view doc4 - - doc4 : Doc - doc4 = - [: Here's another example of some paragraphs. - - All these lines have zero indent. - - - Apart from this one. :] - -``` -```unison --- The special treatment of the first line does mean that the following --- is pretty-printed not so prettily. To fix that we'd need to get the --- lexer to help out with interpreting doc literal indentation (because --- it knows what columns the `[:` was in.) -doc5 = [: - foo - - bar - and the rest. :] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - doc5 : Doc - -``` -```ucm -.> view doc5 - - doc5 : Doc - doc5 = - [: - foo - - bar - and the rest. :] - -``` -```unison --- You can do the following to avoid that problem. -doc6 = [: - - foo - - bar - and the rest. - :] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - doc6 : Doc - -``` -```ucm -.> view doc6 - - doc6 : Doc - doc6 = - [: - foo - - bar - and the rest. - :] - -``` -### More testing - -```unison --- Check empty doc works. -empty = [::] - -expr = foo 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - empty : Doc - expr : Nat - -``` -```ucm -.> view empty - - empty : Doc - empty = [: :] - -``` -```unison -test1 = [: -The internal logic starts to get hairy when you use the \@ features, for example referencing a name like @List.take. Internally, the text between each such usage is its own blob (blob ends here --> @List.take), so paragraph reflow has to be aware of multiple blobs to do paragraph reflow (or, more accurately, to do the normalization step where newlines with a paragraph are removed.) - -Para to reflow: lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor ending in ref @List.take - -@List.take starting para lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor. - -Middle of para: lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor @List.take lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor. - - - non-para line (@List.take) with ref @List.take - Another non-para line - @List.take starting non-para line - - - non-para line with ref @List.take -before a para-line lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor. - - - non-para line followed by a para line starting with ref -@List.take lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor. - -a para-line ending with ref lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor @List.take - - non-para line - -para line lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor - @List.take followed by non-para line starting with ref. - -@[signature] List.take - -@[source] foo - -@[evaluate] expr - -@[include] doc1 - --- note the leading space below - @[signature] List.take - -:] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - test1 : Doc - -``` -```ucm -.> view test1 - - test1 : Doc - test1 = - [: The internal logic starts to get hairy when you use the - \@ features, for example referencing a name like @List.take. - Internally, the text between each such usage is its own blob - (blob ends here --> @List.take), so paragraph reflow has to - be aware of multiple blobs to do paragraph reflow (or, more - accurately, to do the normalization step where newlines with - a paragraph are removed.) - - Para to reflow: lorem ipsum dolor lorem ipsum dolor lorem - ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum - dolor lorem ipsum dolor ending in ref @List.take - - @List.take starting para lorem ipsum dolor lorem ipsum dolor - lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem - ipsum dolor lorem ipsum dolor. - - Middle of para: lorem ipsum dolor lorem ipsum dolor lorem - ipsum dolor @List.take lorem ipsum dolor lorem ipsum dolor - lorem ipsum dolor lorem ipsum dolor. - - - non-para line (@List.take) with ref @List.take - Another non-para line - @List.take starting non-para line - - - non-para line with ref @List.take - before a para-line lorem ipsum dolor lorem ipsum dolor lorem - ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum - dolor lorem ipsum dolor lorem ipsum dolor. - - - non-para line followed by a para line starting with ref - @List.take lorem ipsum dolor lorem ipsum dolor lorem ipsum - dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor - lorem ipsum dolor lorem ipsum dolor. - - a para-line ending with ref lorem ipsum dolor lorem ipsum - dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor - lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor @List.take - - non-para line - - para line lorem ipsum dolor lorem ipsum dolor lorem ipsum - dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor - lorem ipsum dolor lorem ipsum dolor - @List.take followed by non-para line starting with ref. - - @[signature] List.take - - @[source] foo - - @[evaluate] expr - - @[include] doc1 - - -- note the leading space below - @[signature] List.take - - :] - -``` -```unison --- Regression test for #1363 - preservation of spaces after @ directives in first line when unindenting -reg1363 = [: `@List.take foo` bar - baz :] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - reg1363 : Doc - -``` -```ucm -.> view reg1363 - - reg1363 : Doc - reg1363 = [: `@List.take foo` bar baz :] - -``` -```unison --- Demonstrate doc display when whitespace follows a @[source] or @[evaluate] --- whose output spans multiple lines. - -test2 = [: - Take a look at this: - @[source] foo ▶ bar -:] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - test2 : Doc - -``` -View is fine. -```ucm -.> view test2 - - test2 : Doc - test2 = - [: Take a look at this: - @[source] foo ▶ bar - :] - -``` -But note it's not obvious how display should best be handling this. At the moment it just does the simplest thing: -```ucm -.> display test2 - - Take a look at this: - foo : Nat -> Nat - foo n = - use Nat + - _ = [: do the thing :] - n + 1 ▶ bar - - -``` diff --git a/unison-src/transcripts/doc-type-link-keywords.md b/unison-src/transcripts/doc-type-link-keywords.md deleted file mode 100644 index a4cb0007aa..0000000000 --- a/unison-src/transcripts/doc-type-link-keywords.md +++ /dev/null @@ -1,41 +0,0 @@ -Regression test to ensure that `type` and `ability` in embedded doc links are -lexed properly when they occur at the start of identifiers. - -That is, `{abilityPatterns}` should be a link to the **term** `abilityPatterns`, -not the ability `Patterns`; the lexer should see this as a single identifier. - -See https://github.com/unisonweb/unison/issues/2642 for an example. - -```ucm:hide -.> builtins.mergeio -``` - -```unison:hide -abilityPatterns : () -abilityPatterns = () - -structural ability Patterns where p : () - -typeLabels : Nat -typeLabels = 5 - -structural type Labels = Labels - -docs.example1 = {{A doc that links to the {abilityPatterns} term}} -docs.example2 = {{A doc that links to the {ability Patterns} ability}} -docs.example3 = {{A doc that links to the {typeLabels} term}} -docs.example4 = {{A doc that links to the {type Labels} type}} -``` - -```ucm:hide -.> add -``` - -Now we check that each doc links to the object of the correct name: - -```ucm -.> display docs.example1 -.> display docs.example2 -.> display docs.example3 -.> display docs.example4 -``` diff --git a/unison-src/transcripts/doc-type-link-keywords.output.md b/unison-src/transcripts/doc-type-link-keywords.output.md deleted file mode 100644 index 9eea235a15..0000000000 --- a/unison-src/transcripts/doc-type-link-keywords.output.md +++ /dev/null @@ -1,45 +0,0 @@ -Regression test to ensure that `type` and `ability` in embedded doc links are -lexed properly when they occur at the start of identifiers. - -That is, `{abilityPatterns}` should be a link to the **term** `abilityPatterns`, -not the ability `Patterns`; the lexer should see this as a single identifier. - -See https://github.com/unisonweb/unison/issues/2642 for an example. - -```unison -abilityPatterns : () -abilityPatterns = () - -structural ability Patterns where p : () - -typeLabels : Nat -typeLabels = 5 - -structural type Labels = Labels - -docs.example1 = {{A doc that links to the {abilityPatterns} term}} -docs.example2 = {{A doc that links to the {ability Patterns} ability}} -docs.example3 = {{A doc that links to the {typeLabels} term}} -docs.example4 = {{A doc that links to the {type Labels} type}} -``` - -Now we check that each doc links to the object of the correct name: - -```ucm -.> display docs.example1 - - A doc that links to the abilityPatterns term - -.> display docs.example2 - - A doc that links to the Patterns ability - -.> display docs.example3 - - A doc that links to the typeLabels term - -.> display docs.example4 - - A doc that links to the Labels type - -``` diff --git a/unison-src/transcripts/doc1.md b/unison-src/transcripts/doc1.md deleted file mode 100644 index 7379c47198..0000000000 --- a/unison-src/transcripts/doc1.md +++ /dev/null @@ -1,83 +0,0 @@ -# Documenting Unison code - -```ucm:hide -.> builtins.merge -``` - -Unison documentation is written in Unison. Documentation is a value of the following type: - -```ucm -.builtin> view Doc -``` - -You can create these `Doc` values with ordinary code, or you can use the special syntax. A value of structural type `Doc` can be created via syntax like: - -```unison -doc1 = [: This is some documentation. - -It can span multiple lines. - -Can link to definitions like @List.drop or @List - -:] -``` - -Syntax: - -`[:` starts a documentation block; `:]` finishes it. Within the block: - -* Links to definitions are done with `@List`. `\@` (and `\:]`) if you want to escape. -* `@[signature] List.take` expands to the type signature of `List.take` -* `@[source] List.map` expands to the full source of `List.map` -* `@[include] someOtherDoc`, inserts a value `someOtherDoc : Doc` here. -* `@[evaluate] someDefinition` expands to the result of evaluating `someDefinition`, which must be a pre-existing definition in the codebase (can't be an arbitrary expression). - -### An example - -We are going to document `List.take` using some verbiage and a few examples. First we have to add the examples to the codebase: - -```unison -List.take.ex1 = take 0 [1,2,3,4,5] -List.take.ex2 = take 2 [1,2,3,4,5] -``` - -```ucm -.builtin> add -``` - -And now let's write our docs and reference these examples: - -```unison -List.take.doc = [: -`@List.take n xs` returns the first `n` elements of `xs`. (No need to add line breaks manually. The display command will do wrapping of text for you. Indent any lines where you don't want it to do this.) - -## Examples: - - @[source] List.take.ex1 - 🔽 - @List.take.ex1 = @[evaluate] List.take.ex1 - - - @[source] List.take.ex2 - 🔽 - @List.take.ex2 = @[evaluate] List.take.ex2 -:] -``` - -Let's add it to the codebase. - -```ucm -.builtin> add -``` - -We can view it with `docs`, which shows the `Doc` value that is associated with a definition. - -```ucm -.builtin> docs List.take -``` - -Note that if we view the source of the documentation, the various references are *not* expanded. - -```ucm -.builtin> view List.take -``` diff --git a/unison-src/transcripts/doc1.output.md b/unison-src/transcripts/doc1.output.md deleted file mode 100644 index 9fc30e1602..0000000000 --- a/unison-src/transcripts/doc1.output.md +++ /dev/null @@ -1,158 +0,0 @@ -# Documenting Unison code - -Unison documentation is written in Unison. Documentation is a value of the following type: - -```ucm -.builtin> view Doc - - type Doc - = Blob Text - | Link Link - | Source Link - | Signature Term - | Evaluate Term - | Join [Doc] - -``` -You can create these `Doc` values with ordinary code, or you can use the special syntax. A value of structural type `Doc` can be created via syntax like: - -```unison -doc1 = [: This is some documentation. - -It can span multiple lines. - -Can link to definitions like @List.drop or @List - -:] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - doc1 : Doc - -``` -Syntax: - -`[:` starts a documentation block; `:]` finishes it. Within the block: - -* Links to definitions are done with `@List`. `\@` (and `\:]`) if you want to escape. -* `@[signature] List.take` expands to the type signature of `List.take` -* `@[source] List.map` expands to the full source of `List.map` -* `@[include] someOtherDoc`, inserts a value `someOtherDoc : Doc` here. -* `@[evaluate] someDefinition` expands to the result of evaluating `someDefinition`, which must be a pre-existing definition in the codebase (can't be an arbitrary expression). - -### An example - -We are going to document `List.take` using some verbiage and a few examples. First we have to add the examples to the codebase: - -```unison -List.take.ex1 = take 0 [1,2,3,4,5] -List.take.ex2 = take 2 [1,2,3,4,5] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - List.take.ex1 : [Nat] - List.take.ex2 : [Nat] - -``` -```ucm -.builtin> add - - ⍟ I've added these definitions: - - List.take.ex1 : [Nat] - List.take.ex2 : [Nat] - -``` -And now let's write our docs and reference these examples: - -```unison -List.take.doc = [: -`@List.take n xs` returns the first `n` elements of `xs`. (No need to add line breaks manually. The display command will do wrapping of text for you. Indent any lines where you don't want it to do this.) - -## Examples: - - @[source] List.take.ex1 - 🔽 - @List.take.ex1 = @[evaluate] List.take.ex1 - - - @[source] List.take.ex2 - 🔽 - @List.take.ex2 = @[evaluate] List.take.ex2 -:] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - List.take.doc : Doc - -``` -Let's add it to the codebase. - -```ucm -.builtin> add - - ⍟ I've added these definitions: - - List.take.doc : Doc - -``` -We can view it with `docs`, which shows the `Doc` value that is associated with a definition. - -```ucm -.builtin> docs List.take - - `List.take n xs` returns the first `n` elements of `xs`. (No - need to add line breaks manually. The display command will do - wrapping of text for you. Indent any lines where you don't - want it to do this.) - - ## Examples: - - List.take.ex1 : [Nat] - List.take.ex1 = List.take 0 [1, 2, 3, 4, 5] - 🔽 - ex1 = [] - - - List.take.ex2 : [Nat] - List.take.ex2 = List.take 2 [1, 2, 3, 4, 5] - 🔽 - ex2 = [1, 2] - - -``` -Note that if we view the source of the documentation, the various references are *not* expanded. - -```ucm -.builtin> view List.take - - builtin List.take : Nat -> [a] -> [a] - -``` diff --git a/unison-src/transcripts/doc2.md b/unison-src/transcripts/doc2.md deleted file mode 100644 index 278cc8f493..0000000000 --- a/unison-src/transcripts/doc2.md +++ /dev/null @@ -1,118 +0,0 @@ -# Test parsing and round-trip of doc2 syntax elements - -```ucm:hide -.> builtins.mergeio -``` - -```unison:hide -otherDoc : a -> Doc2 -otherDoc _ = {{ yo }} - -otherTerm : Nat -otherTerm = 99 - -fulldoc : Doc2 -fulldoc = - use Nat + - {{ -Heres some text with a -soft line break - -hard line break - -Here's a cool **BOLD** __italic__ ~~strikethrough~~ thing with an inline code block `1 + 2` - -Should print with appropriate fences for the contents: - -`No fancy quotes` - -'' There are `backticks` in here '' - -''' There are `backticks` and ''quotes'' in here ''' - -# Heading - -## Heading 2 - -Term Link: {otherTerm} - -Type Link: {type Optional} - -Term source: - -@source{term} - -Term signature: - -@signature{term} - -* List item - -Inline code: - -`` 1 + 2 `` - -` "doesn't typecheck" + 1 ` - -[Link](https://unison-lang.org) - -![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) - -Horizontal rule - ---- - -Video - -{{ -Special - (Embed - (Any (Video [MediaSource "test.mp4" None] [("poster", "test.png")]))) -}} - -Transclusion/evaluation: - -{{ otherDoc (a -> Word a) }} - ---- - -The following markdown features aren't supported by the Doc format yet, but maybe will someday - - -> Block quote - - -Table - -| Header 1 | Header 2 | -| -------- | -------- | -| Cell 1 | Cell 2 | - - - Indented Code block - -''' - Exact whitespace should be preserved across multiple updates. Don't mess with the logo! - - _____ _ - | | |___|_|___ ___ ___ - | | | | |_ -| . | | - |_____|_|_|_|___|___|_|_| - - Line with no whitespace: - - Should have one full trailing newline below here: - -''' - -Inline '' text literal with 1 space of padding '' in the middle of a sentence. - - -}} -``` - -Format it to check that everything pretty-prints in a valid way. - -```ucm -.> debug.format -``` diff --git a/unison-src/transcripts/doc2.output.md b/unison-src/transcripts/doc2.output.md deleted file mode 100644 index e303b639a4..0000000000 --- a/unison-src/transcripts/doc2.output.md +++ /dev/null @@ -1,217 +0,0 @@ -# Test parsing and round-trip of doc2 syntax elements - -```unison -otherDoc : a -> Doc2 -otherDoc _ = {{ yo }} - -otherTerm : Nat -otherTerm = 99 - -fulldoc : Doc2 -fulldoc = - use Nat + - {{ -Heres some text with a -soft line break - -hard line break - -Here's a cool **BOLD** __italic__ ~~strikethrough~~ thing with an inline code block `1 + 2` - -Should print with appropriate fences for the contents: - -`No fancy quotes` - -'' There are `backticks` in here '' - -''' There are `backticks` and ''quotes'' in here ''' - -# Heading - -## Heading 2 - -Term Link: {otherTerm} - -Type Link: {type Optional} - -Term source: - -@source{term} - -Term signature: - -@signature{term} - -* List item - -Inline code: - -`` 1 + 2 `` - -` "doesn't typecheck" + 1 ` - -[Link](https://unison-lang.org) - -![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) - -Horizontal rule - ---- - -Video - -{{ -Special - (Embed - (Any (Video [MediaSource "test.mp4" None] [("poster", "test.png")]))) -}} - -Transclusion/evaluation: - -{{ otherDoc (a -> Word a) }} - ---- - -The following markdown features aren't supported by the Doc format yet, but maybe will someday - - -> Block quote - - -Table - -| Header 1 | Header 2 | -| -------- | -------- | -| Cell 1 | Cell 2 | - - - Indented Code block - -''' - Exact whitespace should be preserved across multiple updates. Don't mess with the logo! - - _____ _ - | | |___|_|___ ___ ___ - | | | | |_ -| . | | - |_____|_|_|_|___|___|_|_| - - Line with no whitespace: - - Should have one full trailing newline below here: - -''' - -Inline '' text literal with 1 space of padding '' in the middle of a sentence. - - -}} -``` - -Format it to check that everything pretty-prints in a valid way. - -```ucm -.> debug.format - -``` -```unison:added-by-ucm scratch.u -otherDoc : a -> Doc2 -otherDoc _ = {{ yo }} - -otherTerm : Nat -otherTerm = 99 - -fulldoc : Doc2 -fulldoc = - use Nat + - {{ - Heres some text with a soft line break - - hard line break - - Here's a cool **BOLD** __italic__ ~~strikethrough~~ thing with an inline code - block `1 + 2` - - Should print with appropriate fences for the contents: - - `No fancy quotes` - - '' There are `backticks` in here '' - - ''' There are `backticks` and ''quotes'' in here ''' - - # Heading - - ## Heading 2 - - Term Link: {otherTerm} - - Type Link: {type Optional} - - Term source: - - @source{term} - - Term signature: - - @signature{term} - - * List item - - Inline code: - - `` 1 + 2 `` - - ` "doesn't typecheck" + 1 ` - - [Link](https://unison-lang.org) - - ![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) - - Horizontal rule - - --- - - Video - - {{ - Special - (Embed - (Any (Video [MediaSource "test.mp4" None] [("poster", "test.png")]))) - }} - - Transclusion/evaluation: - - {{ otherDoc (a -> Word a) }} - - --- - - The following markdown features aren't supported by the Doc format yet, - but maybe will someday - - > Block quote - - Table - - | Header 1 | Header 2 | | -------- | -------- | | Cell 1 | Cell 2 | - - Indented Code block - - ''' - Exact whitespace should be preserved across multiple updates. Don't mess with the logo! - - _____ _ - | | |___|_|___ ___ ___ - | | | | |_ -| . | | - |_____|_|_|_|___|___|_|_| - - Line with no whitespace: - - Should have one full trailing newline below here: - - ''' - - Inline ` text literal with 1 space of padding ` in the middle of a - sentence. - }} -``` - diff --git a/unison-src/transcripts/doc2markdown.md b/unison-src/transcripts/doc2markdown.md deleted file mode 100644 index a7ac7a808b..0000000000 --- a/unison-src/transcripts/doc2markdown.md +++ /dev/null @@ -1,111 +0,0 @@ -```ucm:hide -.> builtins.mergeio -``` - -```unison:hide -otherDoc : a -> Doc2 -otherDoc _ = {{ yo }} - -otherTerm : Nat -otherTerm = 99 - -fulldoc : Doc2 -fulldoc = - use Nat + - {{ -Heres some text with a -soft line break - -hard line break - -Here's a cool **BOLD** __italic__ ~~strikethrough~~ thing with an inline code block ''1 + 2'' - -# Heading - -## Heading 2 - -Term Link: {otherTerm} - -Type Link: {type Optional} - -Term source: - -@source{term} - -Term signature: - -@signature{term} - -* List item - -Inline code: - -`` 1 + 2 `` - -` "doesn't typecheck" + 1 ` - -[Link](https://unison-lang.org) - -![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) - -Horizontal rule - ---- - -Video - -{{ -Special - (Embed - (Any (Video [MediaSource "test.mp4" None] [("poster", "test.png")]))) -}} - -Transclusion/evaluation: - -{{ otherDoc (a -> Word a) }} - ---- - -The following markdown features aren't supported by the Doc format yet, but maybe will someday - - -> Block quote - - -Table - -| Header 1 | Header 2 | -| -------- | -------- | -| Cell 1 | Cell 2 | - - - Indented Code block - - -}} -``` - -```ucm:hide -.> add -``` - -```ucm -.> debug.doc-to-markdown fulldoc -``` - -You can add docs to a term or type with a top-level doc literal above the binding: - -```unison -{{ This is a term doc }} -myTerm = 10 - --- Regression tests for https://github.com/unisonweb/unison/issues/4634 -{{ This is a type doc }} -type MyType = MyType - -{{ This is a unique type doc }} -unique type MyUniqueType = MyUniqueType - -{{ This is a structural type doc }} -structural type MyStructuralType = MyStructuralType -``` diff --git a/unison-src/transcripts/doc2markdown.output.md b/unison-src/transcripts/doc2markdown.output.md deleted file mode 100644 index c9b98f984f..0000000000 --- a/unison-src/transcripts/doc2markdown.output.md +++ /dev/null @@ -1,197 +0,0 @@ -```unison -otherDoc : a -> Doc2 -otherDoc _ = {{ yo }} - -otherTerm : Nat -otherTerm = 99 - -fulldoc : Doc2 -fulldoc = - use Nat + - {{ -Heres some text with a -soft line break - -hard line break - -Here's a cool **BOLD** __italic__ ~~strikethrough~~ thing with an inline code block ''1 + 2'' - -# Heading - -## Heading 2 - -Term Link: {otherTerm} - -Type Link: {type Optional} - -Term source: - -@source{term} - -Term signature: - -@signature{term} - -* List item - -Inline code: - -`` 1 + 2 `` - -` "doesn't typecheck" + 1 ` - -[Link](https://unison-lang.org) - -![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) - -Horizontal rule - ---- - -Video - -{{ -Special - (Embed - (Any (Video [MediaSource "test.mp4" None] [("poster", "test.png")]))) -}} - -Transclusion/evaluation: - -{{ otherDoc (a -> Word a) }} - ---- - -The following markdown features aren't supported by the Doc format yet, but maybe will someday - - -> Block quote - - -Table - -| Header 1 | Header 2 | -| -------- | -------- | -| Cell 1 | Cell 2 | - - - Indented Code block - - -}} -``` - -```ucm -.> debug.doc-to-markdown fulldoc - - Heres some text with a soft line break - - hard line break - - Here's a cool **BOLD** _italic_ ~~strikethrough~~ thing with an inline code block `1 + 2` - - # Heading - - ## Heading 2 - - Term Link: `otherTerm` - - Type Link: `Optional` - - Term source: - - ```unison - term : '{g} a -> Doc2.Term - term a = Term.Term (Any a) - ``` - - - - Term signature: - - ```unison - term : '{g} a -> Doc2.Term - ``` - - - - - List item - - Inline code: - - `1 Nat.+ 2` - - ` "doesn't typecheck" + 1 ` - - [Link](https://unison-lang.org) - - ![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) - - Horizontal rule - - --- - - Video - - ![](test.mp4) - - Transclusion/evaluation: - - yo - - - - --- - - The following markdown features aren't supported by the Doc format yet, but maybe will someday - - > Block quote - - Table - - | Header 1 | Header 2 | | -------- | -------- | | Cell 1 | Cell 2 | - - Indented Code block - - - - -``` -You can add docs to a term or type with a top-level doc literal above the binding: - -```unison -{{ This is a term doc }} -myTerm = 10 - --- Regression tests for https://github.com/unisonweb/unison/issues/4634 -{{ This is a type doc }} -type MyType = MyType - -{{ This is a unique type doc }} -unique type MyUniqueType = MyUniqueType - -{{ This is a structural type doc }} -structural type MyStructuralType = MyStructuralType -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type MyStructuralType - (also named builtin.Unit) - type MyType - type MyUniqueType - MyStructuralType.doc : Doc2 - MyType.doc : Doc2 - MyUniqueType.doc : Doc2 - myTerm : Nat - myTerm.doc : Doc2 - -``` diff --git a/unison-src/transcripts/dont-upgrade-refs-that-exist-in-old.md b/unison-src/transcripts/dont-upgrade-refs-that-exist-in-old.md deleted file mode 100644 index d74ca38e19..0000000000 --- a/unison-src/transcripts/dont-upgrade-refs-that-exist-in-old.md +++ /dev/null @@ -1,19 +0,0 @@ -If `foo#old` exists in old, and `foo#new` exists in new, you might think `upgrade old new` would rewrite references to -`#old` with references to `#new`. And it will... !!unless!! `#old` still exists in new. - -```ucm:hide -foo/main> builtins.merge lib.builtin -``` - -```unison -lib.old.foo = 18 -lib.new.other = 18 -lib.new.foo = 19 -mything = lib.old.foo + lib.old.foo -``` - -```ucm -foo/main> add -foo/main> upgrade old new -foo/main> view mything -``` diff --git a/unison-src/transcripts/dont-upgrade-refs-that-exist-in-old.output.md b/unison-src/transcripts/dont-upgrade-refs-that-exist-in-old.output.md deleted file mode 100644 index a256f4e45e..0000000000 --- a/unison-src/transcripts/dont-upgrade-refs-that-exist-in-old.output.md +++ /dev/null @@ -1,48 +0,0 @@ -If `foo#old` exists in old, and `foo#new` exists in new, you might think `upgrade old new` would rewrite references to -`#old` with references to `#new`. And it will... !!unless!! `#old` still exists in new. - -```unison -lib.old.foo = 18 -lib.new.other = 18 -lib.new.foo = 19 -mything = lib.old.foo + lib.old.foo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - lib.new.foo : Nat - lib.new.other : Nat - lib.old.foo : Nat - mything : Nat - -``` -```ucm -foo/main> add - - ⍟ I've added these definitions: - - lib.new.foo : Nat - lib.new.other : Nat - lib.old.foo : Nat - mything : Nat - -foo/main> upgrade old new - - I upgraded old to new, and removed old. - -foo/main> view mything - - mything : Nat - mything = - use Nat + - other + other - -``` diff --git a/unison-src/transcripts/duplicate-names.md b/unison-src/transcripts/duplicate-names.md deleted file mode 100644 index 2935a401b9..0000000000 --- a/unison-src/transcripts/duplicate-names.md +++ /dev/null @@ -1,54 +0,0 @@ -# Duplicate names in scratch file. - -```ucm:hide -.> builtins.merge -``` - -Term and ability constructor collisions should cause a parse error. - -```unison:error -structural ability Stream where - send : a -> () - -Stream.send : a -> () -Stream.send _ = () -``` - -Term and type constructor collisions should cause a parse error. - -```unison:error -structural type X = x - -X.x : a -> () -X.x _ = () -``` - -Ability and type constructor collisions should cause a parse error. - -```unison:error -structural type X = x -structural ability X where - x : () -``` - -Field accessors and terms with the same name should cause a parse error. - -```unison:error -structural type X = {x : ()} -X.x.modify = () -X.x.set = () -X.x = () -``` - -Types and terms with the same name are allowed. - -```unison -structural type X = Z - -X = () -``` - -```ucm -.> add -.> view X -``` diff --git a/unison-src/transcripts/duplicate-names.output.md b/unison-src/transcripts/duplicate-names.output.md deleted file mode 100644 index 7e82b2e04b..0000000000 --- a/unison-src/transcripts/duplicate-names.output.md +++ /dev/null @@ -1,143 +0,0 @@ -# Duplicate names in scratch file. - -Term and ability constructor collisions should cause a parse error. - -```unison -structural ability Stream where - send : a -> () - -Stream.send : a -> () -Stream.send _ = () -``` - -```ucm - - Loading changes detected in scratch.u. - - ❗️ - - I found multiple bindings with the name Stream.send: - 2 | send : a -> () - 3 | - 4 | Stream.send : a -> () - 5 | Stream.send _ = () - - -``` -Term and type constructor collisions should cause a parse error. - -```unison -structural type X = x - -X.x : a -> () -X.x _ = () -``` - -```ucm - - Loading changes detected in scratch.u. - - ❗️ - - I found multiple bindings with the name X.x: - 1 | structural type X = x - 2 | - 3 | X.x : a -> () - 4 | X.x _ = () - - -``` -Ability and type constructor collisions should cause a parse error. - -```unison -structural type X = x -structural ability X where - x : () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found two types called X: - - 1 | structural type X = x - 2 | structural ability X where - 3 | x : () - - -``` -Field accessors and terms with the same name should cause a parse error. - -```unison -structural type X = {x : ()} -X.x.modify = () -X.x.set = () -X.x = () -``` - -```ucm - - Loading changes detected in scratch.u. - - ❗️ - - I found multiple bindings with the name X.x: - 1 | structural type X = {x : ()} - 2 | X.x.modify = () - 3 | X.x.set = () - 4 | X.x = () - - - I found multiple bindings with the name X.x.modify: - 1 | structural type X = {x : ()} - 2 | X.x.modify = () - - - I found multiple bindings with the name X.x.set: - 1 | structural type X = {x : ()} - 2 | X.x.modify = () - 3 | X.x.set = () - - -``` -Types and terms with the same name are allowed. - -```unison -structural type X = Z - -X = () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type X - (also named builtin.Unit) - X : () - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - structural type X - (also named builtin.Unit) - X : () - -.> view X - - structural type X = Z - - X : () - X = () - -``` diff --git a/unison-src/transcripts/duplicate-term-detection.md b/unison-src/transcripts/duplicate-term-detection.md deleted file mode 100644 index 61b2a8ebf1..0000000000 --- a/unison-src/transcripts/duplicate-term-detection.md +++ /dev/null @@ -1,42 +0,0 @@ -# Duplicate Term Detection - -```ucm:hide -.> builtins.merge -``` - - -Trivial duplicate terms should be detected: - -```unison:error -x = 1 -x = 2 -``` - -Equivalent duplicate terms should be detected: - -```unison:error -x = 1 -x = 1 -``` - -Duplicates from record accessors/setters should be detected - -```unison:error -structural type Record = {x: Nat, y: Nat} -Record.x = 1 -Record.x.set = 2 -Record.x.modify = 2 -``` - -Duplicate terms and constructors should be detected: - -```unison:error -structural type SumType = X - -SumType.X = 1 - -structural ability AnAbility where - thing : Nat -> () - -AnAbility.thing = 2 -``` diff --git a/unison-src/transcripts/duplicate-term-detection.output.md b/unison-src/transcripts/duplicate-term-detection.output.md deleted file mode 100644 index 35f4de11fc..0000000000 --- a/unison-src/transcripts/duplicate-term-detection.output.md +++ /dev/null @@ -1,106 +0,0 @@ -# Duplicate Term Detection - -Trivial duplicate terms should be detected: - -```unison -x = 1 -x = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - ❗️ - - I found multiple bindings with the name x: - 1 | x = 1 - 2 | x = 2 - - -``` -Equivalent duplicate terms should be detected: - -```unison -x = 1 -x = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - ❗️ - - I found multiple bindings with the name x: - 1 | x = 1 - 2 | x = 1 - - -``` -Duplicates from record accessors/setters should be detected - -```unison -structural type Record = {x: Nat, y: Nat} -Record.x = 1 -Record.x.set = 2 -Record.x.modify = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - ❗️ - - I found multiple bindings with the name Record.x: - 1 | structural type Record = {x: Nat, y: Nat} - 2 | Record.x = 1 - - - I found multiple bindings with the name Record.x.modify: - 1 | structural type Record = {x: Nat, y: Nat} - 2 | Record.x = 1 - 3 | Record.x.set = 2 - 4 | Record.x.modify = 2 - - - I found multiple bindings with the name Record.x.set: - 1 | structural type Record = {x: Nat, y: Nat} - 2 | Record.x = 1 - 3 | Record.x.set = 2 - - -``` -Duplicate terms and constructors should be detected: - -```unison -structural type SumType = X - -SumType.X = 1 - -structural ability AnAbility where - thing : Nat -> () - -AnAbility.thing = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - ❗️ - - I found multiple bindings with the name AnAbility.thing: - 6 | thing : Nat -> () - 7 | - 8 | AnAbility.thing = 2 - - - I found multiple bindings with the name SumType.X: - 1 | structural type SumType = X - 2 | - 3 | SumType.X = 1 - - -``` diff --git a/unison-src/transcripts/ed25519.md b/unison-src/transcripts/ed25519.md deleted file mode 100644 index 679a8900a0..0000000000 --- a/unison-src/transcripts/ed25519.md +++ /dev/null @@ -1,27 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -```unison - -up = 0xs0123456789abcdef -down = 0xsfedcba9876543210 - -secret = 0xs3885da624f4430c01326d96764da85647d403dae1fcdc9856c51037f9c647032 - -public = 0xsb14dbcf139c0e73d942a184b419e4f4fab726102bfe2b65c060b113bb379c77c - - -message = up ++ down ++ up ++ down ++ down ++ up ++ down ++ up - -signature = crypto.Ed25519.sign.impl secret public message - -sigOkay = match signature with - Left err -> Left err - Right sg -> crypto.Ed25519.verify.impl public message sg - -> signature -> sigOkay -``` - diff --git a/unison-src/transcripts/ed25519.output.md b/unison-src/transcripts/ed25519.output.md deleted file mode 100644 index e204f75302..0000000000 --- a/unison-src/transcripts/ed25519.output.md +++ /dev/null @@ -1,53 +0,0 @@ - -```unison -up = 0xs0123456789abcdef -down = 0xsfedcba9876543210 - -secret = 0xs3885da624f4430c01326d96764da85647d403dae1fcdc9856c51037f9c647032 - -public = 0xsb14dbcf139c0e73d942a184b419e4f4fab726102bfe2b65c060b113bb379c77c - - -message = up ++ down ++ up ++ down ++ down ++ up ++ down ++ up - -signature = crypto.Ed25519.sign.impl secret public message - -sigOkay = match signature with - Left err -> Left err - Right sg -> crypto.Ed25519.verify.impl public message sg - -> signature -> sigOkay -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - down : Bytes - message : Bytes - public : Bytes - secret : Bytes - sigOkay : Either Failure Boolean - signature : Either Failure Bytes - up : Bytes - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 17 | > signature - ⧩ - Right - 0xs0b76988ce7e5147d36597d2a526ec7b8e178b3ae29083598c33c9fbcdf0f84b4ff2f8c5409123dd9a0c54447861c07e21296500a98540f5d5f15d927eaa6d30a - - 18 | > sigOkay - ⧩ - Right true - -``` diff --git a/unison-src/transcripts/edit-command.md b/unison-src/transcripts/edit-command.md deleted file mode 100644 index 4c4edc9e4c..0000000000 --- a/unison-src/transcripts/edit-command.md +++ /dev/null @@ -1,21 +0,0 @@ -```ucm -.> builtins.merge -``` - -```unison /private/tmp/scratch.u -foo = 123 - -bar = 456 - -mytest = [Ok "ok"] -``` - -```ucm -.> add -.> edit foo bar -.> edit mytest -``` - -```ucm:error -.> edit missing -``` diff --git a/unison-src/transcripts/edit-command.output.md b/unison-src/transcripts/edit-command.output.md deleted file mode 100644 index a4c428e281..0000000000 --- a/unison-src/transcripts/edit-command.output.md +++ /dev/null @@ -1,83 +0,0 @@ -```ucm -.> builtins.merge - - Done. - -``` -```unison ---- -title: /private/tmp/scratch.u ---- -foo = 123 - -bar = 456 - -mytest = [Ok "ok"] - -``` - - -```ucm - - Loading changes detected in /private/tmp/scratch.u. - - I found and typechecked these definitions in - /private/tmp/scratch.u. If you do an `add` or `update`, here's - how your codebase would change: - - ⍟ These new definitions are ok to `add`: - - bar : Nat - foo : Nat - mytest : [Result] - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - bar : Nat - foo : Nat - mytest : [Result] - -.> edit foo bar - - ☝️ - - I added 2 definitions to the top of /private/tmp/scratch.u - - You can edit them there, then run `update` to replace the - definitions currently in this namespace. - -.> edit mytest - - ☝️ - - I added 1 definitions to the top of /private/tmp/scratch.u - - You can edit them there, then run `update` to replace the - definitions currently in this namespace. - -``` -```unison:added-by-ucm /private/tmp/scratch.u -bar : Nat -bar = 456 - -foo : Nat -foo = 123 -``` - -```unison:added-by-ucm /private/tmp/scratch.u -test> mytest = [Ok "ok"] -``` - -```ucm -.> edit missing - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - missing - -``` diff --git a/unison-src/transcripts/edit-namespace.md b/unison-src/transcripts/edit-namespace.md deleted file mode 100644 index ad50bc1b0d..0000000000 --- a/unison-src/transcripts/edit-namespace.md +++ /dev/null @@ -1,38 +0,0 @@ -```ucm:hide -project/main> builtins.mergeio lib.builtin -``` - -```unison -{{ ping doc }} -nested.cycle.ping n = n Nat.+ pong n - -{{ pong doc }} -nested.cycle.pong n = n Nat.+ ping n - -toplevel = "hi" - -simple.x = 10 -simple.y = 20 - --- Shouldn't edit things in lib -lib.project.ignoreMe = 30 - --- Shouldn't render record accessors -unique type Foo = { bar : Nat, baz : Nat } -``` - -```ucm -project/main> add -``` - -`edit.namespace` edits the whole namespace (minus the top-level `lib`). - -```ucm -project/main> edit.namespace -``` - -`edit.namespace` can also accept explicit paths - -```ucm -project/main> edit.namespace nested simple -``` diff --git a/unison-src/transcripts/edit-namespace.output.md b/unison-src/transcripts/edit-namespace.output.md deleted file mode 100644 index ab3bbbb54a..0000000000 --- a/unison-src/transcripts/edit-namespace.output.md +++ /dev/null @@ -1,147 +0,0 @@ -```unison -{{ ping doc }} -nested.cycle.ping n = n Nat.+ pong n - -{{ pong doc }} -nested.cycle.pong n = n Nat.+ ping n - -toplevel = "hi" - -simple.x = 10 -simple.y = 20 - --- Shouldn't edit things in lib -lib.project.ignoreMe = 30 - --- Shouldn't render record accessors -unique type Foo = { bar : Nat, baz : Nat } -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - Foo.bar : Foo -> Nat - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.bar.set : Nat -> Foo -> Foo - Foo.baz : Foo -> Nat - Foo.baz.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.baz.set : Nat -> Foo -> Foo - lib.project.ignoreMe : Nat - nested.cycle.ping : Nat -> Nat - nested.cycle.ping.doc : Doc2 - nested.cycle.pong : Nat -> Nat - nested.cycle.pong.doc : Doc2 - simple.x : Nat - simple.y : Nat - toplevel : Text - -``` -```ucm -project/main> add - - ⍟ I've added these definitions: - - type Foo - Foo.bar : Foo -> Nat - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.bar.set : Nat -> Foo -> Foo - Foo.baz : Foo -> Nat - Foo.baz.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.baz.set : Nat -> Foo -> Foo - lib.project.ignoreMe : Nat - nested.cycle.ping : Nat -> Nat - nested.cycle.ping.doc : Doc2 - nested.cycle.pong : Nat -> Nat - nested.cycle.pong.doc : Doc2 - simple.x : Nat - simple.y : Nat - toplevel : Text - -``` -`edit.namespace` edits the whole namespace (minus the top-level `lib`). - -```ucm -project/main> edit.namespace - - ☝️ - - I added 8 definitions to the top of scratch.u - - You can edit them there, then run `update` to replace the - definitions currently in this namespace. - -``` -```unison:added-by-ucm scratch.u -type Foo = { bar : Nat, baz : Nat } - -nested.cycle.ping : Nat -> Nat -nested.cycle.ping n = - use Nat + - n + nested.cycle.pong n - -nested.cycle.ping.doc : Doc2 -nested.cycle.ping.doc = {{ ping doc }} - -nested.cycle.pong : Nat -> Nat -nested.cycle.pong n = - use Nat + - n + nested.cycle.ping n - -nested.cycle.pong.doc : Doc2 -nested.cycle.pong.doc = {{ pong doc }} - -simple.x : Nat -simple.x = 10 - -simple.y : Nat -simple.y = 20 - -toplevel : Text -toplevel = "hi" -``` - -`edit.namespace` can also accept explicit paths - -```ucm -project/main> edit.namespace nested simple - - ☝️ - - I added 6 definitions to the top of scratch.u - - You can edit them there, then run `update` to replace the - definitions currently in this namespace. - -``` -```unison:added-by-ucm scratch.u -nested.cycle.ping : Nat -> Nat -nested.cycle.ping n = - use Nat + - n + nested.cycle.pong n - -nested.cycle.ping.doc : Doc2 -nested.cycle.ping.doc = {{ ping doc }} - -nested.cycle.pong : Nat -> Nat -nested.cycle.pong n = - use Nat + - n + nested.cycle.ping n - -nested.cycle.pong.doc : Doc2 -nested.cycle.pong.doc = {{ pong doc }} - -simple.x : Nat -simple.x = 10 - -simple.y : Nat -simple.y = 20 -``` - diff --git a/unison-src/transcripts/empty-namespaces.md b/unison-src/transcripts/empty-namespaces.md deleted file mode 100644 index 223ab34ba9..0000000000 --- a/unison-src/transcripts/empty-namespaces.md +++ /dev/null @@ -1,85 +0,0 @@ -# Empty namespace behaviours - -```unison:hide -mynamespace.x = 1 -``` - -```ucm:hide -.> add -.> delete.namespace mynamespace -``` - -The deleted namespace shouldn't appear in `ls` output. -```ucm:error -.> ls -``` -```ucm:error -.> find.verbose -``` -```ucm:error -.> find mynamespace -``` - -## history - -The history of the namespace should be empty. - -```ucm -.> history mynamespace -``` - -Merging an empty namespace should be a no-op - -```ucm:error -.empty> history -.empty> merge.old .mynamespace -.empty> history -``` - -Add and then delete a term to add some history to a deleted namespace. - -```unison:hide -deleted.x = 1 -stuff.thing = 2 -``` - -```ucm:hide -.> add -.> delete.namespace deleted -``` - -## fork - -I should be allowed to fork over a deleted namespace - -```ucm -.> fork stuff deleted -``` - -The history from the `deleted` namespace should have been overwritten by the history from `stuff`. - -```ucm -.> history stuff -.> history deleted -``` - -## move.namespace - -```unison:hide -moveoverme.x = 1 -moveme.y = 2 -``` - -```ucm:hide -.> add -``` - -I should be able to move a namespace over-top of a deleted namespace. -The history should be that of the moved namespace. - -```ucm -.> delete.namespace moveoverme -.> history moveme -.> move.namespace moveme moveoverme -.> history moveoverme -``` diff --git a/unison-src/transcripts/empty-namespaces.output.md b/unison-src/transcripts/empty-namespaces.output.md deleted file mode 100644 index 16d33046e1..0000000000 --- a/unison-src/transcripts/empty-namespaces.output.md +++ /dev/null @@ -1,154 +0,0 @@ -# Empty namespace behaviours - -```unison -mynamespace.x = 1 -``` - -The deleted namespace shouldn't appear in `ls` output. -```ucm -.> ls - - nothing to show - -``` -```ucm -.> find.verbose - - ☝️ - - I couldn't find matches in this namespace, searching in - 'lib'... - - 😶 - - No results. Check your spelling, or try using tab completion - to supply command arguments. - - `find.global` can be used to search outside the current - namespace. - -``` -```ucm -.> find mynamespace - - ☝️ - - I couldn't find matches in this namespace, searching in - 'lib'... - - 😶 - - No results. Check your spelling, or try using tab completion - to supply command arguments. - - `find.global` can be used to search outside the current - namespace. - -``` -## history - -The history of the namespace should be empty. - -```ucm -.> history mynamespace - - ☝️ The namespace .mynamespace is empty. - -``` -Merging an empty namespace should be a no-op - -```ucm - ☝️ The namespace .empty is empty. - -.empty> history - - ☝️ The namespace .empty is empty. - -.empty> merge.old .mynamespace - - ⚠️ - - The namespace .mynamespace doesn't exist. - -.empty> history - - ☝️ The namespace .empty is empty. - -``` -Add and then delete a term to add some history to a deleted namespace. - -```unison -deleted.x = 1 -stuff.thing = 2 -``` - -## fork - -I should be allowed to fork over a deleted namespace - -```ucm -.> fork stuff deleted - - Done. - -``` -The history from the `deleted` namespace should have been overwritten by the history from `stuff`. - -```ucm -.> history stuff - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #q2dq4tsno1 (start of history) - -.> history deleted - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #q2dq4tsno1 (start of history) - -``` -## move.namespace - -```unison -moveoverme.x = 1 -moveme.y = 2 -``` - -I should be able to move a namespace over-top of a deleted namespace. -The history should be that of the moved namespace. - -```ucm -.> delete.namespace moveoverme - - Done. - -.> history moveme - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #c5uisu4kll (start of history) - -.> move.namespace moveme moveoverme - - Done. - -.> history moveoverme - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #c5uisu4kll (start of history) - -``` diff --git a/unison-src/transcripts/emptyCodebase.md b/unison-src/transcripts/emptyCodebase.md deleted file mode 100644 index a9ea55b850..0000000000 --- a/unison-src/transcripts/emptyCodebase.md +++ /dev/null @@ -1,27 +0,0 @@ -# The empty codebase - -The Unison codebase, when first initialized, contains no definitions in its namespace. - -Not even `Nat` or `+`! - -BEHOLD!!! - -```ucm:error -.> ls -``` - -Technically, the definitions all exist, but they have no names. `builtins.merge` brings them into existence, under the current namespace: - -```ucm -.foo> builtins.merge -.foo> ls -``` - -And for a limited time, you can get even more builtin goodies: - -```ucm -.foo> builtins.mergeio -.foo> ls -``` - -More typically, you'd start out by pulling `base`. diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md deleted file mode 100644 index 672ac4857a..0000000000 --- a/unison-src/transcripts/emptyCodebase.output.md +++ /dev/null @@ -1,41 +0,0 @@ -# The empty codebase - -The Unison codebase, when first initialized, contains no definitions in its namespace. - -Not even `Nat` or `+`! - -BEHOLD!!! - -```ucm -.> ls - - nothing to show - -``` -Technically, the definitions all exist, but they have no names. `builtins.merge` brings them into existence, under the current namespace: - -```ucm - ☝️ The namespace .foo is empty. - -.foo> builtins.merge - - Done. - -.foo> ls - - 1. builtin/ (469 terms, 74 types) - -``` -And for a limited time, you can get even more builtin goodies: - -```ucm -.foo> builtins.mergeio - - Done. - -.foo> ls - - 1. builtin/ (643 terms, 92 types) - -``` -More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/error-messages.md b/unison-src/transcripts/error-messages.md deleted file mode 100644 index de58eb43b9..0000000000 --- a/unison-src/transcripts/error-messages.md +++ /dev/null @@ -1,121 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -This file contains programs with parse errors and type errors, for visual inspection of error message quality and to check for regressions or changes to error reporting. - -## Parse errors - -Some basic errors of literals. - -### Floating point literals - -```unison:error -x = 1. -- missing some digits after the decimal -``` - -```unison:error -x = 1e -- missing an exponent -``` - -```unison:error -x = 1e- -- missing an exponent -``` - -```unison:error -x = 1E+ -- missing an exponent -``` - -### Hex, octal, and bytes literals - -```unison:error -x = 0xoogabooga -- invalid hex chars -``` - -```unison:error -x = 0o987654321 -- 9 and 8 are not valid octal char -``` - -```unison:error -x = 0xsf -- odd number of hex chars in a bytes literal -``` - -```unison:error -x = 0xsnotvalidhexchars -- invalid hex chars in a bytes literal -``` - -### Layout errors - -```unison:error -foo = else -- not matching if -``` - -```unison:error -foo = then -- unclosed -``` - -```unison:error -foo = with -- unclosed -``` - -### Matching - -```unison:error --- No cases -foo = match 1 with -``` - -```unison:error -foo = match 1 with - 2 -- no right-hand-side -``` - -```unison:error --- Mismatched arities -foo = cases - 1, 2 -> () - 3 -> () -``` - -```unison:error --- Missing a '->' -x = match Some a with - None -> - 1 - Some _ - 2 -``` - -```unison:error --- Missing patterns -x = match Some a with - None -> 1 - -> 2 - -> 3 -``` - -```unison:error --- Guards following an unguarded case -x = match Some a with - None -> 1 - | true -> 2 -``` - -### Watches - -```unison:error --- Empty watch -> -``` - -### Keywords - -```unison:error -use.keyword.in.namespace = 1 -``` - -```unison:error --- reserved operator -a ! b = 1 -``` diff --git a/unison-src/transcripts/error-messages.output.md b/unison-src/transcripts/error-messages.output.md deleted file mode 100644 index 525df31ee9..0000000000 --- a/unison-src/transcripts/error-messages.output.md +++ /dev/null @@ -1,375 +0,0 @@ - -This file contains programs with parse errors and type errors, for visual inspection of error message quality and to check for regressions or changes to error reporting. - -## Parse errors - -Some basic errors of literals. - -### Floating point literals - -```unison -x = 1. -- missing some digits after the decimal -``` - -```ucm - - Loading changes detected in scratch.u. - - This number isn't valid syntax: - - 1 | x = 1. -- missing some digits after the decimal - - I was expecting some digits after the '.', for example: 1.0 or - 1.1e37. - -``` -```unison -x = 1e -- missing an exponent -``` - -```ucm - - Loading changes detected in scratch.u. - - This number isn't valid syntax: - - 1 | x = 1e -- missing an exponent - - I was expecting some digits for the exponent, for example: - 1e37. - -``` -```unison -x = 1e- -- missing an exponent -``` - -```ucm - - Loading changes detected in scratch.u. - - This number isn't valid syntax: - - 1 | x = 1e- -- missing an exponent - - I was expecting some digits for the exponent, for example: - 1e-37. - -``` -```unison -x = 1E+ -- missing an exponent -``` - -```ucm - - Loading changes detected in scratch.u. - - This number isn't valid syntax: - - 1 | x = 1E+ -- missing an exponent - - I was expecting some digits for the exponent, for example: - 1e+37. - -``` -### Hex, octal, and bytes literals - -```unison -x = 0xoogabooga -- invalid hex chars -``` - -```ucm - - Loading changes detected in scratch.u. - - This number isn't valid syntax: - - 1 | x = 0xoogabooga -- invalid hex chars - - I was expecting only hexidecimal characters (one of - 0123456789abcdefABCDEF) after the 0x. - -``` -```unison -x = 0o987654321 -- 9 and 8 are not valid octal char -``` - -```ucm - - Loading changes detected in scratch.u. - - This number isn't valid syntax: - - 1 | x = 0o987654321 -- 9 and 8 are not valid octal char - - I was expecting only octal characters (one of 01234567) after - the 0o. - -``` -```unison -x = 0xsf -- odd number of hex chars in a bytes literal -``` - -```ucm - - Loading changes detected in scratch.u. - - This bytes literal isn't valid syntax: 0xsf - - 1 | x = 0xsf -- odd number of hex chars in a bytes literal - - I was expecting an even number of hexidecimal characters (one - of 0123456789abcdefABCDEF) after the 0xs. - -``` -```unison -x = 0xsnotvalidhexchars -- invalid hex chars in a bytes literal -``` - -```ucm - - Loading changes detected in scratch.u. - - This bytes literal isn't valid syntax: 0xsnotvalidhexchars - - 1 | x = 0xsnotvalidhexchars -- invalid hex chars in a bytes literal - - I was expecting an even number of hexidecimal characters (one - of 0123456789abcdefABCDEF) after the 0xs. - -``` -### Layout errors - -```unison -foo = else -- not matching if -``` - -```ucm - - Loading changes detected in scratch.u. - - I found a closing 'else' here without a matching 'then'. - - 1 | foo = else -- not matching if - - -``` -```unison -foo = then -- unclosed -``` - -```ucm - - Loading changes detected in scratch.u. - - I found a closing 'then' here without a matching 'if'. - - 1 | foo = then -- unclosed - - -``` -```unison -foo = with -- unclosed -``` - -```ucm - - Loading changes detected in scratch.u. - - I found a closing 'with' here without a matching 'handle' or 'match'. - - 1 | foo = with -- unclosed - - -``` -### Matching - -```unison --- No cases -foo = match 1 with -``` - -```ucm - - Loading changes detected in scratch.u. - - 😶 - - I expected some patterns after a match / with or cases but I - didn't find any. - - 2 | foo = match 1 with - - -``` -```unison -foo = match 1 with - 2 -- no right-hand-side -``` - -```ucm - - Loading changes detected in scratch.u. - - I got confused here: - - 3 | - - I was surprised to find an end of section here. - I was expecting one of these instead: - - * "," - * case match - * pattern guard - -``` -```unison --- Mismatched arities -foo = cases - 1, 2 -> () - 3 -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - 😶 - - Not all the branches of this pattern matching have the same - number of arguments. I was assuming they'd all have 2 - arguments (based on the previous patterns) but this one has - 1 arguments: - 4 | 3 -> () - - -``` -```unison --- Missing a '->' -x = match Some a with - None -> - 1 - Some _ - 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I got confused here: - - 7 | - - I was surprised to find an end of section here. - I was expecting one of these instead: - - * "," - * blank - * case match - * false - * pattern guard - * true - -``` -```unison --- Missing patterns -x = match Some a with - None -> 1 - -> 2 - -> 3 -``` - -```ucm - - Loading changes detected in scratch.u. - - I got confused here: - - 4 | -> 2 - - - I was surprised to find a -> here. - I was expecting one of these instead: - - * newline or semicolon - -``` -```unison --- Guards following an unguarded case -x = match Some a with - None -> 1 - | true -> 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I got confused here: - - 4 | | true -> 2 - - - I was surprised to find a '|' here. - I was expecting one of these instead: - - * newline or semicolon - -``` -### Watches - -```unison --- Empty watch -> -``` - -```ucm - - Loading changes detected in scratch.u. - - I expected a non-empty watch expression and not just ">" - - 2 | > - - -``` -### Keywords - -```unison -use.keyword.in.namespace = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - The identifier used here isn't allowed to be a reserved keyword: - - 1 | use.keyword.in.namespace = 1 - - -``` -```unison --- reserved operator -a ! b = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - This looks like the start of an expression here - - 2 | a ! b = 1 - - but at the file top-level, I expect one of the following: - - - A binding, like a = 42 OR - a : Nat - a = 42 - - A watch expression, like > a + 1 - - An `ability` declaration, like unique ability Foo where ... - - A `type` declaration, like structural type Optional a = None | Some a - - -``` diff --git a/unison-src/transcripts/errors/code-block-parse-error.md b/unison-src/transcripts/errors/code-block-parse-error.md new file mode 100644 index 0000000000..da296b4b68 --- /dev/null +++ b/unison-src/transcripts/errors/code-block-parse-error.md @@ -0,0 +1,3 @@ +``` ucm +foo/bar% this uses the wrong delimiter before the UCM command +``` diff --git a/unison-src/transcripts/errors/code-block-parse-error.output.md b/unison-src/transcripts/errors/code-block-parse-error.output.md new file mode 100644 index 0000000000..ab6626d668 --- /dev/null +++ b/unison-src/transcripts/errors/code-block-parse-error.output.md @@ -0,0 +1,6 @@ +:2:8: + | +2 | foo/bar% this uses the wrong delimiter before the UCM command + | ^ +unexpected '%' +expecting '>' diff --git a/unison-src/transcripts/errors/dont-hide-unexpected-ucm-errors.md b/unison-src/transcripts/errors/dont-hide-unexpected-ucm-errors.md new file mode 100644 index 0000000000..e84a409d72 --- /dev/null +++ b/unison-src/transcripts/errors/dont-hide-unexpected-ucm-errors.md @@ -0,0 +1,20 @@ +Since this code block is expecting an error, we still hide it. It seems unusual to want to hide an error, but maybe it’s just too verbose or something. This follows the author’s intent. + +``` ucm :hide :error +scratch/main> help pull +scratch/main> not.a.command +``` + +For comparison, here’s what we get without `:hide`. + +``` ucm :error +scratch/main> help pull +scratch/main> not.a.command +``` + +Even though this code block has `:hide` on it, we should still see the error output, because it wasn’t expecting an error. But we should continue to hide the output _before_ the error. + +``` ucm :hide +scratch/main> help pull +scratch/main> not.a.command +``` diff --git a/unison-src/transcripts/errors/dont-hide-unexpected-ucm-errors.output.md b/unison-src/transcripts/errors/dont-hide-unexpected-ucm-errors.output.md new file mode 100644 index 0000000000..322dfe8484 --- /dev/null +++ b/unison-src/transcripts/errors/dont-hide-unexpected-ucm-errors.output.md @@ -0,0 +1,59 @@ +Since this code block is expecting an error, we still hide it. It seems unusual to want to hide an error, but maybe it’s just too verbose or something. This follows the author’s intent. + +``` ucm :hide :error +scratch/main> help pull + +scratch/main> not.a.command +``` + +For comparison, here’s what we get without `:hide`. + +``` ucm :error +scratch/main> help pull + + pull + The `pull` command merges a remote namespace into a local + branch + + `pull @unison/base/main` merges the branch + `main` of the Unison + Share hosted project + `@unison/base` into + the current branch + `pull @unison/base/main my-base/topic` merges the branch + `main` of the Unison + Share hosted project + `@unison/base` into + the branch `topic` of + the local `my-base` + project + + where `remote` is a project or project branch, such as: + Project (defaults to the /main branch) `@unison/base` + Project Branch `@unison/base/feature` + Contributor Branch `@unison/base/@johnsmith/feature` + Project Release `@unison/base/releases/1.0.0` + +scratch/main> not.a.command + + ⚠️ + I don't know how to not.a.command. Type `help` or `?` to get + help. +``` + +Even though this code block has `:hide` on it, we should still see the error output, because it wasn’t expecting an error. But we should continue to hide the output *before* the error. + +``` ucm :hide +scratch/main> help pull +scratch/main> not.a.command +``` + +🛑 + +The transcript failed due to an error in the stanza above. The error is: + +``` +⚠️ +I don't know how to not.a.command. Type `help` or `?` to get +help. +``` diff --git a/unison-src/transcripts/errors/dont-hide-unexpected-unison-errors.md b/unison-src/transcripts/errors/dont-hide-unexpected-unison-errors.md new file mode 100644 index 0000000000..a903e385be --- /dev/null +++ b/unison-src/transcripts/errors/dont-hide-unexpected-unison-errors.md @@ -0,0 +1,17 @@ +Since this code block is expecting an error, we still hide it. It seems unusual to want to hide an error, but maybe it’s just too verbose or something. This follows the author’s intent. + +``` unison :hide :error +x + x + +``` + +For comparison, here is what we get without the `:hide`. + +``` unison :error +x + x + +``` + +Even though this code block has `:hide` on it, we should still see the error output, because it wasn’t expecting an error. + +``` unison :hide +x + x + +``` diff --git a/unison-src/transcripts/errors/dont-hide-unexpected-unison-errors.output.md b/unison-src/transcripts/errors/dont-hide-unexpected-unison-errors.output.md new file mode 100644 index 0000000000..e73b5e616a --- /dev/null +++ b/unison-src/transcripts/errors/dont-hide-unexpected-unison-errors.output.md @@ -0,0 +1,55 @@ +Since this code block is expecting an error, we still hide it. It seems unusual to want to hide an error, but maybe it’s just too verbose or something. This follows the author’s intent. + +``` unison :hide :error +x + x + +``` + +For comparison, here is what we get without the `:hide`. + +``` unison :error +x + x + +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 1 | x + x + + + + I was surprised to find a x here. + I was expecting one of these instead: + + * ability + * namespace + * newline or semicolon + * type + * use +``` + +Even though this code block has `:hide` on it, we should still see the error output, because it wasn’t expecting an error. + +``` unison :hide +x + x + +``` + +🛑 + +The transcript failed due to an error in the stanza above. The error is: + +``` +I got confused here: + + 1 | x + x + + + +I was surprised to find a x here. +I was expecting one of these instead: + +* ability +* namespace +* newline or semicolon +* type +* use +``` diff --git a/unison-src/transcripts/errors/info-string-parse-error.md b/unison-src/transcripts/errors/info-string-parse-error.md new file mode 100644 index 0000000000..641a51a0ab --- /dev/null +++ b/unison-src/transcripts/errors/info-string-parse-error.md @@ -0,0 +1,3 @@ +``` ucm :hode +doesn’t matter that this isn’t a valid UCM command, because we should have failed to parse “hode” above +``` diff --git a/unison-src/transcripts/errors/info-string-parse-error.output.md b/unison-src/transcripts/errors/info-string-parse-error.output.md new file mode 100644 index 0000000000..3ef6a22af4 --- /dev/null +++ b/unison-src/transcripts/errors/info-string-parse-error.output.md @@ -0,0 +1,6 @@ +:1:9: + | +1 | ``` ucm :hode + | ^ +unexpected ':' +expecting ":added-by-ucm", ":bug", ":error", ":hide", ":hide-all", or newline diff --git a/unison-src/transcripts/errors/invalid-api-requests.md b/unison-src/transcripts/errors/invalid-api-requests.md new file mode 100644 index 0000000000..34ead03b81 --- /dev/null +++ b/unison-src/transcripts/errors/invalid-api-requests.md @@ -0,0 +1,3 @@ +``` api +DELETE /something/important +``` diff --git a/unison-src/transcripts/errors/invalid-api-requests.output.md b/unison-src/transcripts/errors/invalid-api-requests.output.md new file mode 100644 index 0000000000..1326224e62 --- /dev/null +++ b/unison-src/transcripts/errors/invalid-api-requests.output.md @@ -0,0 +1,6 @@ +:2:1: + | +2 | DELETE /something/important + | ^^^ +unexpected "DEL" +expecting " ", " ", "--", "GET", end of input, or newline diff --git a/unison-src/transcripts/errors/missing-result-typed.md b/unison-src/transcripts/errors/missing-result-typed.md index 47a3eb7920..70949bec81 100644 --- a/unison-src/transcripts/errors/missing-result-typed.md +++ b/unison-src/transcripts/errors/missing-result-typed.md @@ -1,17 +1,15 @@ - ### Transcript parser hidden errors -When an error is encountered in a `unison:hide:all` block +When an error is encountered in a `unison :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -```ucm:hide -.> builtins.merge +``` ucm :hide +scratch/main> builtins.merge ``` -```unison:hide:all +``` unison :hide-all a : Nat -a = +a = b = 24 ``` - diff --git a/unison-src/transcripts/errors/missing-result-typed.output.md b/unison-src/transcripts/errors/missing-result-typed.output.md index 260b806172..f28268036c 100644 --- a/unison-src/transcripts/errors/missing-result-typed.output.md +++ b/unison-src/transcripts/errors/missing-result-typed.output.md @@ -1,28 +1,29 @@ - ### Transcript parser hidden errors -When an error is encountered in a `unison:hide:all` block +When an error is encountered in a `unison :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -```unison +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison :hide-all a : Nat -a = +a = b = 24 ``` - - 🛑 The transcript failed due to an error in the stanza above. The error is: +``` +The last element of a block must be an expression, but this is a +definition: - The last element of a block must be an expression, but this is - a definition: - - 3 | b = 24 - - Try adding an expression at the end of the block. - It should be of type Nat. + 3 | b = 24 +Try adding an expression at the end of the block. +It should be of type Nat. +``` diff --git a/unison-src/transcripts/errors/missing-result.md b/unison-src/transcripts/errors/missing-result.md index f11fb2f546..a94c3bb3c5 100644 --- a/unison-src/transcripts/errors/missing-result.md +++ b/unison-src/transcripts/errors/missing-result.md @@ -1,12 +1,10 @@ - ### Transcript parser hidden errors -When an error is encountered in a `unison:hide:all` block +When an error is encountered in a `unison :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -```unison:hide:all -x = +``` unison :hide-all +x = y = 24 ``` - diff --git a/unison-src/transcripts/errors/missing-result.output.md b/unison-src/transcripts/errors/missing-result.output.md index c099e70080..faf91774a6 100644 --- a/unison-src/transcripts/errors/missing-result.output.md +++ b/unison-src/transcripts/errors/missing-result.output.md @@ -1,26 +1,23 @@ - ### Transcript parser hidden errors -When an error is encountered in a `unison:hide:all` block +When an error is encountered in a `unison :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -```unison -x = +``` unison :hide-all +x = y = 24 ``` - - 🛑 The transcript failed due to an error in the stanza above. The error is: +``` +The last element of a block must be an expression, but this is a +definition: - The last element of a block must be an expression, but this is - a definition: - - 2 | y = 24 - - Try adding an expression at the end of the block. + 2 | y = 24 +Try adding an expression at the end of the block. +``` diff --git a/unison-src/transcripts/errors/no-abspath-in-ucm.md b/unison-src/transcripts/errors/no-abspath-in-ucm.md new file mode 100644 index 0000000000..81b0cd09be --- /dev/null +++ b/unison-src/transcripts/errors/no-abspath-in-ucm.md @@ -0,0 +1,5 @@ +``` ucm :error +scratch/main> builtins.merge +-- As of 0.5.25, we no longer allow loose code paths for UCM commands. +.> ls +``` diff --git a/unison-src/transcripts/errors/no-abspath-in-ucm.output.md b/unison-src/transcripts/errors/no-abspath-in-ucm.output.md new file mode 100644 index 0000000000..4b38721ad7 --- /dev/null +++ b/unison-src/transcripts/errors/no-abspath-in-ucm.output.md @@ -0,0 +1,6 @@ +:4:1: + | +4 | .> ls + | ^^ +unexpected ".>" +expecting " ", " ", '@', comment (delimited with “--”), end of input, or newline diff --git a/unison-src/transcripts/errors/obsolete-bug.md b/unison-src/transcripts/errors/obsolete-bug.md new file mode 100644 index 0000000000..6f2a9641eb --- /dev/null +++ b/unison-src/transcripts/errors/obsolete-bug.md @@ -0,0 +1,5 @@ +This transcript will error, because we’re claiming that the stanza has a bug, but `help` works as expected. + +``` ucm :bug +scratch/main> help edit +``` diff --git a/unison-src/transcripts/errors/obsolete-bug.output.md b/unison-src/transcripts/errors/obsolete-bug.output.md new file mode 100644 index 0000000000..b88fe47b32 --- /dev/null +++ b/unison-src/transcripts/errors/obsolete-bug.output.md @@ -0,0 +1,15 @@ +This transcript will error, because we’re claiming that the stanza has a bug, but `help` works as expected. + +``` ucm :bug +scratch/main> help edit + + edit + `edit foo` prepends the definition of `foo` to the top of the most recently saved file. + `edit` without arguments invokes a search to select a definition for editing, which requires that `fzf` can be found within your PATH. +``` + +🎉 + +## You fixed a bug\! + +The stanza above with `:bug` is now passing\! You can remove `:bug` and close any appropriate Github issues. diff --git a/unison-src/transcripts/errors/obsolete-error-bug.md b/unison-src/transcripts/errors/obsolete-error-bug.md new file mode 100644 index 0000000000..39b6f667ad --- /dev/null +++ b/unison-src/transcripts/errors/obsolete-error-bug.md @@ -0,0 +1,5 @@ +This transcript will fail, because we’re claiming that the stanza has a bug, but `do.something` errors as expected. + +``` ucm :error :bug +scratch/main> do.something +``` diff --git a/unison-src/transcripts/errors/obsolete-error-bug.output.md b/unison-src/transcripts/errors/obsolete-error-bug.output.md new file mode 100644 index 0000000000..7a3a16789b --- /dev/null +++ b/unison-src/transcripts/errors/obsolete-error-bug.output.md @@ -0,0 +1,19 @@ +This transcript will fail, because we’re claiming that the stanza has a bug, but `do.something` errors as expected. + +``` ucm :error :bug +scratch/main> do.something +``` + +🎉 + +## You fixed a bug\! + +The stanza above marked with `:error :bug` is now failing with + +``` +⚠️ +I don't know how to do.something. Type `help` or `?` to get +help. +``` + +so you can remove `:bug` and close any appropriate Github issues. If the error message is different from the expected error message, open a new issue and reference it in this transcript. diff --git a/unison-src/transcripts/errors/ucm-hide-all-error.md b/unison-src/transcripts/errors/ucm-hide-all-error.md index dcf94d8d32..7a56730f69 100644 --- a/unison-src/transcripts/errors/ucm-hide-all-error.md +++ b/unison-src/transcripts/errors/ucm-hide-all-error.md @@ -1,12 +1,11 @@ - ### Transcript parser hidden errors Dangerous scary words! -When an expected error is not encountered in a `ucm:hide:all` block +When an expected error is not encountered in a `ucm :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -```ucm:hide:all:error -.> history +``` ucm :hide-all :error +scratch/main> history ``` diff --git a/unison-src/transcripts/errors/ucm-hide-all-error.output.md b/unison-src/transcripts/errors/ucm-hide-all-error.output.md index e3a9558abd..6f7c903cbd 100644 --- a/unison-src/transcripts/errors/ucm-hide-all-error.output.md +++ b/unison-src/transcripts/errors/ucm-hide-all-error.output.md @@ -1,17 +1,15 @@ - ### Transcript parser hidden errors -Dangerous scary words! +Dangerous scary words\! -When an expected error is not encountered in a `ucm:hide:all` block +When an expected error is not encountered in a `ucm :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -```ucm -.> history +``` ucm :hide-all :error +scratch/main> history ``` - 🛑 The transcript was expecting an error in the stanza above, but did not encounter one. diff --git a/unison-src/transcripts/errors/ucm-hide-all.md b/unison-src/transcripts/errors/ucm-hide-all.md index 22950a9334..a3e6d3443f 100644 --- a/unison-src/transcripts/errors/ucm-hide-all.md +++ b/unison-src/transcripts/errors/ucm-hide-all.md @@ -1,12 +1,11 @@ - ### Transcript parser hidden errors Dangerous scary words! -When an error is encountered in a `ucm:hide:all` block +When an error is encountered in a `ucm :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -```ucm:hide:all -.> move.namespace foo bar +``` ucm :hide-all +scratch/main> move.namespace foo bar ``` diff --git a/unison-src/transcripts/errors/ucm-hide-all.output.md b/unison-src/transcripts/errors/ucm-hide-all.output.md index 38ec6f09f5..fc6d21cbc6 100644 --- a/unison-src/transcripts/errors/ucm-hide-all.output.md +++ b/unison-src/transcripts/errors/ucm-hide-all.output.md @@ -1,23 +1,21 @@ - ### Transcript parser hidden errors -Dangerous scary words! +Dangerous scary words\! -When an error is encountered in a `ucm:hide:all` block +When an error is encountered in a `ucm :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -```ucm -.> move.namespace foo bar +``` ucm :hide-all +scratch/main> move.namespace foo bar ``` - 🛑 The transcript failed due to an error in the stanza above. The error is: +``` +⚠️ - ⚠️ - - The namespace foo doesn't exist. - +The namespace foo doesn't exist. +``` diff --git a/unison-src/transcripts/errors/ucm-hide-error.md b/unison-src/transcripts/errors/ucm-hide-error.md index 68da57efc2..802b495d49 100644 --- a/unison-src/transcripts/errors/ucm-hide-error.md +++ b/unison-src/transcripts/errors/ucm-hide-error.md @@ -1,12 +1,11 @@ - ### Transcript parser hidden errors Dangerous scary words! -When an expected error is not encountered in a `ucm:hide` block +When an expected error is not encountered in a `ucm :hide` block then the transcript parser should print the stanza and surface a helpful message. -```ucm:hide:error -.> history +``` ucm :hide:error +scratch/main> history ``` diff --git a/unison-src/transcripts/errors/ucm-hide-error.output.md b/unison-src/transcripts/errors/ucm-hide-error.output.md index 0056a35888..8deec0bfaf 100644 --- a/unison-src/transcripts/errors/ucm-hide-error.output.md +++ b/unison-src/transcripts/errors/ucm-hide-error.output.md @@ -1,17 +1,15 @@ - ### Transcript parser hidden errors -Dangerous scary words! +Dangerous scary words\! -When an expected error is not encountered in a `ucm:hide` block +When an expected error is not encountered in a `ucm :hide` block then the transcript parser should print the stanza and surface a helpful message. -```ucm -.> history +``` ucm :hide :error +scratch/main> history ``` - 🛑 The transcript was expecting an error in the stanza above, but did not encounter one. diff --git a/unison-src/transcripts/errors/ucm-hide.md b/unison-src/transcripts/errors/ucm-hide.md index aa725ada4c..8cca437cc3 100644 --- a/unison-src/transcripts/errors/ucm-hide.md +++ b/unison-src/transcripts/errors/ucm-hide.md @@ -1,12 +1,11 @@ - ### Transcript parser hidden errors Dangerous scary words! -When an error is encountered in a `ucm:hide` block +When an error is encountered in a `ucm :hide` block then the transcript parser should print the stanza and surface a helpful message. -```ucm:hide -.> move.namespace foo bar +``` ucm :hide +scratch/main> move.namespace foo bar ``` diff --git a/unison-src/transcripts/errors/ucm-hide.output.md b/unison-src/transcripts/errors/ucm-hide.output.md index fe4faa583d..c42cd9294f 100644 --- a/unison-src/transcripts/errors/ucm-hide.output.md +++ b/unison-src/transcripts/errors/ucm-hide.output.md @@ -1,23 +1,21 @@ - ### Transcript parser hidden errors -Dangerous scary words! +Dangerous scary words\! -When an error is encountered in a `ucm:hide` block +When an error is encountered in a `ucm :hide` block then the transcript parser should print the stanza and surface a helpful message. -```ucm -.> move.namespace foo bar +``` ucm :hide +scratch/main> move.namespace foo bar ``` - 🛑 The transcript failed due to an error in the stanza above. The error is: +``` +⚠️ - ⚠️ - - The namespace foo doesn't exist. - +The namespace foo doesn't exist. +``` diff --git a/unison-src/transcripts/errors/unison-hide-all-error.md b/unison-src/transcripts/errors/unison-hide-all-error.md index 0364b35fdf..ca2bd023ba 100644 --- a/unison-src/transcripts/errors/unison-hide-all-error.md +++ b/unison-src/transcripts/errors/unison-hide-all-error.md @@ -1,10 +1,9 @@ - ### Transcript parser hidden errors -When an expected error is not encountered in a `unison:hide:all:error` block +When an expected error is not encountered in a `unison :hide-all :error` block then the transcript parser should print the stanza and surface a helpful message. -```unison:hide:all:error +``` unison :hide-all :error myVal = 3 -``` \ No newline at end of file +``` diff --git a/unison-src/transcripts/errors/unison-hide-all-error.output.md b/unison-src/transcripts/errors/unison-hide-all-error.output.md index 3c3e6f3e5f..6205069903 100644 --- a/unison-src/transcripts/errors/unison-hide-all-error.output.md +++ b/unison-src/transcripts/errors/unison-hide-all-error.output.md @@ -1,16 +1,13 @@ - ### Transcript parser hidden errors -When an expected error is not encountered in a `unison:hide:all:error` block +When an expected error is not encountered in a `unison :hide-all :error` block then the transcript parser should print the stanza and surface a helpful message. -```unison +``` unison :hide-all :error myVal = 3 ``` - - 🛑 The transcript was expecting an error in the stanza above, but did not encounter one. diff --git a/unison-src/transcripts/errors/unison-hide-all.md b/unison-src/transcripts/errors/unison-hide-all.md index b722caad70..9288252881 100644 --- a/unison-src/transcripts/errors/unison-hide-all.md +++ b/unison-src/transcripts/errors/unison-hide-all.md @@ -1,10 +1,9 @@ - ### Transcript parser hidden errors -When an error is encountered in a `unison:hide:all` block +When an error is encountered in a `unison :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -```unison:hide:all +``` unison :hide-all g 3 ``` diff --git a/unison-src/transcripts/errors/unison-hide-all.output.md b/unison-src/transcripts/errors/unison-hide-all.output.md index 9b313c82a6..89cd4724b7 100644 --- a/unison-src/transcripts/errors/unison-hide-all.output.md +++ b/unison-src/transcripts/errors/unison-hide-all.output.md @@ -1,32 +1,28 @@ - ### Transcript parser hidden errors -When an error is encountered in a `unison:hide:all` block +When an error is encountered in a `unison :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -```unison +``` unison :hide-all g 3 ``` - - 🛑 The transcript failed due to an error in the stanza above. The error is: +``` +This looks like the start of an expression here - This looks like the start of an expression here - - 1 | g 3 - - but at the file top-level, I expect one of the following: - - - A binding, like g = 42 OR - g : Nat - g = 42 - - A watch expression, like > g + 1 - - An `ability` declaration, like unique ability Foo where ... - - A `type` declaration, like structural type Optional a = None | Some a - + 1 | g 3 +but at the file top-level, I expect one of the following: + + - A binding, like g = 42 OR + g : Nat + g = 42 + - A watch expression, like > g + 1 + - An `ability` declaration, like unique ability Foo where ... + - A `type` declaration, like structural type Optional a = None | Some a +``` diff --git a/unison-src/transcripts/errors/unison-hide-error.md b/unison-src/transcripts/errors/unison-hide-error.md index 1ab6e675d3..29eb056f83 100644 --- a/unison-src/transcripts/errors/unison-hide-error.md +++ b/unison-src/transcripts/errors/unison-hide-error.md @@ -1,10 +1,9 @@ - ### Transcript parser hidden errors -When an expected error is not encountered in a `unison:hide:error` block +When an expected error is not encountered in a `unison :hide:error` block then the transcript parser should print the stanza and surface a helpful message. -```unison:hide:error +``` unison :hide:error myVal = 3 -``` \ No newline at end of file +``` diff --git a/unison-src/transcripts/errors/unison-hide-error.output.md b/unison-src/transcripts/errors/unison-hide-error.output.md index 30ab85dc58..7bc464673c 100644 --- a/unison-src/transcripts/errors/unison-hide-error.output.md +++ b/unison-src/transcripts/errors/unison-hide-error.output.md @@ -1,16 +1,13 @@ - ### Transcript parser hidden errors -When an expected error is not encountered in a `unison:hide:error` block +When an expected error is not encountered in a `unison :hide:error` block then the transcript parser should print the stanza and surface a helpful message. -```unison +``` unison :hide :error myVal = 3 ``` - - 🛑 The transcript was expecting an error in the stanza above, but did not encounter one. diff --git a/unison-src/transcripts/errors/unison-hide.md b/unison-src/transcripts/errors/unison-hide.md index 52b5ef4000..4a920cfe2b 100644 --- a/unison-src/transcripts/errors/unison-hide.md +++ b/unison-src/transcripts/errors/unison-hide.md @@ -1,10 +1,9 @@ - ### Transcript parser hidden errors -When an error is encountered in a `unison:hide` block +When an error is encountered in a `unison :hide` block then the transcript parser should print the stanza and surface a helpful message. -```unison:hide +``` unison :hide g 3 ``` diff --git a/unison-src/transcripts/errors/unison-hide.output.md b/unison-src/transcripts/errors/unison-hide.output.md index bf410ca30e..f9a48fb687 100644 --- a/unison-src/transcripts/errors/unison-hide.output.md +++ b/unison-src/transcripts/errors/unison-hide.output.md @@ -1,32 +1,28 @@ - ### Transcript parser hidden errors -When an error is encountered in a `unison:hide` block +When an error is encountered in a `unison :hide` block then the transcript parser should print the stanza and surface a helpful message. -```unison +``` unison :hide g 3 ``` - - 🛑 The transcript failed due to an error in the stanza above. The error is: +``` +This looks like the start of an expression here - This looks like the start of an expression here - - 1 | g 3 - - but at the file top-level, I expect one of the following: - - - A binding, like g = 42 OR - g : Nat - g = 42 - - A watch expression, like > g + 1 - - An `ability` declaration, like unique ability Foo where ... - - A `type` declaration, like structural type Optional a = None | Some a - + 1 | g 3 +but at the file top-level, I expect one of the following: + + - A binding, like g = 42 OR + g : Nat + g = 42 + - A watch expression, like > g + 1 + - An `ability` declaration, like unique ability Foo where ... + - A `type` declaration, like structural type Optional a = None | Some a +``` diff --git a/unison-src/transcripts/escape-sequences.md b/unison-src/transcripts/escape-sequences.md deleted file mode 100644 index fc7955ff3d..0000000000 --- a/unison-src/transcripts/escape-sequences.md +++ /dev/null @@ -1,5 +0,0 @@ -```unison -> "Rúnar" -> "῎Ανδρα μοι ἔννεπε, Μοῦσα, πολύτροπον" -> "古池や蛙飛びこむ水の音" -``` diff --git a/unison-src/transcripts/escape-sequences.output.md b/unison-src/transcripts/escape-sequences.output.md deleted file mode 100644 index 46cb0e0459..0000000000 --- a/unison-src/transcripts/escape-sequences.output.md +++ /dev/null @@ -1,30 +0,0 @@ -```unison -> "Rúnar" -> "῎Ανδρα μοι ἔννεπε, Μοῦσα, πολύτροπον" -> "古池や蛙飛びこむ水の音" -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > "Rúnar" - ⧩ - "Rúnar" - - 2 | > "῎Ανδρα μοι ἔννεπε, Μοῦσα, πολύτροπον" - ⧩ - "῎Ανδρα μοι ἔννεπε, Μοῦσα, πολύτροπον" - - 3 | > "古池や蛙飛びこむ水の音" - ⧩ - "古池や蛙飛びこむ水の音" - -``` diff --git a/unison-src/transcripts/find-by-type.md b/unison-src/transcripts/find-by-type.md deleted file mode 100644 index 009ad845e5..0000000000 --- a/unison-src/transcripts/find-by-type.md +++ /dev/null @@ -1,27 +0,0 @@ -```ucm:hide -.> alias.type ##Text builtin.Text -``` - -```unison:hide -unique type A = A Text - -foo : A -foo = A "foo!" - -bar : Text -> A -bar = A - -baz : A -> Text -baz = cases - A t -> t -``` - -```ucm -.> add -.> find : Text -> A -.> find : A -> Text -.> find : A -``` -```ucm:error -.> find : Text -``` diff --git a/unison-src/transcripts/find-by-type.output.md b/unison-src/transcripts/find-by-type.output.md deleted file mode 100644 index 0577051f92..0000000000 --- a/unison-src/transcripts/find-by-type.output.md +++ /dev/null @@ -1,55 +0,0 @@ -```unison -unique type A = A Text - -foo : A -foo = A "foo!" - -bar : Text -> A -bar = A - -baz : A -> Text -baz = cases - A t -> t -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - type A - bar : Text -> A - baz : A -> Text - foo : A - -.> find : Text -> A - - 1. bar : Text -> A - 2. A.A : Text -> A - - -.> find : A -> Text - - 1. baz : A -> Text - - -.> find : A - - 1. foo : A - - -``` -```ucm -.> find : Text - - ☝️ - - I couldn't find exact type matches, resorting to fuzzy - matching... - - 1. bar : Text -> A - 2. baz : A -> Text - 3. A.A : Text -> A - - -``` diff --git a/unison-src/transcripts/find-command.md b/unison-src/transcripts/find-command.md deleted file mode 100644 index 46f852dd35..0000000000 --- a/unison-src/transcripts/find-command.md +++ /dev/null @@ -1,50 +0,0 @@ -```ucm:hide -.> builtins.merge -.> move builtin lib.builtin -``` - -```unison:hide -foo = 1 -lib.foo = 2 -lib.bar = 3 -cat.foo = 4 -cat.lib.foo = 5 -cat.lib.bar = 6 -somewhere.bar = 7 -``` - -```ucm:hide -.> add -``` - -```ucm -.> find foo -.> view 1 -.> find.all foo -.> view 1 -``` - -```ucm -.> find-in cat foo -.> view 1 -.> find-in.all cat foo -.> view 1 -``` - -```ucm -.somewhere> find bar -.somewhere> find.global bar -``` - -```ucm -.> find bar -.> find-in somewhere bar -``` - -```ucm:error -.> find baz -``` - -```ucm:error -.> find.global notHere -``` diff --git a/unison-src/transcripts/find-command.output.md b/unison-src/transcripts/find-command.output.md deleted file mode 100644 index f3a11b8913..0000000000 --- a/unison-src/transcripts/find-command.output.md +++ /dev/null @@ -1,112 +0,0 @@ -```unison -foo = 1 -lib.foo = 2 -lib.bar = 3 -cat.foo = 4 -cat.lib.foo = 5 -cat.lib.bar = 6 -somewhere.bar = 7 -``` - -```ucm -.> find foo - - 1. cat.foo : Nat - 2. foo : Nat - - -.> view 1 - - cat.foo : Nat - cat.foo = 4 - -.> find.all foo - - 1. cat.foo : Nat - 2. cat.lib.foo : Nat - 3. lib.foo : Nat - 4. foo : Nat - - -.> view 1 - - cat.foo : Nat - cat.foo = 4 - -``` -```ucm -.> find-in cat foo - - 1. foo : Nat - - -.> view 1 - - cat.foo : Nat - cat.foo = 4 - -.> find-in.all cat foo - - 1. lib.foo : Nat - 2. foo : Nat - - -.> view 1 - - cat.lib.foo : Nat - cat.lib.foo = 5 - -``` -```ucm -.somewhere> find bar - - 1. bar : ##Nat - - -.somewhere> find.global bar - - 1. .cat.lib.bar : Nat - 2. .lib.bar : Nat - 3. .somewhere.bar : Nat - - -``` -```ucm -.> find bar - - 1. somewhere.bar : Nat - - -.> find-in somewhere bar - - 1. bar : Nat - - -``` -```ucm -.> find baz - - ☝️ - - I couldn't find matches in this namespace, searching in - 'lib'... - - 😶 - - No results. Check your spelling, or try using tab completion - to supply command arguments. - - `find.global` can be used to search outside the current - namespace. - -``` -```ucm -.> find.global notHere - - 😶 - - No results. Check your spelling, or try using tab completion - to supply command arguments. - - -``` diff --git a/unison-src/transcripts/fix-1381-excess-propagate.md b/unison-src/transcripts/fix-1381-excess-propagate.md deleted file mode 100644 index 84da98c5bc..0000000000 --- a/unison-src/transcripts/fix-1381-excess-propagate.md +++ /dev/null @@ -1,28 +0,0 @@ -We were seeing an issue where (it seemed) that every namespace that was visited during a propagate would get a new history node, even when it didn't contain any dependents. - -Example: -```unison:hide -a = "a term" -X.foo = "a namespace" -``` - -```ucm -.> add -``` - -Here is an update which should not affect `X`: -```unison:hide -a = "an update" -``` -```ucm -.> update -``` - -As of the time of this writing, the history for `X` should be a single node, `#4eeuo5bsfr`; -```ucm -.> history X -``` -however, as of release/M1i, we saw an extraneous node appear. If your `ucm` is fixed, you won't see it below: -```ucm:error -.> history #7nl6ppokhg -``` diff --git a/unison-src/transcripts/fix-1381-excess-propagate.output.md b/unison-src/transcripts/fix-1381-excess-propagate.output.md deleted file mode 100644 index f07217266b..0000000000 --- a/unison-src/transcripts/fix-1381-excess-propagate.output.md +++ /dev/null @@ -1,52 +0,0 @@ -We were seeing an issue where (it seemed) that every namespace that was visited during a propagate would get a new history node, even when it didn't contain any dependents. - -Example: -```unison -a = "a term" -X.foo = "a namespace" -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - X.foo : ##Text - a : ##Text - -``` -Here is an update which should not affect `X`: -```unison -a = "an update" -``` - -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -``` -As of the time of this writing, the history for `X` should be a single node, `#4eeuo5bsfr`; -```ucm -.> history X - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #das1se4g2i (start of history) - -``` -however, as of release/M1i, we saw an extraneous node appear. If your `ucm` is fixed, you won't see it below: -```ucm -.> history #7nl6ppokhg - - 😶 - - I don't know of a namespace with that hash. - -``` diff --git a/unison-src/transcripts/fix-2258-if-as-list-element.output.md b/unison-src/transcripts/fix-2258-if-as-list-element.output.md deleted file mode 100644 index 50c28c0046..0000000000 --- a/unison-src/transcripts/fix-2258-if-as-list-element.output.md +++ /dev/null @@ -1,62 +0,0 @@ -Tests that `if` statements can appear as list and tuple elements. - -```unison -> [ if true then 1 else 0 ] - -> [ if true then 1 else 0, 1] - -> [1, if true then 1 else 0] - -> (if true then 1 else 0, 0) - -> (0, if true then 1 else 0) - -> (1) - -> (1,2) - -> (1,2,3) - -> [1,2,3] - -> [] - -> [1] - -> [1,2] - -> [1,2,3] - -> [ - 1, - 2, - 3 - ] - -> [ - 1, - 2, - 3,] - -> (1,2,3,) - -> (1, - 2,) - -structural ability Zoot where zoot : () - -Zoot.handler : Request {Zoot} a -> a -Zoot.handler = cases - { a } -> a - { zoot -> k } -> handle !k with Zoot.handler - -fst = cases (x,_) -> x - -> List.size - [ if true then (x y -> y) - else handle (x y -> x) with fst (Zoot.handler, 42), - cases a, b -> a Nat.+ b, -- multi-arg cases lambda - cases x, y -> x Nat.+ y - ] -``` - diff --git a/unison-src/transcripts/fix-big-list-crash.output.md b/unison-src/transcripts/fix-big-list-crash.output.md deleted file mode 100644 index 1d14e77d7b..0000000000 --- a/unison-src/transcripts/fix-big-list-crash.output.md +++ /dev/null @@ -1,24 +0,0 @@ -#### Big list crash - -Big lists have been observed to crash, while in the garbage collection step. - -```unison -unique type Direction = U | D | L | R - -x = [(R,1005),(U,563),(R,417),(U,509),(L,237),(U,555),(R,397),(U,414),(L,490),(U,336),(L,697),(D,682),(L,180),(U,951),(L,189),(D,547),(R,697),(U,583),(L,172),(D,859),(L,370),(D,114),(L,519),(U,829),(R,389),(U,608),(R,66),(D,634),(L,320),(D,49),(L,931),(U,137),(L,349),(D,689),(L,351),(D,829),(R,819),(D,138),(L,118),(D,849),(R,230),(U,858),(L,509),(D,311),(R,815),(U,217),(R,359),(U,840),(R,77),(U,230),(R,361),(U,322),(R,300),(D,646),(R,348),(U,815),(R,793),(D,752),(R,967),(U,128),(R,948),(D,499),(R,359),(U,572),(L,566),(U,815),(R,630),(D,290),(L,829),(D,736),(R,358),(U,778),(R,891),(U,941),(R,544),(U,889),(L,920),(U,913),(L,447),(D,604),(R,538),(U,818),(L,215),(D,437),(R,447),(U,576),(R,452),(D,794),(R,864),(U,269),(L,325),(D,35),(L,268),(D,639),(L,101),(U,777),(L,776),(U,958),(R,105),(U,517),(R,667),(D,423),(R,603),(U,469),(L,125),(D,919),(R,879),(U,994),(R,665),(D,377),(R,456),(D,570),(L,685),(U,291),(R,261),(U,846),(R,840),(U,418),(L,974),(D,270),(L,312),(D,426),(R,621),(D,334),(L,855),(D,378),(R,694),(U,845),(R,481),(U,895),(L,362),(D,840),(L,712),(U,57),(R,276),(D,643),(R,566),(U,348),(R,361),(D,144),(L,287),(D,864),(L,556),(U,610),(L,927),(U,322),(R,271),(D,90),(L,741),(U,446),(R,181),(D,527),(R,56),(U,805),(L,907),(D,406),(L,286),(U,873),(L,79),(D,280),(L,153),(D,377),(R,253),(D,61),(R,475),(D,804),(R,788),(U,393),(L,660),(U,314),(R,489),(D,491),(L,234),(D,712),(L,253),(U,651),(L,777),(D,726),(R,146),(U,47),(R,630),(U,517),(R,226),(U,624),(L,834),(D,153),(L,513),(U,799),(R,287),(D,868),(R,982),(U,390),(L,296),(D,373),(R,9),(U,994),(R,105),(D,673),(L,657),(D,868),(R,738),(D,277),(R,374),(U,828),(R,860),(U,247),(R,484),(U,986),(L,723),(D,847),(L,578),(U,487),(L,51),(D,865),(L,328),(D,199),(R,812),(D,726),(R,355),(D,463),(R,761),(U,69),(R,508),(D,753),(L,81),(D,50),(L,345),(D,66),(L,764),(D,466),(L,975),(U,619),(R,59),(D,788),(L,737),(D,360),(R,14),(D,253),(L,512),(D,417),(R,828),(D,188),(L,394),(U,212),(R,658),(U,369),(R,920),(U,927),(L,339),(U,552),(R,856),(D,458),(R,407),(U,41),(L,930),(D,460),(R,809),(U,467),(L,410),(D,800),(L,135),(D,596),(R,678),(D,4),(L,771),(D,637),(L,876),(U,192),(L,406),(D,136),(R,666),(U,730),(R,711),(D,291),(L,586),(U,845),(R,606),(U,2),(L,228),(D,759),(R,244),(U,946),(R,948),(U,160),(R,397),(U,134),(R,188),(U,850),(R,623),(D,315),(L,219),(D,450),(R,489),(U,374),(R,299),(D,474),(L,767),(D,679),(L,160),(D,403),(L,708)] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Direction - x : [(Direction, Nat)] - -``` diff --git a/unison-src/transcripts/fix-ls.md b/unison-src/transcripts/fix-ls.md deleted file mode 100644 index 5bb9b950e3..0000000000 --- a/unison-src/transcripts/fix-ls.md +++ /dev/null @@ -1,15 +0,0 @@ -```ucm -test-ls/main> builtins.merge -``` - -```unison -foo.bar.add x y = x Int.+ y - -foo.bar.subtract x y = x Int.- y -``` - -```ucm -test-ls/main> add -test-ls/main> ls foo -test-ls/main> ls 1 -``` diff --git a/unison-src/transcripts/fix-ls.output.md b/unison-src/transcripts/fix-ls.output.md deleted file mode 100644 index 56277c6925..0000000000 --- a/unison-src/transcripts/fix-ls.output.md +++ /dev/null @@ -1,44 +0,0 @@ -```ucm -test-ls/main> builtins.merge - - Done. - -``` -```unison -foo.bar.add x y = x Int.+ y - -foo.bar.subtract x y = x Int.- y -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo.bar.add : Int -> Int -> Int - foo.bar.subtract : Int -> Int -> Int - -``` -```ucm -test-ls/main> add - - ⍟ I've added these definitions: - - foo.bar.add : Int -> Int -> Int - foo.bar.subtract : Int -> Int -> Int - -test-ls/main> ls foo - - 1. bar/ (2 terms) - -test-ls/main> ls 1 - - 1. add (Int -> Int -> Int) - 2. subtract (Int -> Int -> Int) - -``` diff --git a/unison-src/transcripts/fix1063.md b/unison-src/transcripts/fix1063.md deleted file mode 100644 index a7160f3564..0000000000 --- a/unison-src/transcripts/fix1063.md +++ /dev/null @@ -1,19 +0,0 @@ -Tests that functions named `.` are rendered correctly. - -```ucm:hide -.> builtins.merge -``` - -``` unison -(`.`) f g x = f (g x) - -use Boolean not - -noop = not `.` not -``` - -``` ucm -.> add -.> view noop -``` - diff --git a/unison-src/transcripts/fix1063.output.md b/unison-src/transcripts/fix1063.output.md deleted file mode 100644 index 80a1cc8a26..0000000000 --- a/unison-src/transcripts/fix1063.output.md +++ /dev/null @@ -1,40 +0,0 @@ -Tests that functions named `.` are rendered correctly. - -```unison -(`.`) f g x = f (g x) - -use Boolean not - -noop = not `.` not -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - `.` : (i1 ->{g1} o) -> (i ->{g} i1) -> i ->{g1, g} o - noop : Boolean -> Boolean - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - `.` : (i1 ->{g1} o) -> (i ->{g} i1) -> i ->{g1, g} o - noop : Boolean -> Boolean - -.> view noop - - noop : Boolean -> Boolean - noop = - use Boolean not - not `.` not - -``` diff --git a/unison-src/transcripts/fix1334.md b/unison-src/transcripts/fix1334.md deleted file mode 100644 index 68e6967481..0000000000 --- a/unison-src/transcripts/fix1334.md +++ /dev/null @@ -1,10 +0,0 @@ -Previously, the `alias.term` and `alias.type` would fail if the source argument was hash-only, and there was no way to create an alias for a definition that didn't already have a name. Also, the `replace.term` and `replace.type` _only_ worked on hashes, and they had to be _full_ hashes. - -With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual. - -Let's make some hash-only aliases, now that we can. :mad-with-power-emoji: - -```ucm -.> alias.type ##Nat Cat -.> alias.term ##Nat.+ please_fix_763.+ -``` diff --git a/unison-src/transcripts/fix1334.output.md b/unison-src/transcripts/fix1334.output.md deleted file mode 100644 index d397a51a1a..0000000000 --- a/unison-src/transcripts/fix1334.output.md +++ /dev/null @@ -1,16 +0,0 @@ -Previously, the `alias.term` and `alias.type` would fail if the source argument was hash-only, and there was no way to create an alias for a definition that didn't already have a name. Also, the `replace.term` and `replace.type` _only_ worked on hashes, and they had to be _full_ hashes. - -With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual. - -Let's make some hash-only aliases, now that we can. :mad-with-power-emoji: - -```ucm -.> alias.type ##Nat Cat - - Done. - -.> alias.term ##Nat.+ please_fix_763.+ - - Done. - -``` diff --git a/unison-src/transcripts/fix1390.md b/unison-src/transcripts/fix1390.md deleted file mode 100644 index 807cb14d25..0000000000 --- a/unison-src/transcripts/fix1390.md +++ /dev/null @@ -1,28 +0,0 @@ - -```ucm -.> builtins.merge -``` - -```unison --- List.map : (a -> b) -> [a] -> [b] -List.map f = - go acc = cases - [] -> acc - h +: t -> go (acc :+ f h) t - go [] -``` - -```ucm -.> add -.> view List.map -``` - -```unison -List.map2 : (g -> g2) -> [g] -> [g2] -List.map2 f = - unused = "just to give this a different hash" - go acc = cases - [] -> acc - h +: t -> go (acc :+ f h) t - go [] -``` diff --git a/unison-src/transcripts/fix1390.output.md b/unison-src/transcripts/fix1390.output.md deleted file mode 100644 index 67155bde52..0000000000 --- a/unison-src/transcripts/fix1390.output.md +++ /dev/null @@ -1,69 +0,0 @@ - -```ucm -.> builtins.merge - - Done. - -``` -```unison --- List.map : (a -> b) -> [a] -> [b] -List.map f = - go acc = cases - [] -> acc - h +: t -> go (acc :+ f h) t - go [] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - List.map : (i ->{g} o) -> [i] ->{g} [o] - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - List.map : (i ->{g} o) -> [i] ->{g} [o] - -.> view List.map - - List.map : (i ->{g} o) -> [i] ->{g} [o] - List.map f = - go acc = cases - [] -> acc - h +: t -> go (acc :+ f h) t - go [] - -``` -```unison -List.map2 : (g -> g2) -> [g] -> [g2] -List.map2 f = - unused = "just to give this a different hash" - go acc = cases - [] -> acc - h +: t -> go (acc :+ f h) t - go [] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - List.map2 : (g ->{h} g2) -> [g] ->{h} [g2] - -``` diff --git a/unison-src/transcripts/fix1532.md b/unison-src/transcripts/fix1532.md deleted file mode 100644 index 6b5a07c938..0000000000 --- a/unison-src/transcripts/fix1532.md +++ /dev/null @@ -1,40 +0,0 @@ -```ucm -.> builtins.merge -``` - -First, lets create two namespaces. `foo` and `bar`, and add some definitions. - -```unison -foo.x = 42 -foo.y = 100 -bar.z = x + y -``` - -```ucm -.> add -``` - -Let's see what we have created... - -```ucm -.> ls -``` - -Now, if we try deleting the namespace `foo`, we get an error, as expected. - -```ucm:error -.> delete.namespace foo -``` - -Any numbered arguments should refer to `bar.z`. - -```ucm -.> debug.numberedArgs -``` - -We can then delete the dependent term, and then delete `foo`. - -```ucm -.> delete.term 1 -.> delete.namespace foo -``` diff --git a/unison-src/transcripts/fix1532.output.md b/unison-src/transcripts/fix1532.output.md deleted file mode 100644 index d2707bb51a..0000000000 --- a/unison-src/transcripts/fix1532.output.md +++ /dev/null @@ -1,89 +0,0 @@ -```ucm -.> builtins.merge - - Done. - -``` -First, lets create two namespaces. `foo` and `bar`, and add some definitions. - -```unison -foo.x = 42 -foo.y = 100 -bar.z = x + y -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bar.z : Nat - foo.x : Nat - foo.y : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - bar.z : Nat - foo.x : Nat - foo.y : Nat - -``` -Let's see what we have created... - -```ucm -.> ls - - 1. bar/ (1 term) - 2. builtin/ (469 terms, 74 types) - 3. foo/ (2 terms) - -``` -Now, if we try deleting the namespace `foo`, we get an error, as expected. - -```ucm -.> delete.namespace foo - - ⚠️ - - I didn't delete the namespace because the following - definitions are still in use. - - Dependency Referenced In - x 1. bar.z - - y 2. bar.z - - If you want to proceed anyways and leave those definitions - without names, use delete.namespace.force - -``` -Any numbered arguments should refer to `bar.z`. - -```ucm -.> debug.numberedArgs - - 1. bar.z - 2. bar.z - -``` -We can then delete the dependent term, and then delete `foo`. - -```ucm -.> delete.term 1 - - Done. - -.> delete.namespace foo - - Done. - -``` diff --git a/unison-src/transcripts/fix1578.md b/unison-src/transcripts/fix1578.md deleted file mode 100644 index 8e2e7958f3..0000000000 --- a/unison-src/transcripts/fix1578.md +++ /dev/null @@ -1,112 +0,0 @@ -This transcript shows how suffix-based name resolution works when definitions in the file share a suffix with definitions already in the codebase. - -## Setup - -```ucm:hide -.> builtins.merge -``` - -As setup, we'll add a data type `Day` and a definition `foo.bar : Nat`. - -```unison:hide -unique type Day = Sun | Mon | Tue | Wed | Thu | Fri | Sat - -foo.bar : Nat -foo.bar = 23 -``` - -```ucm:hide -.> add -``` - -Suffix-based name resolution prefers to use names locally defined in the current file, then checks for matches in the codebase. Here are the precise rules, which will be explained below with examples: - -* If a symbol, `s`, is a suffix of exactly one definition `d` in the file, then `s` refers to `d`. -* Otherwise, if `s` is a suffix of exactly one definition `d` in the codebase, then `s` refers to `d`. -* Otherwise, if `s` is a suffix of multiple definitions in the file or the codebase, then (at least for terms) type-directed name resolution will be attempted to figure out which definition `s` refers to. - -## Example 1: local file term definitions shadow codebase term definitions - -This should typecheck, using the file's `bar : Text` rather than the codebase `foo.bar : Nat`: - -```unison:hide -use Text ++ - -bar : Text -bar = "hello" - -baz = bar ++ ", world!" -``` - -## Example 2: any locally unique term suffix shadows codebase term definitions - -This should also typecheck, using the file's `oog.bar`. This shows you can refer to a definition in the file by any suffix that is unique to definitions in the file (even if that suffix may match other definitions in the _codebase_). See example 4 below for overriding this behavior. - -```unison:hide -use Text ++ - -oog.bar = "hello" - -baz = bar ++ ", world!" -``` - -This subtle test establishes that we aren't using type-directed name resolution (TDNR) for the local term references in the file. If this were using TDNR, it would fail with an ambiguity as there's nothing that pins down the expected type of `bar` here: - -```unison:hide -use Text ++ - -oog.bar = "hello" - -baz = (bar, 42) -``` - -This subtle test establishes that locally introduced variables (within a function, say) correctly shadow definitions introduced at the file top level: - -```unison:hide -use Text ++ - -oog.bar = "hello" - -baz : [Int] -> ([Int], Nat) -baz bar = (bar, 42) -- here, `bar` refers to the parameter -``` - -## Example 3: Local type and constructor definitions shadow codebase definitions - -This should also typecheck, using the local `Sun`, and not `Day.Sun` which exists in the codebase, and the local `Day`, not the codebase `Day`. - -```unison:hide -structural type Zoot = Zonk | Sun - -structural type Day = Day Int - -use Zoot Zonk - -flip : Zoot -> Zoot -flip = cases - Sun -> Zonk - Zonk -> Sun - -day1 : Day -day1 = Day +1 -``` - -## Example 4: Refering to codebase definitions via a unique suffix - -Even though local definitions are preferred, you can refer to definitions in the codebase via any unique suffix that doesn't also exist in the file. - -```unison:hide -structural type Zoot = Zonk | Sun - -use Zoot Zonk - -blah = cases - Day.Sun -> Day.Tue - day -> day - -blah2 = - -- imports work too if you get tired of typing Day.Sun over and over - use Day Sun - cases Sun -> Wed - day -> day -``` diff --git a/unison-src/transcripts/fix1578.output.md b/unison-src/transcripts/fix1578.output.md deleted file mode 100644 index 1b57bcabd6..0000000000 --- a/unison-src/transcripts/fix1578.output.md +++ /dev/null @@ -1,105 +0,0 @@ -This transcript shows how suffix-based name resolution works when definitions in the file share a suffix with definitions already in the codebase. - -## Setup - -As setup, we'll add a data type `Day` and a definition `foo.bar : Nat`. - -```unison -unique type Day = Sun | Mon | Tue | Wed | Thu | Fri | Sat - -foo.bar : Nat -foo.bar = 23 -``` - -Suffix-based name resolution prefers to use names locally defined in the current file, then checks for matches in the codebase. Here are the precise rules, which will be explained below with examples: - -* If a symbol, `s`, is a suffix of exactly one definition `d` in the file, then `s` refers to `d`. -* Otherwise, if `s` is a suffix of exactly one definition `d` in the codebase, then `s` refers to `d`. -* Otherwise, if `s` is a suffix of multiple definitions in the file or the codebase, then (at least for terms) type-directed name resolution will be attempted to figure out which definition `s` refers to. - -## Example 1: local file term definitions shadow codebase term definitions - -This should typecheck, using the file's `bar : Text` rather than the codebase `foo.bar : Nat`: - -```unison -use Text ++ - -bar : Text -bar = "hello" - -baz = bar ++ ", world!" -``` - -## Example 2: any locally unique term suffix shadows codebase term definitions - -This should also typecheck, using the file's `oog.bar`. This shows you can refer to a definition in the file by any suffix that is unique to definitions in the file (even if that suffix may match other definitions in the _codebase_). See example 4 below for overriding this behavior. - -```unison -use Text ++ - -oog.bar = "hello" - -baz = bar ++ ", world!" -``` - -This subtle test establishes that we aren't using type-directed name resolution (TDNR) for the local term references in the file. If this were using TDNR, it would fail with an ambiguity as there's nothing that pins down the expected type of `bar` here: - -```unison -use Text ++ - -oog.bar = "hello" - -baz = (bar, 42) -``` - -This subtle test establishes that locally introduced variables (within a function, say) correctly shadow definitions introduced at the file top level: - -```unison -use Text ++ - -oog.bar = "hello" - -baz : [Int] -> ([Int], Nat) -baz bar = (bar, 42) -- here, `bar` refers to the parameter -``` - -## Example 3: Local type and constructor definitions shadow codebase definitions - -This should also typecheck, using the local `Sun`, and not `Day.Sun` which exists in the codebase, and the local `Day`, not the codebase `Day`. - -```unison -structural type Zoot = Zonk | Sun - -structural type Day = Day Int - -use Zoot Zonk - -flip : Zoot -> Zoot -flip = cases - Sun -> Zonk - Zonk -> Sun - -day1 : Day -day1 = Day +1 -``` - -## Example 4: Refering to codebase definitions via a unique suffix - -Even though local definitions are preferred, you can refer to definitions in the codebase via any unique suffix that doesn't also exist in the file. - -```unison -structural type Zoot = Zonk | Sun - -use Zoot Zonk - -blah = cases - Day.Sun -> Day.Tue - day -> day - -blah2 = - -- imports work too if you get tired of typing Day.Sun over and over - use Day Sun - cases Sun -> Wed - day -> day -``` - diff --git a/unison-src/transcripts/fix1696.md b/unison-src/transcripts/fix1696.md deleted file mode 100644 index c80b41a731..0000000000 --- a/unison-src/transcripts/fix1696.md +++ /dev/null @@ -1,22 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -```unison:error -structural ability Ask where ask : Nat - -ability Zoot where - zoot : Nat - -Ask.provide : '{Zoot} Nat -> '{Ask} r -> r -Ask.provide answer asker = - h = cases - {r} -> r - {Ask.ask -> resume} -> handle resume !answer with h - handle !asker with h - -dialog = Ask.provide 'zoot '("Awesome number: " ++ Nat.toText Ask.ask ++ "!") - -> dialog -``` diff --git a/unison-src/transcripts/fix1696.output.md b/unison-src/transcripts/fix1696.output.md deleted file mode 100644 index c0a9ccce85..0000000000 --- a/unison-src/transcripts/fix1696.output.md +++ /dev/null @@ -1,29 +0,0 @@ - -```unison -structural ability Ask where ask : Nat - -ability Zoot where - zoot : Nat - -Ask.provide : '{Zoot} Nat -> '{Ask} r -> r -Ask.provide answer asker = - h = cases - {r} -> r - {Ask.ask -> resume} -> handle resume !answer with h - handle !asker with h - -dialog = Ask.provide 'zoot '("Awesome number: " ++ Nat.toText Ask.ask ++ "!") - -> dialog -``` - -```ucm - - Loading changes detected in scratch.u. - - The expression in red needs the {Zoot} ability, but this location does not have access to any abilities. - - 13 | dialog = Ask.provide 'zoot '("Awesome number: " ++ Nat.toText Ask.ask ++ "!") - - -``` diff --git a/unison-src/transcripts/fix1731.md b/unison-src/transcripts/fix1731.md deleted file mode 100644 index 81adcd8de2..0000000000 --- a/unison-src/transcripts/fix1731.md +++ /dev/null @@ -1,22 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -```unison:hide -structural ability CLI where - print : Text ->{CLI} () - input : {CLI} Text -``` - -```ucm:hide -.> add -``` - -The `input` here should parse as a wildcard, not as `CLI.input`. - -```unison -repro : Text -> () -repro = cases - input -> () -``` diff --git a/unison-src/transcripts/fix1731.output.md b/unison-src/transcripts/fix1731.output.md deleted file mode 100644 index f3fc1c35d1..0000000000 --- a/unison-src/transcripts/fix1731.output.md +++ /dev/null @@ -1,28 +0,0 @@ - -```unison -structural ability CLI where - print : Text ->{CLI} () - input : {CLI} Text -``` - -The `input` here should parse as a wildcard, not as `CLI.input`. - -```unison -repro : Text -> () -repro = cases - input -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - repro : Text -> () - -``` diff --git a/unison-src/transcripts/fix1800.md b/unison-src/transcripts/fix1800.md deleted file mode 100644 index a35edb8a2d..0000000000 --- a/unison-src/transcripts/fix1800.md +++ /dev/null @@ -1,64 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -```unison:hide -printLine : Text ->{IO} () -printLine msg = - _ = putBytes.impl (stdHandle StdOut) (Text.toUtf8 (msg ++ "\n")) - () - --- An unannotated main function -main1 = '(printLine "\nhello world!") - --- Another variation -main2 _ = printLine "🌹" - --- An annotated main function -main3 : '{IO} () -main3 _ = printLine "🦄 ☁️ 🌈" -``` - -Testing a few variations here: - -* Should be able to run annotated and unannotated main functions in the current file. -* Should be able to run annotated and unannotated main functions from the codebase. - -```ucm -.> run main1 -.> run main2 -.> run main3 -.> add -.> rename.term main1 code.main1 -.> rename.term main2 code.main2 -.> rename.term main3 code.main3 -``` - -The renaming just ensures that when running `code.main1`, it has to get that main from the codebase rather than the scratch file: - -```ucm -.> run code.main1 -.> run code.main2 -.> run code.main3 -``` - -Now testing a few variations that should NOT typecheck. - -```unison:hide -main4 : Nat ->{IO} Nat -main4 n = n - -main5 : Nat ->{IO} () -main5 _ = () -``` - -This shouldn't work since `main4` and `main5` don't have the right type. - -```ucm:error -.> run main4 -``` - -```ucm:error -.> run main5 -``` diff --git a/unison-src/transcripts/fix1800.output.md b/unison-src/transcripts/fix1800.output.md deleted file mode 100644 index 0a534138a4..0000000000 --- a/unison-src/transcripts/fix1800.output.md +++ /dev/null @@ -1,114 +0,0 @@ - -```unison -printLine : Text ->{IO} () -printLine msg = - _ = putBytes.impl (stdHandle StdOut) (Text.toUtf8 (msg ++ "\n")) - () - --- An unannotated main function -main1 = '(printLine "\nhello world!") - --- Another variation -main2 _ = printLine "🌹" - --- An annotated main function -main3 : '{IO} () -main3 _ = printLine "🦄 ☁️ 🌈" -``` - -Testing a few variations here: - -* Should be able to run annotated and unannotated main functions in the current file. -* Should be able to run annotated and unannotated main functions from the codebase. - -```ucm -.> run main1 - - () - -.> run main2 - - () - -.> run main3 - - () - -.> add - - ⍟ I've added these definitions: - - main1 : '{IO} () - main2 : ∀ _. _ ->{IO} () - main3 : '{IO} () - printLine : Text ->{IO} () - -.> rename.term main1 code.main1 - - Done. - -.> rename.term main2 code.main2 - - Done. - -.> rename.term main3 code.main3 - - Done. - -``` -The renaming just ensures that when running `code.main1`, it has to get that main from the codebase rather than the scratch file: - -```ucm -.> run code.main1 - - () - -.> run code.main2 - - () - -.> run code.main3 - - () - -``` -Now testing a few variations that should NOT typecheck. - -```unison -main4 : Nat ->{IO} Nat -main4 n = n - -main5 : Nat ->{IO} () -main5 _ = () -``` - -This shouldn't work since `main4` and `main5` don't have the right type. - -```ucm -.> run main4 - - 😶 - - I found this function: - - main4 : Nat ->{IO} Nat - - but in order for me to `run` it needs to be a subtype of: - - main4 : '{IO, Exception} result - -``` -```ucm -.> run main5 - - 😶 - - I found this function: - - main5 : Nat ->{IO} () - - but in order for me to `run` it needs to be a subtype of: - - main5 : '{IO, Exception} result - -``` diff --git a/unison-src/transcripts/fix1844.md b/unison-src/transcripts/fix1844.md deleted file mode 100644 index 41c189867c..0000000000 --- a/unison-src/transcripts/fix1844.md +++ /dev/null @@ -1,11 +0,0 @@ - -```unison -structural type One a = One a -unique type Woot a b c = Woot a b c -unique type Z = Z - -snoc k aN = match k with - One a0 -> Woot (One a0) (One aN) 99 - -> snoc (One 1) 2 -``` diff --git a/unison-src/transcripts/fix1844.output.md b/unison-src/transcripts/fix1844.output.md deleted file mode 100644 index 571daa8b9a..0000000000 --- a/unison-src/transcripts/fix1844.output.md +++ /dev/null @@ -1,35 +0,0 @@ - -```unison -structural type One a = One a -unique type Woot a b c = Woot a b c -unique type Z = Z - -snoc k aN = match k with - One a0 -> Woot (One a0) (One aN) 99 - -> snoc (One 1) 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type One a - type Woot a b c - type Z - snoc : One a -> aN -> Woot (One a) (One aN) ##Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 8 | > snoc (One 1) 2 - ⧩ - Woot (One 1) (One 2) 99 - -``` diff --git a/unison-src/transcripts/fix1926.md b/unison-src/transcripts/fix1926.md deleted file mode 100644 index 373cb0e95a..0000000000 --- a/unison-src/transcripts/fix1926.md +++ /dev/null @@ -1,15 +0,0 @@ -```ucm -.> builtins.merge -``` - -```unison -> 'sq - -sq = 2934892384 -``` - -```unison -> 'sq - -sq = 2934892384 -``` diff --git a/unison-src/transcripts/fix1926.output.md b/unison-src/transcripts/fix1926.output.md deleted file mode 100644 index 9eeb00583a..0000000000 --- a/unison-src/transcripts/fix1926.output.md +++ /dev/null @@ -1,58 +0,0 @@ -```ucm -.> builtins.merge - - Done. - -``` -```unison -> 'sq - -sq = 2934892384 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - sq : Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > 'sq - ⧩ - do sq - -``` -```unison -> 'sq - -sq = 2934892384 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - sq : Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > 'sq - ⧩ - do sq - -``` diff --git a/unison-src/transcripts/fix2000.md b/unison-src/transcripts/fix2000.md deleted file mode 100644 index 812ec10df0..0000000000 --- a/unison-src/transcripts/fix2000.md +++ /dev/null @@ -1,44 +0,0 @@ -Checks that squash and merge do the same thing, with nontrivial history that -includes a merge conflict. - -```ucm:hide -.> builtins.merge -``` - -```unison -x.a.p = "af" -x.a.q = "ef" -``` - -```ucm -.> add -.> fork x y -.> fork x s -.> fork x m -.> delete.verbose y.a.p -``` - -```unison -y.a.p = "fij" -``` - -```ucm -.> add -``` - -```unison -y.b.p = "wie" -``` - -Merge back into the ancestor. - -```ucm -.> add -.> merge.old y.b y.a -.> delete.term.verbose 1 -.> merge.old y m -.> merge.old.squash y s -.s> todo -.m> todo -``` - diff --git a/unison-src/transcripts/fix2000.output.md b/unison-src/transcripts/fix2000.output.md deleted file mode 100644 index 84a674b1d7..0000000000 --- a/unison-src/transcripts/fix2000.output.md +++ /dev/null @@ -1,192 +0,0 @@ -Checks that squash and merge do the same thing, with nontrivial history that -includes a merge conflict. - -```unison -x.a.p = "af" -x.a.q = "ef" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - x.a.p : Text - x.a.q : Text - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - x.a.p : Text - x.a.q : Text - -.> fork x y - - Done. - -.> fork x s - - Done. - -.> fork x m - - Done. - -.> delete.verbose y.a.p - - Name changes: - - Original Changes - 1. m.a.p ┐ 2. y.a.p (removed) - 3. s.a.p │ - 4. x.a.p │ - 5. y.a.p ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -``` -```unison -y.a.p = "fij" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - y.a.p : Text - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - y.a.p : Text - -``` -```unison -y.b.p = "wie" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - y.b.p : Text - -``` -Merge back into the ancestor. - -```ucm -.> add - - ⍟ I've added these definitions: - - y.b.p : Text - -.> merge.old y.b y.a - - Here's what's changed in y.a after the merge: - - New name conflicts: - - 1. p#l2mmpgn323 : Text - ↓ - 2. ┌ p#l2mmpgn323 : Text - 3. └ p#nm3omrdks9 : Text - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.> delete.term.verbose 1 - - Resolved name conflicts: - - 1. ┌ y.a.p#l2mmpgn323 : Text - 2. └ y.a.p#nm3omrdks9 : Text - ↓ - 3. y.a.p#nm3omrdks9 : Text - - Tip: You can use `undo` or `reflog` to undo this change. - -.> merge.old y m - - Here's what's changed in m after the merge: - - Updates: - - 1. a.p : Text - ↓ - 2. a.p : Text - - Added definitions: - - 3. ┌ a.p : Text - 4. └ b.p : Text - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.> merge.old.squash y s - - Here's what's changed in s after the merge: - - Updates: - - 1. a.p : Text - ↓ - 2. a.p : Text - - Added definitions: - - 3. ┌ a.p : Text - 4. └ b.p : Text - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.s> todo - - ✅ - - No conflicts or edits in progress. - -.m> todo - - ✅ - - No conflicts or edits in progress. - -``` diff --git a/unison-src/transcripts/fix2004.md b/unison-src/transcripts/fix2004.md deleted file mode 100644 index ab33da9e7f..0000000000 --- a/unison-src/transcripts/fix2004.md +++ /dev/null @@ -1,82 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -Here's the scenario that can produce bad empty namespace LCAs: - -``` - deletes of v4 -j1: ... - v1 - v2 - v3 - v4 - v4a - v5 - v6 - v7 - / - - v5a - - adds of unrelated -j2: ... - v1 - v2 - v3 - v4 - x0 - x1 - x2 - x3 - / - - z1 - -``` - -So `j1` and `j2` have common history up through `v4`, then `j1` deletes some definitions while `j2` adds some definitions via shallow merges. These shallow merges then result in the LCA being the empty namespace rather than `v4`. - -First, we create some common history before a fork: - -```ucm -.> alias.term builtin.Nat.+ a.delete1 -.> alias.term builtin.Nat.* a.delete2 -.> alias.term builtin.Nat.drop a.delete3 -.> alias.type builtin.Nat a.Delete4 -``` - -Now we fork `a2` off of `a`. `a` continues on, deleting the terms it added previously and then adding one unrelated term via a merge with little history. It's this short history merge which will become a bad LCA of the empty namespace. - -```ucm -.> fork a a2 -.> delete.term.verbose a.delete1 -.> delete.term.verbose a.delete2 -.> delete.term.verbose a.delete3 -.> delete.type.verbose a.Delete4 -.> alias.term .builtin.Float.+ newbranchA.dontDelete -.> merge.old newbranchA a -.a> find -``` - -Meanwhile, `a2` adds some other unrelated terms, some via merging in namespaces with little history. When merging `a2` back into `a`, the deletes from their common history should be respected. - -```ucm -.> alias.term builtin.Text.take a2.keep1 -.> alias.term builtin.Text.take a2.keep2 -.> alias.term builtin.Text.take a2.keep3 -.> alias.term builtin.Text.take a2.keep4 -.> alias.term builtin.Text.take a2.keep5 -.> alias.term builtin.Text.take newbranchA2.keep6 -.> merge.old newbranchA2 a2 -.a2> find -``` - -```ucm -.> fork a asquash -.> merge.old a2 a -.> merge.old.squash a2 asquash -``` - -At this point, all the things that `a` has deleted (`delete1`, `delete2`, etc) should be deleted in both the merged and squashed results. Let's verify this: - -```ucm -.a> find -.asquash> find -``` - -```ucm:hide -.> view a.keep1 a.keep2 a.keep3 -.> view asquash.keep1 asquash.keep2 asquash.keep3 -``` - -```ucm:error -.> view a.Delete4 -``` - -```ucm:error -.> view asquash.delete1 -``` diff --git a/unison-src/transcripts/fix2004.output.md b/unison-src/transcripts/fix2004.output.md deleted file mode 100644 index c8216d5e89..0000000000 --- a/unison-src/transcripts/fix2004.output.md +++ /dev/null @@ -1,267 +0,0 @@ - -Here's the scenario that can produce bad empty namespace LCAs: - -```deletes -of v4 -j1: ... - v1 - v2 - v3 - v4 - v4a - v5 - v6 - v7 - / - - v5a - - adds of unrelated -j2: ... - v1 - v2 - v3 - v4 - x0 - x1 - x2 - x3 - / - - z1 - - -``` - -So `j1` and `j2` have common history up through `v4`, then `j1` deletes some definitions while `j2` adds some definitions via shallow merges. These shallow merges then result in the LCA being the empty namespace rather than `v4`. - -First, we create some common history before a fork: - -```ucm -.> alias.term builtin.Nat.+ a.delete1 - - Done. - -.> alias.term builtin.Nat.* a.delete2 - - Done. - -.> alias.term builtin.Nat.drop a.delete3 - - Done. - -.> alias.type builtin.Nat a.Delete4 - - Done. - -``` -Now we fork `a2` off of `a`. `a` continues on, deleting the terms it added previously and then adding one unrelated term via a merge with little history. It's this short history merge which will become a bad LCA of the empty namespace. - -```ucm -.> fork a a2 - - Done. - -.> delete.term.verbose a.delete1 - - Name changes: - - Original Changes - 1. a.delete1 ┐ 2. a.delete1 (removed) - 3. a2.delete1 │ - 4. builtin.Nat.+ ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -.> delete.term.verbose a.delete2 - - Name changes: - - Original Changes - 1. a.delete2 ┐ 2. a.delete2 (removed) - 3. a2.delete2 │ - 4. builtin.Nat.* ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -.> delete.term.verbose a.delete3 - - Name changes: - - Original Changes - 1. a.delete3 ┐ 2. a.delete3 (removed) - 3. a2.delete3 │ - 4. builtin.Nat.drop ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -.> delete.type.verbose a.Delete4 - - Name changes: - - Original Changes - 1. a.Delete4 ┐ 2. a.Delete4 (removed) - 3. a2.Delete4 │ - 4. builtin.Nat ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -.> alias.term .builtin.Float.+ newbranchA.dontDelete - - Done. - -.> merge.old newbranchA a - - Here's what's changed in a after the merge: - - Added definitions: - - 1. dontDelete : Float -> Float -> Float - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.a> find - - 1. dontDelete : ##Float -> ##Float -> ##Float - - -``` -Meanwhile, `a2` adds some other unrelated terms, some via merging in namespaces with little history. When merging `a2` back into `a`, the deletes from their common history should be respected. - -```ucm -.> alias.term builtin.Text.take a2.keep1 - - Done. - -.> alias.term builtin.Text.take a2.keep2 - - Done. - -.> alias.term builtin.Text.take a2.keep3 - - Done. - -.> alias.term builtin.Text.take a2.keep4 - - Done. - -.> alias.term builtin.Text.take a2.keep5 - - Done. - -.> alias.term builtin.Text.take newbranchA2.keep6 - - Done. - -.> merge.old newbranchA2 a2 - - Here's what's changed in a2 after the merge: - - Name changes: - - Original Changes - 1. keep1 ┐ 2. keep6 (added) - 3. keep2 │ - 4. keep3 │ - 5. keep4 │ - 6. keep5 ┘ - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.a2> find - - 1. delete1 : Delete4 -> Delete4 -> Delete4 - 2. delete2 : Delete4 -> Delete4 -> Delete4 - 3. delete3 : Delete4 -> Delete4 -> Delete4 - 4. builtin type Delete4 - 5. keep1 : Delete4 -> ##Text -> ##Text - 6. keep2 : Delete4 -> ##Text -> ##Text - 7. keep3 : Delete4 -> ##Text -> ##Text - 8. keep4 : Delete4 -> ##Text -> ##Text - 9. keep5 : Delete4 -> ##Text -> ##Text - 10. keep6 : Delete4 -> ##Text -> ##Text - - -``` -```ucm -.> fork a asquash - - Done. - -.> merge.old a2 a - - Here's what's changed in a after the merge: - - Added definitions: - - 1. ┌ keep1 : Delete4 -> Text -> Text - 2. │ keep2 : Delete4 -> Text -> Text - 3. │ keep3 : Delete4 -> Text -> Text - 4. │ keep4 : Delete4 -> Text -> Text - 5. │ keep5 : Delete4 -> Text -> Text - 6. └ keep6 : Delete4 -> Text -> Text - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.> merge.old.squash a2 asquash - - Here's what's changed in asquash after the merge: - - Added definitions: - - 1. ┌ keep1 : Delete4 -> Text -> Text - 2. │ keep2 : Delete4 -> Text -> Text - 3. │ keep3 : Delete4 -> Text -> Text - 4. │ keep4 : Delete4 -> Text -> Text - 5. │ keep5 : Delete4 -> Text -> Text - 6. └ keep6 : Delete4 -> Text -> Text - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` -At this point, all the things that `a` has deleted (`delete1`, `delete2`, etc) should be deleted in both the merged and squashed results. Let's verify this: - -```ucm -.a> find - - 1. dontDelete : ##Float -> ##Float -> ##Float - 2. keep1 : ##Nat -> ##Text -> ##Text - 3. keep2 : ##Nat -> ##Text -> ##Text - 4. keep3 : ##Nat -> ##Text -> ##Text - 5. keep4 : ##Nat -> ##Text -> ##Text - 6. keep5 : ##Nat -> ##Text -> ##Text - 7. keep6 : ##Nat -> ##Text -> ##Text - - -.asquash> find - - 1. dontDelete : ##Float -> ##Float -> ##Float - 2. keep1 : ##Nat -> ##Text -> ##Text - 3. keep2 : ##Nat -> ##Text -> ##Text - 4. keep3 : ##Nat -> ##Text -> ##Text - 5. keep4 : ##Nat -> ##Text -> ##Text - 6. keep5 : ##Nat -> ##Text -> ##Text - 7. keep6 : ##Nat -> ##Text -> ##Text - - -``` -```ucm -.> view a.Delete4 - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - a.Delete4 - -``` -```ucm -.> view asquash.delete1 - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - asquash.delete1 - -``` diff --git a/unison-src/transcripts/fix2026.md b/unison-src/transcripts/fix2026.md deleted file mode 100644 index 819a579e2f..0000000000 --- a/unison-src/transcripts/fix2026.md +++ /dev/null @@ -1,44 +0,0 @@ -```ucm:hide -.> builtins.mergeio -``` - -```unison -structural ability Exception where raise : Failure -> x - -ex = unsafeRun! '(printLine "hello world") - -printLine : Text ->{IO, Exception} () -printLine t = - putText stdOut t - putText stdOut "\n" - -stdOut : Handle -stdOut = stdHandle StdOut - -compose2 : (c ->{𝕖1} d) -> (a ->{𝕖2} b ->{𝕖3} c) -> a -> b ->{𝕖1,𝕖2,𝕖3} d -compose2 f g x y = f (g x y) - -putBytes : Handle -> Bytes ->{IO, Exception} () -putBytes = compose2 toException putBytes.impl - -toException : Either Failure a ->{Exception} a -toException = cases - Left e -> raise e - Right a -> a - -putText : Handle -> Text ->{IO, Exception} () -putText h t = putBytes h (toUtf8 t) - -Exception.unsafeRun! : '{Exception, g} a -> '{g} a -Exception.unsafeRun! e _ = - h : Request {Exception} a -> a - h = cases - {Exception.raise fail -> _ } -> - bug fail - {a} -> a - handle !e with h -``` - -```ucm -.> run ex -``` \ No newline at end of file diff --git a/unison-src/transcripts/fix2026.output.md b/unison-src/transcripts/fix2026.output.md deleted file mode 100644 index 1391a35c6b..0000000000 --- a/unison-src/transcripts/fix2026.output.md +++ /dev/null @@ -1,71 +0,0 @@ -```unison -structural ability Exception where raise : Failure -> x - -ex = unsafeRun! '(printLine "hello world") - -printLine : Text ->{IO, Exception} () -printLine t = - putText stdOut t - putText stdOut "\n" - -stdOut : Handle -stdOut = stdHandle StdOut - -compose2 : (c ->{𝕖1} d) -> (a ->{𝕖2} b ->{𝕖3} c) -> a -> b ->{𝕖1,𝕖2,𝕖3} d -compose2 f g x y = f (g x y) - -putBytes : Handle -> Bytes ->{IO, Exception} () -putBytes = compose2 toException putBytes.impl - -toException : Either Failure a ->{Exception} a -toException = cases - Left e -> raise e - Right a -> a - -putText : Handle -> Text ->{IO, Exception} () -putText h t = putBytes h (toUtf8 t) - -Exception.unsafeRun! : '{Exception, g} a -> '{g} a -Exception.unsafeRun! e _ = - h : Request {Exception} a -> a - h = cases - {Exception.raise fail -> _ } -> - bug fail - {a} -> a - handle !e with h -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability Exception - (also named builtin.Exception) - Exception.unsafeRun! : '{g, Exception} a -> '{g} a - compose2 : (c ->{𝕖1} d) - -> (a ->{𝕖2} b ->{𝕖3} c) - -> a - -> b - ->{𝕖1, 𝕖2, 𝕖3} d - ex : '{IO} () - printLine : Text ->{IO, Exception} () - putBytes : Handle - -> Bytes - ->{IO, Exception} () - putText : Handle -> Text ->{IO, Exception} () - stdOut : Handle - toException : Either Failure a ->{Exception} a - -``` -```ucm -.> run ex - - () - -``` diff --git a/unison-src/transcripts/fix2027.md b/unison-src/transcripts/fix2027.md deleted file mode 100644 index bcc0824566..0000000000 --- a/unison-src/transcripts/fix2027.md +++ /dev/null @@ -1,55 +0,0 @@ - - -```ucm:hide -.> builtins.merge -``` - -```unison -structural ability Exception where raise : Failure -> x - -reraise = cases - Left e -> raise e - Right a -> a - -structural type Either a b = Left a | Right b - -putBytes h bs = reraise (putBytes.impl h bs) - -toException : Either Failure a ->{Exception} a -toException = cases - Left e -> raise e - Right a -> a - -putText : Handle -> Text ->{IO, Exception} () -putText h t = putBytes h (toUtf8 t) - -bugFail = cases - Failure typ _ _ -> bug (Failure typ "problem" (Any ())) - -Exception.unsafeRun! : '{Exception, g} a -> '{g} a -Exception.unsafeRun! e _ = - h : Request {Exception} a -> a - h = cases - {Exception.raise fail -> _ } -> - bugFail fail - {a} -> a - handle !e with h - -socketSend s bytes = reraise (socketSend.impl s bytes) -closeSocket s = reraise (closeSocket.impl s) -serverSocket host port = reraise (IO.serverSocket.impl host port) - -hello : Text -> Text -> {IO, Exception} () -hello host port = - socket = serverSocket (Some host) port - msg = toUtf8 "Hello there" - socketSend socket msg - closeSocket socket - -myServer = unsafeRun! '(hello "127.0.0.1" "0") - -``` - -```ucm:error -.> run myServer -``` diff --git a/unison-src/transcripts/fix2027.output.md b/unison-src/transcripts/fix2027.output.md deleted file mode 100644 index b69a8b31bb..0000000000 --- a/unison-src/transcripts/fix2027.output.md +++ /dev/null @@ -1,96 +0,0 @@ - - -```unison -structural ability Exception where raise : Failure -> x - -reraise = cases - Left e -> raise e - Right a -> a - -structural type Either a b = Left a | Right b - -putBytes h bs = reraise (putBytes.impl h bs) - -toException : Either Failure a ->{Exception} a -toException = cases - Left e -> raise e - Right a -> a - -putText : Handle -> Text ->{IO, Exception} () -putText h t = putBytes h (toUtf8 t) - -bugFail = cases - Failure typ _ _ -> bug (Failure typ "problem" (Any ())) - -Exception.unsafeRun! : '{Exception, g} a -> '{g} a -Exception.unsafeRun! e _ = - h : Request {Exception} a -> a - h = cases - {Exception.raise fail -> _ } -> - bugFail fail - {a} -> a - handle !e with h - -socketSend s bytes = reraise (socketSend.impl s bytes) -closeSocket s = reraise (closeSocket.impl s) -serverSocket host port = reraise (IO.serverSocket.impl host port) - -hello : Text -> Text -> {IO, Exception} () -hello host port = - socket = serverSocket (Some host) port - msg = toUtf8 "Hello there" - socketSend socket msg - closeSocket socket - -myServer = unsafeRun! '(hello "127.0.0.1" "0") - -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type Either a b - (also named builtin.Either) - structural ability Exception - (also named builtin.Exception) - Exception.unsafeRun! : '{g, Exception} a -> '{g} a - bugFail : Failure -> r - closeSocket : Socket ->{IO, Exception} () - hello : Text -> Text ->{IO, Exception} () - myServer : '{IO} () - putBytes : Handle - -> Bytes - ->{IO, Exception} () - putText : Handle -> Text ->{IO, Exception} () - reraise : Either Failure b ->{Exception} b - serverSocket : Optional Text - -> Text - ->{IO, Exception} Socket - socketSend : Socket - -> Bytes - ->{IO, Exception} () - toException : Either Failure a ->{Exception} a - -``` -```ucm -.> run myServer - - 💔💥 - - I've encountered a call to builtin.bug with the following - value: - - Failure (typeLink IOFailure) "problem" (Any ()) - - Stack trace: - bug - #8ppr1tt4q2 - -``` diff --git a/unison-src/transcripts/fix2049.md b/unison-src/transcripts/fix2049.md deleted file mode 100644 index ab1983e95b..0000000000 --- a/unison-src/transcripts/fix2049.md +++ /dev/null @@ -1,79 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison -id x = x - -structural ability Stream a where - emit : a -> () - -Stream.foldl : (x ->{g} a ->{g} x) -> x -> '{g, Stream a} r -> '{g} x -Stream.foldl f z str _ = - h acc = cases - { emit x -> k } -> handle !k with h (f acc x) - { _ } -> acc - handle !str with h z - -Stream.range : Nat -> Nat -> '{Stream Nat} () -Stream.range m n = do - f : Nat ->{Stream Nat} () - f k = if k < n then emit k ; f (k+1) else () - f m - -unique type Fold' g a b x = Fold' (x -> {g} a -> {g} x) x (x -> {g} b) - -unique type Fold g a b = Fold (∀ g2 r. (∀ x. Fold' g a b x -> {g2} r) -> {g2} r) - -Fold.fromFold' : Fold' g a b x -> Fold g a b -Fold.fromFold' fold = Fold.Fold (f -> f fold) - -Fold.mkFold : (t -> {g} a -> {g} t) -> t -> (t -> {g} b) -> Fold g a b -Fold.mkFold step init extract = - Fold.fromFold' (Fold'.Fold' step init extract) - -folds.all : (a -> {g} Boolean) -> Fold g a Boolean -folds.all predicate = - Fold.mkFold (b -> a -> b && (predicate a)) true id - -Fold.Stream.fold : Fold g a b -> '{g, Stream a} r -> '{g} b -Fold.Stream.fold = - run: Fold' g a b x -> '{g, Stream a} r -> '{g} b - run = - cases Fold'.Fold' step init extract -> - stream -> _ -> extract !(foldl step init stream) - cases - Fold f -> stream -> f (f' -> run f' stream) - -> folds.all.tests.stream = - pred = n -> (Nat.gt n 2) - res : 'Boolean - res = Fold.Stream.fold (folds.all pred) (Stream.range 1 5) - !res Universal.== false -``` - -Tests some capabilities for catching runtime exceptions. - -```unison -catcher : '{IO} () ->{IO} Result -catcher act = - handle tryEval act with cases - { raise _ -> _ } -> Ok "caught" - { _ } -> Fail "nothing to catch" - -tests _ = - [ catcher do - _ = 1/0 - () - , catcher '(bug "testing") - , handle tryEval (do 1+1) with cases - { raise _ -> _ } -> Fail "1+1 failed" - { 2 } -> Ok "got the right answer" - { _ } -> Fail "got the wrong answer" - ] -``` - -```ucm -.> add -.> io.test tests -``` diff --git a/unison-src/transcripts/fix2049.output.md b/unison-src/transcripts/fix2049.output.md deleted file mode 100644 index 7e18e1f6c9..0000000000 --- a/unison-src/transcripts/fix2049.output.md +++ /dev/null @@ -1,143 +0,0 @@ -```unison -id x = x - -structural ability Stream a where - emit : a -> () - -Stream.foldl : (x ->{g} a ->{g} x) -> x -> '{g, Stream a} r -> '{g} x -Stream.foldl f z str _ = - h acc = cases - { emit x -> k } -> handle !k with h (f acc x) - { _ } -> acc - handle !str with h z - -Stream.range : Nat -> Nat -> '{Stream Nat} () -Stream.range m n = do - f : Nat ->{Stream Nat} () - f k = if k < n then emit k ; f (k+1) else () - f m - -unique type Fold' g a b x = Fold' (x -> {g} a -> {g} x) x (x -> {g} b) - -unique type Fold g a b = Fold (∀ g2 r. (∀ x. Fold' g a b x -> {g2} r) -> {g2} r) - -Fold.fromFold' : Fold' g a b x -> Fold g a b -Fold.fromFold' fold = Fold.Fold (f -> f fold) - -Fold.mkFold : (t -> {g} a -> {g} t) -> t -> (t -> {g} b) -> Fold g a b -Fold.mkFold step init extract = - Fold.fromFold' (Fold'.Fold' step init extract) - -folds.all : (a -> {g} Boolean) -> Fold g a Boolean -folds.all predicate = - Fold.mkFold (b -> a -> b && (predicate a)) true id - -Fold.Stream.fold : Fold g a b -> '{g, Stream a} r -> '{g} b -Fold.Stream.fold = - run: Fold' g a b x -> '{g, Stream a} r -> '{g} b - run = - cases Fold'.Fold' step init extract -> - stream -> _ -> extract !(foldl step init stream) - cases - Fold f -> stream -> f (f' -> run f' stream) - -> folds.all.tests.stream = - pred = n -> (Nat.gt n 2) - res : 'Boolean - res = Fold.Stream.fold (folds.all pred) (Stream.range 1 5) - !res Universal.== false -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Fold g a b - type Fold' g a b x - structural ability Stream a - Fold.Stream.fold : Fold g a b - -> '{g, Stream a} r - -> '{g} b - Fold.fromFold' : Fold' g a b x -> Fold g a b - Fold.mkFold : (t ->{g} a ->{g} t) - -> t - -> (t ->{g} b) - -> Fold g a b - Stream.foldl : (x ->{g} a ->{g} x) - -> x - -> '{g, Stream a} r - -> '{g} x - Stream.range : Nat -> Nat -> '{Stream Nat} () - folds.all : (a ->{g} Boolean) -> Fold g a Boolean - id : x -> x - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 44 | pred = n -> (Nat.gt n 2) - ⧩ - true - -``` -Tests some capabilities for catching runtime exceptions. - -```unison -catcher : '{IO} () ->{IO} Result -catcher act = - handle tryEval act with cases - { raise _ -> _ } -> Ok "caught" - { _ } -> Fail "nothing to catch" - -tests _ = - [ catcher do - _ = 1/0 - () - , catcher '(bug "testing") - , handle tryEval (do 1+1) with cases - { raise _ -> _ } -> Fail "1+1 failed" - { 2 } -> Ok "got the right answer" - { _ } -> Fail "got the wrong answer" - ] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - catcher : '{IO} () ->{IO} Result - tests : ∀ _. _ ->{IO} [Result] - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - catcher : '{IO} () ->{IO} Result - tests : ∀ _. _ ->{IO} [Result] - -.> io.test tests - - New test results: - - ◉ tests caught - ◉ tests caught - ◉ tests got the right answer - - ✅ 3 test(s) passing - - Tip: Use view tests to view the source of a test. - -``` diff --git a/unison-src/transcripts/fix2053.md b/unison-src/transcripts/fix2053.md deleted file mode 100644 index 120bbed317..0000000000 --- a/unison-src/transcripts/fix2053.md +++ /dev/null @@ -1,7 +0,0 @@ -```ucm:hide -.> builtins.mergeio -``` - -```ucm -.> display List.map -``` diff --git a/unison-src/transcripts/fix2053.output.md b/unison-src/transcripts/fix2053.output.md deleted file mode 100644 index d1cf4ec78e..0000000000 --- a/unison-src/transcripts/fix2053.output.md +++ /dev/null @@ -1,12 +0,0 @@ -```ucm -.> display List.map - - f a -> - let - use Nat + - go i as acc = match List.at i as with - None -> acc - Some a -> go (i + 1) as (acc :+ f a) - go 0 a [] - -``` diff --git a/unison-src/transcripts/fix2156.md b/unison-src/transcripts/fix2156.md deleted file mode 100644 index 2bc440b149..0000000000 --- a/unison-src/transcripts/fix2156.md +++ /dev/null @@ -1,14 +0,0 @@ - -Tests for a case where bad eta reduction was causing erroneous watch -output/caching. - -```ucm:hide -.> builtins.merge -``` - -```unison -sqr : Nat -> Nat -sqr n = n * n - -> sqr -``` diff --git a/unison-src/transcripts/fix2156.output.md b/unison-src/transcripts/fix2156.output.md deleted file mode 100644 index c4eed7557a..0000000000 --- a/unison-src/transcripts/fix2156.output.md +++ /dev/null @@ -1,31 +0,0 @@ - -Tests for a case where bad eta reduction was causing erroneous watch -output/caching. - -```unison -sqr : Nat -> Nat -sqr n = n * n - -> sqr -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - sqr : Nat -> Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 4 | > sqr - ⧩ - n -> n Nat.* n - -``` diff --git a/unison-src/transcripts/fix2167.md b/unison-src/transcripts/fix2167.md deleted file mode 100644 index 4e65ddb6f6..0000000000 --- a/unison-src/transcripts/fix2167.md +++ /dev/null @@ -1,28 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -This is just a simple transcript to regression check an ability -inference/checking issue. - -```unison -structural ability R t where - die : () -> x - near.impl : Nat -> Either () [Nat] - -R.near n = match near.impl n with - Left e -> die () - Right a -> a - -R.near1 region loc = match R.near 42 with - [loc] -> loc - ls -> R.die () -``` - -The issue was that abilities with parameters like this were sometimes -causing failures like this because the variable in the parameter would -escape to a scope where it no longer made sense. Then solving would -fail because the type was invalid. - -The fix was to avoid dropping certain existential variables out of -scope. diff --git a/unison-src/transcripts/fix2167.output.md b/unison-src/transcripts/fix2167.output.md deleted file mode 100644 index 3d8c3251f6..0000000000 --- a/unison-src/transcripts/fix2167.output.md +++ /dev/null @@ -1,39 +0,0 @@ -This is just a simple transcript to regression check an ability -inference/checking issue. - -```unison -structural ability R t where - die : () -> x - near.impl : Nat -> Either () [Nat] - -R.near n = match near.impl n with - Left e -> die () - Right a -> a - -R.near1 region loc = match R.near 42 with - [loc] -> loc - ls -> R.die () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability R t - R.near : Nat ->{R t} [Nat] - R.near1 : region -> loc ->{R t} Nat - -``` -The issue was that abilities with parameters like this were sometimes -causing failures like this because the variable in the parameter would -escape to a scope where it no longer made sense. Then solving would -fail because the type was invalid. - -The fix was to avoid dropping certain existential variables out of -scope. diff --git a/unison-src/transcripts/fix2187.md b/unison-src/transcripts/fix2187.md deleted file mode 100644 index f519c30de4..0000000000 --- a/unison-src/transcripts/fix2187.md +++ /dev/null @@ -1,19 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison - -lexicalScopeEx: [Text] -lexicalScopeEx = - parent = "outer" - inner1 = let - child1 = "child1" - inner2 : [Text] - inner2 = let - child2 = "child2" - [parent, child1, child2] - inner2 - inner1 - -``` diff --git a/unison-src/transcripts/fix2187.output.md b/unison-src/transcripts/fix2187.output.md deleted file mode 100644 index 8f499449e2..0000000000 --- a/unison-src/transcripts/fix2187.output.md +++ /dev/null @@ -1,28 +0,0 @@ -```unison -lexicalScopeEx: [Text] -lexicalScopeEx = - parent = "outer" - inner1 = let - child1 = "child1" - inner2 : [Text] - inner2 = let - child2 = "child2" - [parent, child1, child2] - inner2 - inner1 - -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - lexicalScopeEx : [Text] - -``` diff --git a/unison-src/transcripts/fix2231.md b/unison-src/transcripts/fix2231.md deleted file mode 100644 index 0b1ed16419..0000000000 --- a/unison-src/transcripts/fix2231.md +++ /dev/null @@ -1,29 +0,0 @@ -This transcript contains some cases that were problematic with the new -type checker. They were likely not discovered earlier because they -involve combining types inferred with the older strategy with the new -inference algorithm. Some code can be given multiple possible types, -and while they are all valid and some may be equivalently general, -the choices may not work equally well with the type checking -strategies. - -```ucm:hide -.> builtins.merge -``` - -```unison -(<<) : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c -(<<) f g x = f (g x) - -f = atan << tan - -foldl : (b ->{e} a ->{e} b) -> b -> [a] ->{e} b -foldl f a = cases - [] -> a - x +: xs -> foldl f (f a x) xs - -txt = foldl (Text.++) "" ["a", "b", "c"] -``` - -```ucm -.> add -``` diff --git a/unison-src/transcripts/fix2231.output.md b/unison-src/transcripts/fix2231.output.md deleted file mode 100644 index 2ff24e5bcf..0000000000 --- a/unison-src/transcripts/fix2231.output.md +++ /dev/null @@ -1,49 +0,0 @@ -This transcript contains some cases that were problematic with the new -type checker. They were likely not discovered earlier because they -involve combining types inferred with the older strategy with the new -inference algorithm. Some code can be given multiple possible types, -and while they are all valid and some may be equivalently general, -the choices may not work equally well with the type checking -strategies. - -```unison -(<<) : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c -(<<) f g x = f (g x) - -f = atan << tan - -foldl : (b ->{e} a ->{e} b) -> b -> [a] ->{e} b -foldl f a = cases - [] -> a - x +: xs -> foldl f (f a x) xs - -txt = foldl (Text.++) "" ["a", "b", "c"] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - << : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c - f : Float -> Float - foldl : (b ->{e} a ->{e} b) -> b -> [a] ->{e} b - txt : Text - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - << : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c - f : Float -> Float - foldl : (b ->{e} a ->{e} b) -> b -> [a] ->{e} b - txt : Text - -``` diff --git a/unison-src/transcripts/fix2238.md b/unison-src/transcripts/fix2238.md deleted file mode 100644 index 3562096397..0000000000 --- a/unison-src/transcripts/fix2238.md +++ /dev/null @@ -1,18 +0,0 @@ - -```ucm:hide -.> builtins.mergeio -``` - -This should not typecheck - the inline `@eval` expression uses abilities. - -```unison:error -structural ability Abort where abort : x - -ex = {{ @eval{abort} }} -``` - -This file should also not typecheck - it has a triple backticks block that uses abilities. - -```ucm:error -.> load unison-src/transcripts/fix2238.u -``` diff --git a/unison-src/transcripts/fix2238.output.md b/unison-src/transcripts/fix2238.output.md deleted file mode 100644 index 31a4aca9f0..0000000000 --- a/unison-src/transcripts/fix2238.output.md +++ /dev/null @@ -1,32 +0,0 @@ - -This should not typecheck - the inline `@eval` expression uses abilities. - -```unison -structural ability Abort where abort : x - -ex = {{ @eval{abort} }} -``` - -```ucm - - Loading changes detected in scratch.u. - - The expression in red needs the {Abort} ability, but this location does not have access to any abilities. - - 3 | ex = {{ @eval{abort} }} - - -``` -This file should also not typecheck - it has a triple backticks block that uses abilities. - -```ucm -.> load unison-src/transcripts/fix2238.u - - Loading changes detected in unison-src/transcripts/fix2238.u. - - The expression in red needs the {Abort} ability, but this location does not have access to any abilities. - - 7 | abort + 1 - - -``` diff --git a/unison-src/transcripts/fix2238.u b/unison-src/transcripts/fix2238.u deleted file mode 100644 index 19e81357ee..0000000000 --- a/unison-src/transcripts/fix2238.u +++ /dev/null @@ -1,9 +0,0 @@ - -structural ability Abort where abort : x - -ex = {{ - -``` -abort + 1 -``` -}} diff --git a/unison-src/transcripts/fix2244.md b/unison-src/transcripts/fix2244.md deleted file mode 100644 index e270dc5f27..0000000000 --- a/unison-src/transcripts/fix2244.md +++ /dev/null @@ -1,13 +0,0 @@ -```ucm:hide -.> builtins.mergeio -``` - -Ensure closing token is emitted by closing brace in doc eval block. - -```ucm -.> load ./unison-src/transcripts/fix2244.u -``` - -```ucm:hide -.> add -``` diff --git a/unison-src/transcripts/fix2244.output.md b/unison-src/transcripts/fix2244.output.md deleted file mode 100644 index 44b65347d9..0000000000 --- a/unison-src/transcripts/fix2244.output.md +++ /dev/null @@ -1,17 +0,0 @@ -Ensure closing token is emitted by closing brace in doc eval block. - -```ucm -.> load ./unison-src/transcripts/fix2244.u - - Loading changes detected in - ./unison-src/transcripts/fix2244.u. - - I found and typechecked these definitions in - ./unison-src/transcripts/fix2244.u. If you do an `add` or - `update`, here's how your codebase would change: - - ⍟ These new definitions are ok to `add`: - - x : Doc2 - -``` diff --git a/unison-src/transcripts/fix2244.u b/unison-src/transcripts/fix2244.u deleted file mode 100644 index 2d947ceb19..0000000000 --- a/unison-src/transcripts/fix2244.u +++ /dev/null @@ -1,11 +0,0 @@ -x = {{ - -``` -let - x = 1 - y = 2 - x + y -``` - -}} - diff --git a/unison-src/transcripts/fix2254.md b/unison-src/transcripts/fix2254.md deleted file mode 100644 index 3b6dd15e6c..0000000000 --- a/unison-src/transcripts/fix2254.md +++ /dev/null @@ -1,96 +0,0 @@ - -```ucm:hide -.a> builtins.merge -``` - -This transcript checks that updates to data types propagate successfully to dependent types and dependent terms that do pattern matching. First let's create some types and terms: - -```unison:hide -unique type A a b c d - = A a - | B b - | C c - | D d - -structural type NeedsA a b = NeedsA (A a b Nat Nat) - | Zoink Text - -f : A Nat Nat Nat Nat -> Nat -f = cases - A n -> n - _ -> 42 - -f2 a = - n = f a - n + 1 - -f3 : NeedsA Nat Nat -> Nat -f3 = cases - NeedsA a -> f a + 20 - _ -> 0 - -g : A Nat Nat Nat Nat -> Nat -g = cases - D n -> n - _ -> 43 -``` - -We'll make our edits in a fork of the `a` namespace: - -```ucm -.a> add -.> fork a a2 -``` - -First let's edit the `A` type, adding another constructor `E`. Note that the functions written against the old type have a wildcard in their pattern match, so they should work fine after the update. - -```unison:hide -unique type A a b c d - = A a - | B b - | C c - | D d - | E a d -``` - -Let's do the update now, and verify that the definitions all look good and there's nothing `todo`: - -```ucm -.a2> update.old -.a2> view A NeedsA f f2 f3 g -.a2> todo -``` - -```ucm:hide -.a2> builtins.merge -``` - -## Record updates - -Here's a test of updating a record: - -```unison -structural type Rec = { uno : Nat, dos : Nat } - -combine r = uno r + dos r -``` - -```ucm:hide -.a3> builtins.merge -``` - -```ucm -.a3> add -``` - -```unison -structural type Rec = { uno : Nat, dos : Nat, tres : Text } -``` - -And checking that after updating this record, there's nothing `todo`: - -```ucm -.> fork a3 a4 -.a4> update.old -.a4> todo -``` diff --git a/unison-src/transcripts/fix2254.output.md b/unison-src/transcripts/fix2254.output.md deleted file mode 100644 index 61af269b2c..0000000000 --- a/unison-src/transcripts/fix2254.output.md +++ /dev/null @@ -1,220 +0,0 @@ - -This transcript checks that updates to data types propagate successfully to dependent types and dependent terms that do pattern matching. First let's create some types and terms: - -```unison -unique type A a b c d - = A a - | B b - | C c - | D d - -structural type NeedsA a b = NeedsA (A a b Nat Nat) - | Zoink Text - -f : A Nat Nat Nat Nat -> Nat -f = cases - A n -> n - _ -> 42 - -f2 a = - n = f a - n + 1 - -f3 : NeedsA Nat Nat -> Nat -f3 = cases - NeedsA a -> f a + 20 - _ -> 0 - -g : A Nat Nat Nat Nat -> Nat -g = cases - D n -> n - _ -> 43 -``` - -We'll make our edits in a fork of the `a` namespace: - -```ucm -.a> add - - ⍟ I've added these definitions: - - type A a b c d - structural type NeedsA a b - f : A Nat Nat Nat Nat -> Nat - f2 : A Nat Nat Nat Nat -> Nat - f3 : NeedsA Nat Nat -> Nat - g : A Nat Nat Nat Nat -> Nat - -.> fork a a2 - - Done. - -``` -First let's edit the `A` type, adding another constructor `E`. Note that the functions written against the old type have a wildcard in their pattern match, so they should work fine after the update. - -```unison -unique type A a b c d - = A a - | B b - | C c - | D d - | E a d -``` - -Let's do the update now, and verify that the definitions all look good and there's nothing `todo`: - -```ucm -.a2> update.old - - ⍟ I've updated these names to your new definition: - - type A a b c d - -.a2> view A NeedsA f f2 f3 g - - type A a b c d - = B b - | D d - | E a d - | C c - | A a - - structural type NeedsA a b - = Zoink Text - | NeedsA (A a b Nat Nat) - - f : A Nat Nat Nat Nat -> Nat - f = cases - A n -> n - _ -> 42 - - f2 : A Nat Nat Nat Nat -> Nat - f2 a = - use Nat + - n = f a - n + 1 - - f3 : NeedsA Nat Nat -> Nat - f3 = cases - NeedsA a -> f a Nat.+ 20 - _ -> 0 - - g : A Nat Nat Nat Nat -> Nat - g = cases - D n -> n - _ -> 43 - -.a2> todo - - ✅ - - No conflicts or edits in progress. - -``` -## Record updates - -Here's a test of updating a record: - -```unison -structural type Rec = { uno : Nat, dos : Nat } - -combine r = uno r + dos r -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type Rec - Rec.dos : Rec -> Nat - Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.dos.set : Nat -> Rec -> Rec - Rec.uno : Rec -> Nat - Rec.uno.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.uno.set : Nat -> Rec -> Rec - combine : Rec -> Nat - -``` -```ucm -.a3> add - - ⍟ I've added these definitions: - - structural type Rec - Rec.dos : Rec -> Nat - Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.dos.set : Nat -> Rec -> Rec - Rec.uno : Rec -> Nat - Rec.uno.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.uno.set : Nat -> Rec -> Rec - combine : Rec -> Nat - -``` -```unison -structural type Rec = { uno : Nat, dos : Nat, tres : Text } -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - Rec.tres : Rec -> Text - Rec.tres.modify : (Text ->{g} Text) -> Rec ->{g} Rec - Rec.tres.set : Text -> Rec -> Rec - - ⍟ These names already exist. You can `update` them to your - new definition: - - structural type Rec - Rec.dos : Rec -> Nat - Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.dos.set : Nat -> Rec -> Rec - Rec.uno : Rec -> Nat - Rec.uno.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.uno.set : Nat -> Rec -> Rec - -``` -And checking that after updating this record, there's nothing `todo`: - -```ucm -.> fork a3 a4 - - Done. - -.a4> update.old - - ⍟ I've added these definitions: - - Rec.tres : Rec -> Text - Rec.tres.modify : (Text ->{g} Text) -> Rec ->{g} Rec - Rec.tres.set : Text -> Rec -> Rec - - ⍟ I've updated these names to your new definition: - - structural type Rec - Rec.dos : Rec -> Nat - Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.dos.set : Nat -> Rec -> Rec - Rec.uno : Rec -> Nat - Rec.uno.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.uno.set : Nat -> Rec -> Rec - -.a4> todo - - ✅ - - No conflicts or edits in progress. - -``` diff --git a/unison-src/transcripts/fix2268.md b/unison-src/transcripts/fix2268.md deleted file mode 100644 index 504e2da734..0000000000 --- a/unison-src/transcripts/fix2268.md +++ /dev/null @@ -1,20 +0,0 @@ -Tests for a TDNR case that wasn't working. The code wasn't 'relaxing' -inferred types that didn't contain arrows, so effects that just yield -a value weren't getting disambiguated. - -```ucm:hide -.> builtins.merge -``` - -```unison -unique ability A where - a : Nat - -unique ability B where - a : Char - -test : () -> Nat -test _ = - x = a - toNat x -``` diff --git a/unison-src/transcripts/fix2268.output.md b/unison-src/transcripts/fix2268.output.md deleted file mode 100644 index bfb65920fd..0000000000 --- a/unison-src/transcripts/fix2268.output.md +++ /dev/null @@ -1,32 +0,0 @@ -Tests for a TDNR case that wasn't working. The code wasn't 'relaxing' -inferred types that didn't contain arrows, so effects that just yield -a value weren't getting disambiguated. - -```unison -unique ability A where - a : Nat - -unique ability B where - a : Char - -test : () -> Nat -test _ = - x = a - toNat x -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ability A - ability B - test : '{B} Nat - -``` diff --git a/unison-src/transcripts/fix2334.md b/unison-src/transcripts/fix2334.md deleted file mode 100644 index 0bc9a2d7d3..0000000000 --- a/unison-src/transcripts/fix2334.md +++ /dev/null @@ -1,20 +0,0 @@ - -Tests an issue where pattern matching matrices involving built-in -types was discarding default cases in some branches. - -```ucm:hide -.> builtins.merge -``` - -```unison -f = cases - 0, 0 -> 0 - _, 1 -> 2 - 1, _ -> 3 - _, _ -> 1 - -> f 0 0 -> f 1 0 -> f 0 1 -> f 1 1 -``` diff --git a/unison-src/transcripts/fix2334.output.md b/unison-src/transcripts/fix2334.output.md deleted file mode 100644 index 669017cd88..0000000000 --- a/unison-src/transcripts/fix2334.output.md +++ /dev/null @@ -1,49 +0,0 @@ - -Tests an issue where pattern matching matrices involving built-in -types was discarding default cases in some branches. - -```unison -f = cases - 0, 0 -> 0 - _, 1 -> 2 - 1, _ -> 3 - _, _ -> 1 - -> f 0 0 -> f 1 0 -> f 0 1 -> f 1 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - f : Nat -> Nat -> Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 7 | > f 0 0 - ⧩ - 0 - - 8 | > f 1 0 - ⧩ - 3 - - 9 | > f 0 1 - ⧩ - 2 - - 10 | > f 1 1 - ⧩ - 2 - -``` diff --git a/unison-src/transcripts/fix2344.md b/unison-src/transcripts/fix2344.md deleted file mode 100644 index 6dd1e0ca21..0000000000 --- a/unison-src/transcripts/fix2344.md +++ /dev/null @@ -1,22 +0,0 @@ - -Checks a corner case with type checking involving destructuring binds. - -The binds were causing some sequences of lets to be unnecessarily -recursive. - -```ucm:hide -.> builtins.merge -``` - -```unison -unique ability Nate where - nate: (Boolean, Nat) - antiNate: () - - -sneezy: (Nat -> {d} a) -> '{Nate,d} a -sneezy dee _ = - (_,_) = nate - antiNate - dee 1 -``` diff --git a/unison-src/transcripts/fix2344.output.md b/unison-src/transcripts/fix2344.output.md deleted file mode 100644 index 6d0ae41c4f..0000000000 --- a/unison-src/transcripts/fix2344.output.md +++ /dev/null @@ -1,33 +0,0 @@ - -Checks a corner case with type checking involving destructuring binds. - -The binds were causing some sequences of lets to be unnecessarily -recursive. - -```unison -unique ability Nate where - nate: (Boolean, Nat) - antiNate: () - - -sneezy: (Nat -> {d} a) -> '{Nate,d} a -sneezy dee _ = - (_,_) = nate - antiNate - dee 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ability Nate - sneezy : (Nat ->{d} a) -> '{d, Nate} a - -``` diff --git a/unison-src/transcripts/fix2350.md b/unison-src/transcripts/fix2350.md deleted file mode 100644 index 667b8a419e..0000000000 --- a/unison-src/transcripts/fix2350.md +++ /dev/null @@ -1,26 +0,0 @@ - -This tests an issue where ability variables were being defaulted over -eagerly. In general, we want to avoid collecting up variables from the -use of definitions with types like: - - T ->{e} U - -Since this type works for every `e`, it is, 'pure;' and we might as -well have `e = {}`, since `{}` is a subrow of every other row. -However, if `e` isn't just a quantified variable, but one involved in -ongoing inference, it's undesirable to default it. Previously there -was a check to see if `e` occurred in the context. However, the wanted -abilities being collected aren't in the context, so types like: - - T ->{S e} U ->{e} V - -were a corner case. We would add `S e` to the wanted abilities, then -not realize that `e` shouldn't be defaulted. - -```unison -unique ability Storage d g where - save.impl : a ->{Storage d g} ('{g} (d a)) - -save : a ->{Storage d g, g} (d a) -save a = !(save.impl a) -``` diff --git a/unison-src/transcripts/fix2350.output.md b/unison-src/transcripts/fix2350.output.md deleted file mode 100644 index d8f6bf43b1..0000000000 --- a/unison-src/transcripts/fix2350.output.md +++ /dev/null @@ -1,41 +0,0 @@ - -This tests an issue where ability variables were being defaulted over -eagerly. In general, we want to avoid collecting up variables from the -use of definitions with types like: - - T ->{e} U - -Since this type works for every `e`, it is, 'pure;' and we might as -well have `e = {}`, since `{}` is a subrow of every other row. -However, if `e` isn't just a quantified variable, but one involved in -ongoing inference, it's undesirable to default it. Previously there -was a check to see if `e` occurred in the context. However, the wanted -abilities being collected aren't in the context, so types like: - - T ->{S e} U ->{e} V - -were a corner case. We would add `S e` to the wanted abilities, then -not realize that `e` shouldn't be defaulted. - -```unison -unique ability Storage d g where - save.impl : a ->{Storage d g} ('{g} (d a)) - -save : a ->{Storage d g, g} (d a) -save a = !(save.impl a) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ability Storage d g - save : a ->{g, Storage d g} d a - -``` diff --git a/unison-src/transcripts/fix2353.md b/unison-src/transcripts/fix2353.md deleted file mode 100644 index 50d0827a6d..0000000000 --- a/unison-src/transcripts/fix2353.md +++ /dev/null @@ -1,16 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison -use builtin Scope -unique ability Async t g where async : {g} Nat -unique ability Exception where raise : Nat -> x - -pure.run : a -> (forall t . '{Async t g} a) ->{Exception, g} a -pure.run a0 a = - a' : forall s . '{Scope s, Exception, g} a - a' = 'a0 -- typechecks - -- make sure this builtin can still be referenced - Scope.run a' -``` diff --git a/unison-src/transcripts/fix2353.output.md b/unison-src/transcripts/fix2353.output.md deleted file mode 100644 index 74c9da016f..0000000000 --- a/unison-src/transcripts/fix2353.output.md +++ /dev/null @@ -1,28 +0,0 @@ -```unison -use builtin Scope -unique ability Async t g where async : {g} Nat -unique ability Exception where raise : Nat -> x - -pure.run : a -> (forall t . '{Async t g} a) ->{Exception, g} a -pure.run a0 a = - a' : forall s . '{Scope s, Exception, g} a - a' = 'a0 -- typechecks - -- make sure this builtin can still be referenced - Scope.run a' -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ability Async t g - ability Exception - pure.run : a -> (∀ t. '{Async t g} a) ->{g, Exception} a - -``` diff --git a/unison-src/transcripts/fix2354.md b/unison-src/transcripts/fix2354.md deleted file mode 100644 index 7346e368cf..0000000000 --- a/unison-src/transcripts/fix2354.md +++ /dev/null @@ -1,14 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -Tests that delaying an un-annotated higher-rank type gives a normal -type error, rather than an internal compiler error. - -```unison:error -f : (forall a . a -> a) -> Nat -f id = id 0 - -x = 'f -``` diff --git a/unison-src/transcripts/fix2354.output.md b/unison-src/transcripts/fix2354.output.md deleted file mode 100644 index 7fcfce26a9..0000000000 --- a/unison-src/transcripts/fix2354.output.md +++ /dev/null @@ -1,29 +0,0 @@ - -Tests that delaying an un-annotated higher-rank type gives a normal -type error, rather than an internal compiler error. - -```unison -f : (forall a . a -> a) -> Nat -f id = id 0 - -x = 'f -``` - -```ucm - - Loading changes detected in scratch.u. - - I found a value of type: (a1 ->{𝕖} a1) ->{𝕖} Nat - where I expected to find: (a -> 𝕣1) -> 𝕣 - - 1 | f : (forall a . a -> a) -> Nat - 2 | f id = id 0 - 3 | - 4 | x = 'f - - from right here: - - 1 | f : (forall a . a -> a) -> Nat - - -``` diff --git a/unison-src/transcripts/fix2355.md b/unison-src/transcripts/fix2355.md deleted file mode 100644 index 25f4840b31..0000000000 --- a/unison-src/transcripts/fix2355.md +++ /dev/null @@ -1,25 +0,0 @@ - -Tests for a loop that was previously occurring in the type checker. - -```ucm:hide -.> builtins.merge -``` - -```unison:error -structural ability A t g where - fork : '{g, A t g} a -> t a - await : t a -> a - empty! : t a - put : a -> t a -> () - -example : '{A t {}} Nat -example = 'let - r = A.empty! - go u = - t = A.fork '(go (u + 1)) - A.await t - - go 0 - t2 = A.fork '(A.put 10 r) - A.await r -``` diff --git a/unison-src/transcripts/fix2355.output.md b/unison-src/transcripts/fix2355.output.md deleted file mode 100644 index ce2f06798e..0000000000 --- a/unison-src/transcripts/fix2355.output.md +++ /dev/null @@ -1,42 +0,0 @@ - -Tests for a loop that was previously occurring in the type checker. - -```unison -structural ability A t g where - fork : '{g, A t g} a -> t a - await : t a -> a - empty! : t a - put : a -> t a -> () - -example : '{A t {}} Nat -example = 'let - r = A.empty! - go u = - t = A.fork '(go (u + 1)) - A.await t - - go 0 - t2 = A.fork '(A.put 10 r) - A.await r -``` - -```ucm - - Loading changes detected in scratch.u. - - I tried to infer a cyclic ability. - - The expression in red was inferred to require the ability: - - {A t25 {𝕖39, 𝕖18}} - - where `𝕖18` is its overall abilities. - - I need a type signature to help figure this out. - - 10 | go u = - 11 | t = A.fork '(go (u + 1)) - 12 | A.await t - - -``` diff --git a/unison-src/transcripts/fix2378.md b/unison-src/transcripts/fix2378.md deleted file mode 100644 index d4358c26e9..0000000000 --- a/unison-src/transcripts/fix2378.md +++ /dev/null @@ -1,44 +0,0 @@ - -Tests for an ability failure that was caused by order dependence of -checking wanted vs. provided abilities. It was necessary to re-check -rows until a fixed point is reached. - -```ucm:hide -.> builtins.merge -``` - -```unison -unique ability C c where - new : c a - receive : c a -> a - send : a -> c a -> () - -unique ability A t g where - fork : '{A t g, g, Exception} a -> t a - await : t a -> a - -unique ability Ex where raise : () -> x - -Ex.catch : '{Ex, g} a ->{g} Either () a -Ex.catch _ = todo "Exception.catch" - -C.pure.run : (forall c . '{C c, g} r) ->{Ex, g} r -C.pure.run _ = todo "C.pure.run" - -A.pure.run : (forall t . '{A t g, g} a) ->{Ex,g} a -A.pure.run _ = todo "A.pure.run" - -ex : '{C c, A t {C c}} Nat -ex _ = - c = C.new - x = A.fork 'let - a = receive c - a + 10 - y = A.fork 'let - send 0 c - () - A.await x - -x : '{} (Either () Nat) -x _ = Ex.catch '(C.pure.run '(A.pure.run ex)) -``` diff --git a/unison-src/transcripts/fix2378.output.md b/unison-src/transcripts/fix2378.output.md deleted file mode 100644 index 5acef2316d..0000000000 --- a/unison-src/transcripts/fix2378.output.md +++ /dev/null @@ -1,61 +0,0 @@ - -Tests for an ability failure that was caused by order dependence of -checking wanted vs. provided abilities. It was necessary to re-check -rows until a fixed point is reached. - -```unison -unique ability C c where - new : c a - receive : c a -> a - send : a -> c a -> () - -unique ability A t g where - fork : '{A t g, g, Exception} a -> t a - await : t a -> a - -unique ability Ex where raise : () -> x - -Ex.catch : '{Ex, g} a ->{g} Either () a -Ex.catch _ = todo "Exception.catch" - -C.pure.run : (forall c . '{C c, g} r) ->{Ex, g} r -C.pure.run _ = todo "C.pure.run" - -A.pure.run : (forall t . '{A t g, g} a) ->{Ex,g} a -A.pure.run _ = todo "A.pure.run" - -ex : '{C c, A t {C c}} Nat -ex _ = - c = C.new - x = A.fork 'let - a = receive c - a + 10 - y = A.fork 'let - send 0 c - () - A.await x - -x : '{} (Either () Nat) -x _ = Ex.catch '(C.pure.run '(A.pure.run ex)) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ability A t g - ability C c - ability Ex - A.pure.run : (∀ t. '{g, A t g} a) ->{g, Ex} a - C.pure.run : (∀ c. '{g, C c} r) ->{g, Ex} r - Ex.catch : '{g, Ex} a ->{g} Either () a - ex : '{C c, A t {C c}} Nat - x : 'Either () Nat - -``` diff --git a/unison-src/transcripts/fix2423.md b/unison-src/transcripts/fix2423.md deleted file mode 100644 index 4f5d073c0a..0000000000 --- a/unison-src/transcripts/fix2423.md +++ /dev/null @@ -1,31 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison -structural ability Split where - skip! : x - both : a -> a -> a - -Split.append : '{Split, g} a -> '{Split, g} a -> '{Split, g} a -Split.append s1 s2 _ = force (both s1 s2) - -force a = !a - -Split.zipSame : '{Split, g} a -> '{Split, g} b -> '{Split, g} (a, b) -Split.zipSame sa sb _ = - go : '{Split,g2} y -> Request {Split} x ->{Split,g2} (x,y) - go sb = cases - { a } -> (a, !sb) - { skip! -> _ } -> skip! - { both la ra -> k } -> - handle !sb with cases - { _ } -> skip! - { skip! -> k } -> skip! - { both lb rb -> k2 } -> - force (Split.append - (zipSame '(k la) '(k2 lb)) - (zipSame '(k ra) '(k2 rb))) - - handle !sa with go sb -``` diff --git a/unison-src/transcripts/fix2423.output.md b/unison-src/transcripts/fix2423.output.md deleted file mode 100644 index 6deb34d734..0000000000 --- a/unison-src/transcripts/fix2423.output.md +++ /dev/null @@ -1,48 +0,0 @@ -```unison -structural ability Split where - skip! : x - both : a -> a -> a - -Split.append : '{Split, g} a -> '{Split, g} a -> '{Split, g} a -Split.append s1 s2 _ = force (both s1 s2) - -force a = !a - -Split.zipSame : '{Split, g} a -> '{Split, g} b -> '{Split, g} (a, b) -Split.zipSame sa sb _ = - go : '{Split,g2} y -> Request {Split} x ->{Split,g2} (x,y) - go sb = cases - { a } -> (a, !sb) - { skip! -> _ } -> skip! - { both la ra -> k } -> - handle !sb with cases - { _ } -> skip! - { skip! -> k } -> skip! - { both lb rb -> k2 } -> - force (Split.append - (zipSame '(k la) '(k2 lb)) - (zipSame '(k ra) '(k2 rb))) - - handle !sa with go sb -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability Split - Split.append : '{g, Split} a - -> '{g, Split} a - -> '{g, Split} a - Split.zipSame : '{g, Split} a - -> '{g, Split} b - -> '{g, Split} (a, b) - force : '{g} o ->{g} o - -``` diff --git a/unison-src/transcripts/fix2474.md b/unison-src/transcripts/fix2474.md deleted file mode 100644 index a718719bd9..0000000000 --- a/unison-src/transcripts/fix2474.md +++ /dev/null @@ -1,35 +0,0 @@ - -Tests an issue with a lack of generality of handlers. - -In general, a set of cases: - - { e ... -> k } - -should be typed in the following way: - - 1. The scrutinee has type `Request {E, g} r -> s` where `E` is all - the abilities being handled. `g` is a slack variable, because all - abilities that are used in the handled expression pass through - the handler. Previously this was being inferred as merely - `Request {E} r -> s` - 2. The continuation variable `k` should have type `o ->{E, g} r`, - matching the above types (`o` is the result type of `e`). - Previously this was being checked as `o ->{E0} r`, where `E0` is - the ability that contains `e`. - -```ucm -.> builtins.merge -``` - -```unison -structural ability Stream a where - emit : a -> () - -Stream.uncons : '{Stream a, g} r ->{g} Either r (a, '{Stream a, g} r) -Stream.uncons s = - go : Request {Stream a,g} r -> Either r (a, '{Stream a,g} r) - go = cases - { r } -> Left r - { Stream.emit a -> tl } -> Right (a, tl : '{Stream a,g} r) - handle !s with go -``` diff --git a/unison-src/transcripts/fix2474.output.md b/unison-src/transcripts/fix2474.output.md deleted file mode 100644 index 7f6472f094..0000000000 --- a/unison-src/transcripts/fix2474.output.md +++ /dev/null @@ -1,53 +0,0 @@ - -Tests an issue with a lack of generality of handlers. - -In general, a set of cases: - - { e ... -> k } - -should be typed in the following way: - - 1. The scrutinee has type `Request {E, g} r -> s` where `E` is all - the abilities being handled. `g` is a slack variable, because all - abilities that are used in the handled expression pass through - the handler. Previously this was being inferred as merely - `Request {E} r -> s` - 2. The continuation variable `k` should have type `o ->{E, g} r`, - matching the above types (`o` is the result type of `e`). - Previously this was being checked as `o ->{E0} r`, where `E0` is - the ability that contains `e`. - -```ucm -.> builtins.merge - - Done. - -``` -```unison -structural ability Stream a where - emit : a -> () - -Stream.uncons : '{Stream a, g} r ->{g} Either r (a, '{Stream a, g} r) -Stream.uncons s = - go : Request {Stream a,g} r -> Either r (a, '{Stream a,g} r) - go = cases - { r } -> Left r - { Stream.emit a -> tl } -> Right (a, tl : '{Stream a,g} r) - handle !s with go -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability Stream a - Stream.uncons : '{g, Stream a} r - ->{g} Either r (a, '{g, Stream a} r) - -``` diff --git a/unison-src/transcripts/fix2628.md b/unison-src/transcripts/fix2628.md deleted file mode 100644 index 5c3ec8df50..0000000000 --- a/unison-src/transcripts/fix2628.md +++ /dev/null @@ -1,15 +0,0 @@ -```ucm:hide -.> alias.type ##Nat .base.Nat -``` - -```unison:hide -unique type foo.bar.baz.MyRecord = { - value : Nat -} -``` - -```ucm -.> add - -.> find : Nat -> MyRecord -``` diff --git a/unison-src/transcripts/fix2628.output.md b/unison-src/transcripts/fix2628.output.md deleted file mode 100644 index 64b45ed29b..0000000000 --- a/unison-src/transcripts/fix2628.output.md +++ /dev/null @@ -1,26 +0,0 @@ -```unison -unique type foo.bar.baz.MyRecord = { - value : Nat -} -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - type foo.bar.baz.MyRecord - foo.bar.baz.MyRecord.value : MyRecord -> Nat - foo.bar.baz.MyRecord.value.modify : (Nat ->{g} Nat) - -> MyRecord - ->{g} MyRecord - foo.bar.baz.MyRecord.value.set : Nat - -> MyRecord - -> MyRecord - -.> find : Nat -> MyRecord - - 1. foo.bar.baz.MyRecord.MyRecord : Nat -> MyRecord - - -``` diff --git a/unison-src/transcripts/fix2663.md b/unison-src/transcripts/fix2663.md deleted file mode 100644 index 6d2ccd7242..0000000000 --- a/unison-src/transcripts/fix2663.md +++ /dev/null @@ -1,24 +0,0 @@ - -Tests a variable capture problem. - -After pattern compilation, the match would end up: - - T p1 p3 p3 - -and z would end up referring to the first p3 rather than the second. - -```ucm:hide -.> builtins.merge -``` - -```unison -structural type Trip = T Nat Nat Nat - -bad : Nat -> (Nat, Nat) -bad x = match Some (Some x) with - Some (Some x) -> match T 3 4 5 with - T _ _ z -> (x, z) - _ -> (0,0) - -> bad 2 -``` diff --git a/unison-src/transcripts/fix2663.output.md b/unison-src/transcripts/fix2663.output.md deleted file mode 100644 index c250fb403e..0000000000 --- a/unison-src/transcripts/fix2663.output.md +++ /dev/null @@ -1,42 +0,0 @@ - -Tests a variable capture problem. - -After pattern compilation, the match would end up: - - T p1 p3 p3 - -and z would end up referring to the first p3 rather than the second. - -```unison -structural type Trip = T Nat Nat Nat - -bad : Nat -> (Nat, Nat) -bad x = match Some (Some x) with - Some (Some x) -> match T 3 4 5 with - T _ _ z -> (x, z) - _ -> (0,0) - -> bad 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type Trip - bad : Nat -> (Nat, Nat) - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 9 | > bad 2 - ⧩ - (2, 5) - -``` diff --git a/unison-src/transcripts/fix2693.md b/unison-src/transcripts/fix2693.md deleted file mode 100644 index 947e35b701..0000000000 --- a/unison-src/transcripts/fix2693.md +++ /dev/null @@ -1,28 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -```unison -loop : List Nat -> Nat -> List Nat -loop l = cases - 0 -> l - n -> loop (n +: l) (drop n 1) - -range : Nat -> List Nat -range = loop [] -``` - -```ucm -.> add -``` - -```unison -> range 2000 -``` - -Should be cached: - -```unison -> range 2000 -``` diff --git a/unison-src/transcripts/fix2693.output.md b/unison-src/transcripts/fix2693.output.md deleted file mode 100644 index 22a46bec21..0000000000 --- a/unison-src/transcripts/fix2693.output.md +++ /dev/null @@ -1,4076 +0,0 @@ - -```unison -loop : List Nat -> Nat -> List Nat -loop l = cases - 0 -> l - n -> loop (n +: l) (drop n 1) - -range : Nat -> List Nat -range = loop [] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - loop : [Nat] -> Nat -> [Nat] - range : Nat -> [Nat] - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - loop : [Nat] -> Nat -> [Nat] - range : Nat -> [Nat] - -``` -```unison -> range 2000 -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > range 2000 - ⧩ - [ 1 - , 2 - , 3 - , 4 - , 5 - , 6 - , 7 - , 8 - , 9 - , 10 - , 11 - , 12 - , 13 - , 14 - , 15 - , 16 - , 17 - , 18 - , 19 - , 20 - , 21 - , 22 - , 23 - , 24 - , 25 - , 26 - , 27 - , 28 - , 29 - , 30 - , 31 - , 32 - , 33 - , 34 - , 35 - , 36 - , 37 - , 38 - , 39 - , 40 - , 41 - , 42 - , 43 - , 44 - , 45 - , 46 - , 47 - , 48 - , 49 - , 50 - , 51 - , 52 - , 53 - , 54 - , 55 - , 56 - , 57 - , 58 - , 59 - , 60 - , 61 - , 62 - , 63 - , 64 - , 65 - , 66 - , 67 - , 68 - , 69 - , 70 - , 71 - , 72 - , 73 - , 74 - , 75 - , 76 - , 77 - , 78 - , 79 - , 80 - , 81 - , 82 - , 83 - , 84 - , 85 - , 86 - , 87 - , 88 - , 89 - , 90 - , 91 - , 92 - , 93 - , 94 - , 95 - , 96 - , 97 - , 98 - , 99 - , 100 - , 101 - , 102 - , 103 - , 104 - , 105 - , 106 - , 107 - , 108 - , 109 - , 110 - , 111 - , 112 - , 113 - , 114 - , 115 - , 116 - , 117 - , 118 - , 119 - , 120 - , 121 - , 122 - , 123 - , 124 - , 125 - , 126 - , 127 - , 128 - , 129 - , 130 - , 131 - , 132 - , 133 - , 134 - , 135 - , 136 - , 137 - , 138 - , 139 - , 140 - , 141 - , 142 - , 143 - , 144 - , 145 - , 146 - , 147 - , 148 - , 149 - , 150 - , 151 - , 152 - , 153 - , 154 - , 155 - , 156 - , 157 - , 158 - , 159 - , 160 - , 161 - , 162 - , 163 - , 164 - , 165 - , 166 - , 167 - , 168 - , 169 - , 170 - , 171 - , 172 - , 173 - , 174 - , 175 - , 176 - , 177 - , 178 - , 179 - , 180 - , 181 - , 182 - , 183 - , 184 - , 185 - , 186 - , 187 - , 188 - , 189 - , 190 - , 191 - , 192 - , 193 - , 194 - , 195 - , 196 - , 197 - , 198 - , 199 - , 200 - , 201 - , 202 - , 203 - , 204 - , 205 - , 206 - , 207 - , 208 - , 209 - , 210 - , 211 - , 212 - , 213 - , 214 - , 215 - , 216 - , 217 - , 218 - , 219 - , 220 - , 221 - , 222 - , 223 - , 224 - , 225 - , 226 - , 227 - , 228 - , 229 - , 230 - , 231 - , 232 - , 233 - , 234 - , 235 - , 236 - , 237 - , 238 - , 239 - , 240 - , 241 - , 242 - , 243 - , 244 - , 245 - , 246 - , 247 - , 248 - , 249 - , 250 - , 251 - , 252 - , 253 - , 254 - , 255 - , 256 - , 257 - , 258 - , 259 - , 260 - , 261 - , 262 - , 263 - , 264 - , 265 - , 266 - , 267 - , 268 - , 269 - , 270 - , 271 - , 272 - , 273 - , 274 - , 275 - , 276 - , 277 - , 278 - , 279 - , 280 - , 281 - , 282 - , 283 - , 284 - , 285 - , 286 - , 287 - , 288 - , 289 - , 290 - , 291 - , 292 - , 293 - , 294 - , 295 - , 296 - , 297 - , 298 - , 299 - , 300 - , 301 - , 302 - , 303 - , 304 - , 305 - , 306 - , 307 - , 308 - , 309 - , 310 - , 311 - , 312 - , 313 - , 314 - , 315 - , 316 - , 317 - , 318 - , 319 - , 320 - , 321 - , 322 - , 323 - , 324 - , 325 - , 326 - , 327 - , 328 - , 329 - , 330 - , 331 - , 332 - , 333 - , 334 - , 335 - , 336 - , 337 - , 338 - , 339 - , 340 - , 341 - , 342 - , 343 - , 344 - , 345 - , 346 - , 347 - , 348 - , 349 - , 350 - , 351 - , 352 - , 353 - , 354 - , 355 - , 356 - , 357 - , 358 - , 359 - , 360 - , 361 - , 362 - , 363 - , 364 - , 365 - , 366 - , 367 - , 368 - , 369 - , 370 - , 371 - , 372 - , 373 - , 374 - , 375 - , 376 - , 377 - , 378 - , 379 - , 380 - , 381 - , 382 - , 383 - , 384 - , 385 - , 386 - , 387 - , 388 - , 389 - , 390 - , 391 - , 392 - , 393 - , 394 - , 395 - , 396 - , 397 - , 398 - , 399 - , 400 - , 401 - , 402 - , 403 - , 404 - , 405 - , 406 - , 407 - , 408 - , 409 - , 410 - , 411 - , 412 - , 413 - , 414 - , 415 - , 416 - , 417 - , 418 - , 419 - , 420 - , 421 - , 422 - , 423 - , 424 - , 425 - , 426 - , 427 - , 428 - , 429 - , 430 - , 431 - , 432 - , 433 - , 434 - , 435 - , 436 - , 437 - , 438 - , 439 - , 440 - , 441 - , 442 - , 443 - , 444 - , 445 - , 446 - , 447 - , 448 - , 449 - , 450 - , 451 - , 452 - , 453 - , 454 - , 455 - , 456 - , 457 - , 458 - , 459 - , 460 - , 461 - , 462 - , 463 - , 464 - , 465 - , 466 - , 467 - , 468 - , 469 - , 470 - , 471 - , 472 - , 473 - , 474 - , 475 - , 476 - , 477 - , 478 - , 479 - , 480 - , 481 - , 482 - , 483 - , 484 - , 485 - , 486 - , 487 - , 488 - , 489 - , 490 - , 491 - , 492 - , 493 - , 494 - , 495 - , 496 - , 497 - , 498 - , 499 - , 500 - , 501 - , 502 - , 503 - , 504 - , 505 - , 506 - , 507 - , 508 - , 509 - , 510 - , 511 - , 512 - , 513 - , 514 - , 515 - , 516 - , 517 - , 518 - , 519 - , 520 - , 521 - , 522 - , 523 - , 524 - , 525 - , 526 - , 527 - , 528 - , 529 - , 530 - , 531 - , 532 - , 533 - , 534 - , 535 - , 536 - , 537 - , 538 - , 539 - , 540 - , 541 - , 542 - , 543 - , 544 - , 545 - , 546 - , 547 - , 548 - , 549 - , 550 - , 551 - , 552 - , 553 - , 554 - , 555 - , 556 - , 557 - , 558 - , 559 - , 560 - , 561 - , 562 - , 563 - , 564 - , 565 - , 566 - , 567 - , 568 - , 569 - , 570 - , 571 - , 572 - , 573 - , 574 - , 575 - , 576 - , 577 - , 578 - , 579 - , 580 - , 581 - , 582 - , 583 - , 584 - , 585 - , 586 - , 587 - , 588 - , 589 - , 590 - , 591 - , 592 - , 593 - , 594 - , 595 - , 596 - , 597 - , 598 - , 599 - , 600 - , 601 - , 602 - , 603 - , 604 - , 605 - , 606 - , 607 - , 608 - , 609 - , 610 - , 611 - , 612 - , 613 - , 614 - , 615 - , 616 - , 617 - , 618 - , 619 - , 620 - , 621 - , 622 - , 623 - , 624 - , 625 - , 626 - , 627 - , 628 - , 629 - , 630 - , 631 - , 632 - , 633 - , 634 - , 635 - , 636 - , 637 - , 638 - , 639 - , 640 - , 641 - , 642 - , 643 - , 644 - , 645 - , 646 - , 647 - , 648 - , 649 - , 650 - , 651 - , 652 - , 653 - , 654 - , 655 - , 656 - , 657 - , 658 - , 659 - , 660 - , 661 - , 662 - , 663 - , 664 - , 665 - , 666 - , 667 - , 668 - , 669 - , 670 - , 671 - , 672 - , 673 - , 674 - , 675 - , 676 - , 677 - , 678 - , 679 - , 680 - , 681 - , 682 - , 683 - , 684 - , 685 - , 686 - , 687 - , 688 - , 689 - , 690 - , 691 - , 692 - , 693 - , 694 - , 695 - , 696 - , 697 - , 698 - , 699 - , 700 - , 701 - , 702 - , 703 - , 704 - , 705 - , 706 - , 707 - , 708 - , 709 - , 710 - , 711 - , 712 - , 713 - , 714 - , 715 - , 716 - , 717 - , 718 - , 719 - , 720 - , 721 - , 722 - , 723 - , 724 - , 725 - , 726 - , 727 - , 728 - , 729 - , 730 - , 731 - , 732 - , 733 - , 734 - , 735 - , 736 - , 737 - , 738 - , 739 - , 740 - , 741 - , 742 - , 743 - , 744 - , 745 - , 746 - , 747 - , 748 - , 749 - , 750 - , 751 - , 752 - , 753 - , 754 - , 755 - , 756 - , 757 - , 758 - , 759 - , 760 - , 761 - , 762 - , 763 - , 764 - , 765 - , 766 - , 767 - , 768 - , 769 - , 770 - , 771 - , 772 - , 773 - , 774 - , 775 - , 776 - , 777 - , 778 - , 779 - , 780 - , 781 - , 782 - , 783 - , 784 - , 785 - , 786 - , 787 - , 788 - , 789 - , 790 - , 791 - , 792 - , 793 - , 794 - , 795 - , 796 - , 797 - , 798 - , 799 - , 800 - , 801 - , 802 - , 803 - , 804 - , 805 - , 806 - , 807 - , 808 - , 809 - , 810 - , 811 - , 812 - , 813 - , 814 - , 815 - , 816 - , 817 - , 818 - , 819 - , 820 - , 821 - , 822 - , 823 - , 824 - , 825 - , 826 - , 827 - , 828 - , 829 - , 830 - , 831 - , 832 - , 833 - , 834 - , 835 - , 836 - , 837 - , 838 - , 839 - , 840 - , 841 - , 842 - , 843 - , 844 - , 845 - , 846 - , 847 - , 848 - , 849 - , 850 - , 851 - , 852 - , 853 - , 854 - , 855 - , 856 - , 857 - , 858 - , 859 - , 860 - , 861 - , 862 - , 863 - , 864 - , 865 - , 866 - , 867 - , 868 - , 869 - , 870 - , 871 - , 872 - , 873 - , 874 - , 875 - , 876 - , 877 - , 878 - , 879 - , 880 - , 881 - , 882 - , 883 - , 884 - , 885 - , 886 - , 887 - , 888 - , 889 - , 890 - , 891 - , 892 - , 893 - , 894 - , 895 - , 896 - , 897 - , 898 - , 899 - , 900 - , 901 - , 902 - , 903 - , 904 - , 905 - , 906 - , 907 - , 908 - , 909 - , 910 - , 911 - , 912 - , 913 - , 914 - , 915 - , 916 - , 917 - , 918 - , 919 - , 920 - , 921 - , 922 - , 923 - , 924 - , 925 - , 926 - , 927 - , 928 - , 929 - , 930 - , 931 - , 932 - , 933 - , 934 - , 935 - , 936 - , 937 - , 938 - , 939 - , 940 - , 941 - , 942 - , 943 - , 944 - , 945 - , 946 - , 947 - , 948 - , 949 - , 950 - , 951 - , 952 - , 953 - , 954 - , 955 - , 956 - , 957 - , 958 - , 959 - , 960 - , 961 - , 962 - , 963 - , 964 - , 965 - , 966 - , 967 - , 968 - , 969 - , 970 - , 971 - , 972 - , 973 - , 974 - , 975 - , 976 - , 977 - , 978 - , 979 - , 980 - , 981 - , 982 - , 983 - , 984 - , 985 - , 986 - , 987 - , 988 - , 989 - , 990 - , 991 - , 992 - , 993 - , 994 - , 995 - , 996 - , 997 - , 998 - , 999 - , 1000 - , 1001 - , 1002 - , 1003 - , 1004 - , 1005 - , 1006 - , 1007 - , 1008 - , 1009 - , 1010 - , 1011 - , 1012 - , 1013 - , 1014 - , 1015 - , 1016 - , 1017 - , 1018 - , 1019 - , 1020 - , 1021 - , 1022 - , 1023 - , 1024 - , 1025 - , 1026 - , 1027 - , 1028 - , 1029 - , 1030 - , 1031 - , 1032 - , 1033 - , 1034 - , 1035 - , 1036 - , 1037 - , 1038 - , 1039 - , 1040 - , 1041 - , 1042 - , 1043 - , 1044 - , 1045 - , 1046 - , 1047 - , 1048 - , 1049 - , 1050 - , 1051 - , 1052 - , 1053 - , 1054 - , 1055 - , 1056 - , 1057 - , 1058 - , 1059 - , 1060 - , 1061 - , 1062 - , 1063 - , 1064 - , 1065 - , 1066 - , 1067 - , 1068 - , 1069 - , 1070 - , 1071 - , 1072 - , 1073 - , 1074 - , 1075 - , 1076 - , 1077 - , 1078 - , 1079 - , 1080 - , 1081 - , 1082 - , 1083 - , 1084 - , 1085 - , 1086 - , 1087 - , 1088 - , 1089 - , 1090 - , 1091 - , 1092 - , 1093 - , 1094 - , 1095 - , 1096 - , 1097 - , 1098 - , 1099 - , 1100 - , 1101 - , 1102 - , 1103 - , 1104 - , 1105 - , 1106 - , 1107 - , 1108 - , 1109 - , 1110 - , 1111 - , 1112 - , 1113 - , 1114 - , 1115 - , 1116 - , 1117 - , 1118 - , 1119 - , 1120 - , 1121 - , 1122 - , 1123 - , 1124 - , 1125 - , 1126 - , 1127 - , 1128 - , 1129 - , 1130 - , 1131 - , 1132 - , 1133 - , 1134 - , 1135 - , 1136 - , 1137 - , 1138 - , 1139 - , 1140 - , 1141 - , 1142 - , 1143 - , 1144 - , 1145 - , 1146 - , 1147 - , 1148 - , 1149 - , 1150 - , 1151 - , 1152 - , 1153 - , 1154 - , 1155 - , 1156 - , 1157 - , 1158 - , 1159 - , 1160 - , 1161 - , 1162 - , 1163 - , 1164 - , 1165 - , 1166 - , 1167 - , 1168 - , 1169 - , 1170 - , 1171 - , 1172 - , 1173 - , 1174 - , 1175 - , 1176 - , 1177 - , 1178 - , 1179 - , 1180 - , 1181 - , 1182 - , 1183 - , 1184 - , 1185 - , 1186 - , 1187 - , 1188 - , 1189 - , 1190 - , 1191 - , 1192 - , 1193 - , 1194 - , 1195 - , 1196 - , 1197 - , 1198 - , 1199 - , 1200 - , 1201 - , 1202 - , 1203 - , 1204 - , 1205 - , 1206 - , 1207 - , 1208 - , 1209 - , 1210 - , 1211 - , 1212 - , 1213 - , 1214 - , 1215 - , 1216 - , 1217 - , 1218 - , 1219 - , 1220 - , 1221 - , 1222 - , 1223 - , 1224 - , 1225 - , 1226 - , 1227 - , 1228 - , 1229 - , 1230 - , 1231 - , 1232 - , 1233 - , 1234 - , 1235 - , 1236 - , 1237 - , 1238 - , 1239 - , 1240 - , 1241 - , 1242 - , 1243 - , 1244 - , 1245 - , 1246 - , 1247 - , 1248 - , 1249 - , 1250 - , 1251 - , 1252 - , 1253 - , 1254 - , 1255 - , 1256 - , 1257 - , 1258 - , 1259 - , 1260 - , 1261 - , 1262 - , 1263 - , 1264 - , 1265 - , 1266 - , 1267 - , 1268 - , 1269 - , 1270 - , 1271 - , 1272 - , 1273 - , 1274 - , 1275 - , 1276 - , 1277 - , 1278 - , 1279 - , 1280 - , 1281 - , 1282 - , 1283 - , 1284 - , 1285 - , 1286 - , 1287 - , 1288 - , 1289 - , 1290 - , 1291 - , 1292 - , 1293 - , 1294 - , 1295 - , 1296 - , 1297 - , 1298 - , 1299 - , 1300 - , 1301 - , 1302 - , 1303 - , 1304 - , 1305 - , 1306 - , 1307 - , 1308 - , 1309 - , 1310 - , 1311 - , 1312 - , 1313 - , 1314 - , 1315 - , 1316 - , 1317 - , 1318 - , 1319 - , 1320 - , 1321 - , 1322 - , 1323 - , 1324 - , 1325 - , 1326 - , 1327 - , 1328 - , 1329 - , 1330 - , 1331 - , 1332 - , 1333 - , 1334 - , 1335 - , 1336 - , 1337 - , 1338 - , 1339 - , 1340 - , 1341 - , 1342 - , 1343 - , 1344 - , 1345 - , 1346 - , 1347 - , 1348 - , 1349 - , 1350 - , 1351 - , 1352 - , 1353 - , 1354 - , 1355 - , 1356 - , 1357 - , 1358 - , 1359 - , 1360 - , 1361 - , 1362 - , 1363 - , 1364 - , 1365 - , 1366 - , 1367 - , 1368 - , 1369 - , 1370 - , 1371 - , 1372 - , 1373 - , 1374 - , 1375 - , 1376 - , 1377 - , 1378 - , 1379 - , 1380 - , 1381 - , 1382 - , 1383 - , 1384 - , 1385 - , 1386 - , 1387 - , 1388 - , 1389 - , 1390 - , 1391 - , 1392 - , 1393 - , 1394 - , 1395 - , 1396 - , 1397 - , 1398 - , 1399 - , 1400 - , 1401 - , 1402 - , 1403 - , 1404 - , 1405 - , 1406 - , 1407 - , 1408 - , 1409 - , 1410 - , 1411 - , 1412 - , 1413 - , 1414 - , 1415 - , 1416 - , 1417 - , 1418 - , 1419 - , 1420 - , 1421 - , 1422 - , 1423 - , 1424 - , 1425 - , 1426 - , 1427 - , 1428 - , 1429 - , 1430 - , 1431 - , 1432 - , 1433 - , 1434 - , 1435 - , 1436 - , 1437 - , 1438 - , 1439 - , 1440 - , 1441 - , 1442 - , 1443 - , 1444 - , 1445 - , 1446 - , 1447 - , 1448 - , 1449 - , 1450 - , 1451 - , 1452 - , 1453 - , 1454 - , 1455 - , 1456 - , 1457 - , 1458 - , 1459 - , 1460 - , 1461 - , 1462 - , 1463 - , 1464 - , 1465 - , 1466 - , 1467 - , 1468 - , 1469 - , 1470 - , 1471 - , 1472 - , 1473 - , 1474 - , 1475 - , 1476 - , 1477 - , 1478 - , 1479 - , 1480 - , 1481 - , 1482 - , 1483 - , 1484 - , 1485 - , 1486 - , 1487 - , 1488 - , 1489 - , 1490 - , 1491 - , 1492 - , 1493 - , 1494 - , 1495 - , 1496 - , 1497 - , 1498 - , 1499 - , 1500 - , 1501 - , 1502 - , 1503 - , 1504 - , 1505 - , 1506 - , 1507 - , 1508 - , 1509 - , 1510 - , 1511 - , 1512 - , 1513 - , 1514 - , 1515 - , 1516 - , 1517 - , 1518 - , 1519 - , 1520 - , 1521 - , 1522 - , 1523 - , 1524 - , 1525 - , 1526 - , 1527 - , 1528 - , 1529 - , 1530 - , 1531 - , 1532 - , 1533 - , 1534 - , 1535 - , 1536 - , 1537 - , 1538 - , 1539 - , 1540 - , 1541 - , 1542 - , 1543 - , 1544 - , 1545 - , 1546 - , 1547 - , 1548 - , 1549 - , 1550 - , 1551 - , 1552 - , 1553 - , 1554 - , 1555 - , 1556 - , 1557 - , 1558 - , 1559 - , 1560 - , 1561 - , 1562 - , 1563 - , 1564 - , 1565 - , 1566 - , 1567 - , 1568 - , 1569 - , 1570 - , 1571 - , 1572 - , 1573 - , 1574 - , 1575 - , 1576 - , 1577 - , 1578 - , 1579 - , 1580 - , 1581 - , 1582 - , 1583 - , 1584 - , 1585 - , 1586 - , 1587 - , 1588 - , 1589 - , 1590 - , 1591 - , 1592 - , 1593 - , 1594 - , 1595 - , 1596 - , 1597 - , 1598 - , 1599 - , 1600 - , 1601 - , 1602 - , 1603 - , 1604 - , 1605 - , 1606 - , 1607 - , 1608 - , 1609 - , 1610 - , 1611 - , 1612 - , 1613 - , 1614 - , 1615 - , 1616 - , 1617 - , 1618 - , 1619 - , 1620 - , 1621 - , 1622 - , 1623 - , 1624 - , 1625 - , 1626 - , 1627 - , 1628 - , 1629 - , 1630 - , 1631 - , 1632 - , 1633 - , 1634 - , 1635 - , 1636 - , 1637 - , 1638 - , 1639 - , 1640 - , 1641 - , 1642 - , 1643 - , 1644 - , 1645 - , 1646 - , 1647 - , 1648 - , 1649 - , 1650 - , 1651 - , 1652 - , 1653 - , 1654 - , 1655 - , 1656 - , 1657 - , 1658 - , 1659 - , 1660 - , 1661 - , 1662 - , 1663 - , 1664 - , 1665 - , 1666 - , 1667 - , 1668 - , 1669 - , 1670 - , 1671 - , 1672 - , 1673 - , 1674 - , 1675 - , 1676 - , 1677 - , 1678 - , 1679 - , 1680 - , 1681 - , 1682 - , 1683 - , 1684 - , 1685 - , 1686 - , 1687 - , 1688 - , 1689 - , 1690 - , 1691 - , 1692 - , 1693 - , 1694 - , 1695 - , 1696 - , 1697 - , 1698 - , 1699 - , 1700 - , 1701 - , 1702 - , 1703 - , 1704 - , 1705 - , 1706 - , 1707 - , 1708 - , 1709 - , 1710 - , 1711 - , 1712 - , 1713 - , 1714 - , 1715 - , 1716 - , 1717 - , 1718 - , 1719 - , 1720 - , 1721 - , 1722 - , 1723 - , 1724 - , 1725 - , 1726 - , 1727 - , 1728 - , 1729 - , 1730 - , 1731 - , 1732 - , 1733 - , 1734 - , 1735 - , 1736 - , 1737 - , 1738 - , 1739 - , 1740 - , 1741 - , 1742 - , 1743 - , 1744 - , 1745 - , 1746 - , 1747 - , 1748 - , 1749 - , 1750 - , 1751 - , 1752 - , 1753 - , 1754 - , 1755 - , 1756 - , 1757 - , 1758 - , 1759 - , 1760 - , 1761 - , 1762 - , 1763 - , 1764 - , 1765 - , 1766 - , 1767 - , 1768 - , 1769 - , 1770 - , 1771 - , 1772 - , 1773 - , 1774 - , 1775 - , 1776 - , 1777 - , 1778 - , 1779 - , 1780 - , 1781 - , 1782 - , 1783 - , 1784 - , 1785 - , 1786 - , 1787 - , 1788 - , 1789 - , 1790 - , 1791 - , 1792 - , 1793 - , 1794 - , 1795 - , 1796 - , 1797 - , 1798 - , 1799 - , 1800 - , 1801 - , 1802 - , 1803 - , 1804 - , 1805 - , 1806 - , 1807 - , 1808 - , 1809 - , 1810 - , 1811 - , 1812 - , 1813 - , 1814 - , 1815 - , 1816 - , 1817 - , 1818 - , 1819 - , 1820 - , 1821 - , 1822 - , 1823 - , 1824 - , 1825 - , 1826 - , 1827 - , 1828 - , 1829 - , 1830 - , 1831 - , 1832 - , 1833 - , 1834 - , 1835 - , 1836 - , 1837 - , 1838 - , 1839 - , 1840 - , 1841 - , 1842 - , 1843 - , 1844 - , 1845 - , 1846 - , 1847 - , 1848 - , 1849 - , 1850 - , 1851 - , 1852 - , 1853 - , 1854 - , 1855 - , 1856 - , 1857 - , 1858 - , 1859 - , 1860 - , 1861 - , 1862 - , 1863 - , 1864 - , 1865 - , 1866 - , 1867 - , 1868 - , 1869 - , 1870 - , 1871 - , 1872 - , 1873 - , 1874 - , 1875 - , 1876 - , 1877 - , 1878 - , 1879 - , 1880 - , 1881 - , 1882 - , 1883 - , 1884 - , 1885 - , 1886 - , 1887 - , 1888 - , 1889 - , 1890 - , 1891 - , 1892 - , 1893 - , 1894 - , 1895 - , 1896 - , 1897 - , 1898 - , 1899 - , 1900 - , 1901 - , 1902 - , 1903 - , 1904 - , 1905 - , 1906 - , 1907 - , 1908 - , 1909 - , 1910 - , 1911 - , 1912 - , 1913 - , 1914 - , 1915 - , 1916 - , 1917 - , 1918 - , 1919 - , 1920 - , 1921 - , 1922 - , 1923 - , 1924 - , 1925 - , 1926 - , 1927 - , 1928 - , 1929 - , 1930 - , 1931 - , 1932 - , 1933 - , 1934 - , 1935 - , 1936 - , 1937 - , 1938 - , 1939 - , 1940 - , 1941 - , 1942 - , 1943 - , 1944 - , 1945 - , 1946 - , 1947 - , 1948 - , 1949 - , 1950 - , 1951 - , 1952 - , 1953 - , 1954 - , 1955 - , 1956 - , 1957 - , 1958 - , 1959 - , 1960 - , 1961 - , 1962 - , 1963 - , 1964 - , 1965 - , 1966 - , 1967 - , 1968 - , 1969 - , 1970 - , 1971 - , 1972 - , 1973 - , 1974 - , 1975 - , 1976 - , 1977 - , 1978 - , 1979 - , 1980 - , 1981 - , 1982 - , 1983 - , 1984 - , 1985 - , 1986 - , 1987 - , 1988 - , 1989 - , 1990 - , 1991 - , 1992 - , 1993 - , 1994 - , 1995 - , 1996 - , 1997 - , 1998 - , 1999 - , 2000 - ] - -``` -Should be cached: - -```unison -> range 2000 -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > range 2000 - ⧩ - [ 1 - , 2 - , 3 - , 4 - , 5 - , 6 - , 7 - , 8 - , 9 - , 10 - , 11 - , 12 - , 13 - , 14 - , 15 - , 16 - , 17 - , 18 - , 19 - , 20 - , 21 - , 22 - , 23 - , 24 - , 25 - , 26 - , 27 - , 28 - , 29 - , 30 - , 31 - , 32 - , 33 - , 34 - , 35 - , 36 - , 37 - , 38 - , 39 - , 40 - , 41 - , 42 - , 43 - , 44 - , 45 - , 46 - , 47 - , 48 - , 49 - , 50 - , 51 - , 52 - , 53 - , 54 - , 55 - , 56 - , 57 - , 58 - , 59 - , 60 - , 61 - , 62 - , 63 - , 64 - , 65 - , 66 - , 67 - , 68 - , 69 - , 70 - , 71 - , 72 - , 73 - , 74 - , 75 - , 76 - , 77 - , 78 - , 79 - , 80 - , 81 - , 82 - , 83 - , 84 - , 85 - , 86 - , 87 - , 88 - , 89 - , 90 - , 91 - , 92 - , 93 - , 94 - , 95 - , 96 - , 97 - , 98 - , 99 - , 100 - , 101 - , 102 - , 103 - , 104 - , 105 - , 106 - , 107 - , 108 - , 109 - , 110 - , 111 - , 112 - , 113 - , 114 - , 115 - , 116 - , 117 - , 118 - , 119 - , 120 - , 121 - , 122 - , 123 - , 124 - , 125 - , 126 - , 127 - , 128 - , 129 - , 130 - , 131 - , 132 - , 133 - , 134 - , 135 - , 136 - , 137 - , 138 - , 139 - , 140 - , 141 - , 142 - , 143 - , 144 - , 145 - , 146 - , 147 - , 148 - , 149 - , 150 - , 151 - , 152 - , 153 - , 154 - , 155 - , 156 - , 157 - , 158 - , 159 - , 160 - , 161 - , 162 - , 163 - , 164 - , 165 - , 166 - , 167 - , 168 - , 169 - , 170 - , 171 - , 172 - , 173 - , 174 - , 175 - , 176 - , 177 - , 178 - , 179 - , 180 - , 181 - , 182 - , 183 - , 184 - , 185 - , 186 - , 187 - , 188 - , 189 - , 190 - , 191 - , 192 - , 193 - , 194 - , 195 - , 196 - , 197 - , 198 - , 199 - , 200 - , 201 - , 202 - , 203 - , 204 - , 205 - , 206 - , 207 - , 208 - , 209 - , 210 - , 211 - , 212 - , 213 - , 214 - , 215 - , 216 - , 217 - , 218 - , 219 - , 220 - , 221 - , 222 - , 223 - , 224 - , 225 - , 226 - , 227 - , 228 - , 229 - , 230 - , 231 - , 232 - , 233 - , 234 - , 235 - , 236 - , 237 - , 238 - , 239 - , 240 - , 241 - , 242 - , 243 - , 244 - , 245 - , 246 - , 247 - , 248 - , 249 - , 250 - , 251 - , 252 - , 253 - , 254 - , 255 - , 256 - , 257 - , 258 - , 259 - , 260 - , 261 - , 262 - , 263 - , 264 - , 265 - , 266 - , 267 - , 268 - , 269 - , 270 - , 271 - , 272 - , 273 - , 274 - , 275 - , 276 - , 277 - , 278 - , 279 - , 280 - , 281 - , 282 - , 283 - , 284 - , 285 - , 286 - , 287 - , 288 - , 289 - , 290 - , 291 - , 292 - , 293 - , 294 - , 295 - , 296 - , 297 - , 298 - , 299 - , 300 - , 301 - , 302 - , 303 - , 304 - , 305 - , 306 - , 307 - , 308 - , 309 - , 310 - , 311 - , 312 - , 313 - , 314 - , 315 - , 316 - , 317 - , 318 - , 319 - , 320 - , 321 - , 322 - , 323 - , 324 - , 325 - , 326 - , 327 - , 328 - , 329 - , 330 - , 331 - , 332 - , 333 - , 334 - , 335 - , 336 - , 337 - , 338 - , 339 - , 340 - , 341 - , 342 - , 343 - , 344 - , 345 - , 346 - , 347 - , 348 - , 349 - , 350 - , 351 - , 352 - , 353 - , 354 - , 355 - , 356 - , 357 - , 358 - , 359 - , 360 - , 361 - , 362 - , 363 - , 364 - , 365 - , 366 - , 367 - , 368 - , 369 - , 370 - , 371 - , 372 - , 373 - , 374 - , 375 - , 376 - , 377 - , 378 - , 379 - , 380 - , 381 - , 382 - , 383 - , 384 - , 385 - , 386 - , 387 - , 388 - , 389 - , 390 - , 391 - , 392 - , 393 - , 394 - , 395 - , 396 - , 397 - , 398 - , 399 - , 400 - , 401 - , 402 - , 403 - , 404 - , 405 - , 406 - , 407 - , 408 - , 409 - , 410 - , 411 - , 412 - , 413 - , 414 - , 415 - , 416 - , 417 - , 418 - , 419 - , 420 - , 421 - , 422 - , 423 - , 424 - , 425 - , 426 - , 427 - , 428 - , 429 - , 430 - , 431 - , 432 - , 433 - , 434 - , 435 - , 436 - , 437 - , 438 - , 439 - , 440 - , 441 - , 442 - , 443 - , 444 - , 445 - , 446 - , 447 - , 448 - , 449 - , 450 - , 451 - , 452 - , 453 - , 454 - , 455 - , 456 - , 457 - , 458 - , 459 - , 460 - , 461 - , 462 - , 463 - , 464 - , 465 - , 466 - , 467 - , 468 - , 469 - , 470 - , 471 - , 472 - , 473 - , 474 - , 475 - , 476 - , 477 - , 478 - , 479 - , 480 - , 481 - , 482 - , 483 - , 484 - , 485 - , 486 - , 487 - , 488 - , 489 - , 490 - , 491 - , 492 - , 493 - , 494 - , 495 - , 496 - , 497 - , 498 - , 499 - , 500 - , 501 - , 502 - , 503 - , 504 - , 505 - , 506 - , 507 - , 508 - , 509 - , 510 - , 511 - , 512 - , 513 - , 514 - , 515 - , 516 - , 517 - , 518 - , 519 - , 520 - , 521 - , 522 - , 523 - , 524 - , 525 - , 526 - , 527 - , 528 - , 529 - , 530 - , 531 - , 532 - , 533 - , 534 - , 535 - , 536 - , 537 - , 538 - , 539 - , 540 - , 541 - , 542 - , 543 - , 544 - , 545 - , 546 - , 547 - , 548 - , 549 - , 550 - , 551 - , 552 - , 553 - , 554 - , 555 - , 556 - , 557 - , 558 - , 559 - , 560 - , 561 - , 562 - , 563 - , 564 - , 565 - , 566 - , 567 - , 568 - , 569 - , 570 - , 571 - , 572 - , 573 - , 574 - , 575 - , 576 - , 577 - , 578 - , 579 - , 580 - , 581 - , 582 - , 583 - , 584 - , 585 - , 586 - , 587 - , 588 - , 589 - , 590 - , 591 - , 592 - , 593 - , 594 - , 595 - , 596 - , 597 - , 598 - , 599 - , 600 - , 601 - , 602 - , 603 - , 604 - , 605 - , 606 - , 607 - , 608 - , 609 - , 610 - , 611 - , 612 - , 613 - , 614 - , 615 - , 616 - , 617 - , 618 - , 619 - , 620 - , 621 - , 622 - , 623 - , 624 - , 625 - , 626 - , 627 - , 628 - , 629 - , 630 - , 631 - , 632 - , 633 - , 634 - , 635 - , 636 - , 637 - , 638 - , 639 - , 640 - , 641 - , 642 - , 643 - , 644 - , 645 - , 646 - , 647 - , 648 - , 649 - , 650 - , 651 - , 652 - , 653 - , 654 - , 655 - , 656 - , 657 - , 658 - , 659 - , 660 - , 661 - , 662 - , 663 - , 664 - , 665 - , 666 - , 667 - , 668 - , 669 - , 670 - , 671 - , 672 - , 673 - , 674 - , 675 - , 676 - , 677 - , 678 - , 679 - , 680 - , 681 - , 682 - , 683 - , 684 - , 685 - , 686 - , 687 - , 688 - , 689 - , 690 - , 691 - , 692 - , 693 - , 694 - , 695 - , 696 - , 697 - , 698 - , 699 - , 700 - , 701 - , 702 - , 703 - , 704 - , 705 - , 706 - , 707 - , 708 - , 709 - , 710 - , 711 - , 712 - , 713 - , 714 - , 715 - , 716 - , 717 - , 718 - , 719 - , 720 - , 721 - , 722 - , 723 - , 724 - , 725 - , 726 - , 727 - , 728 - , 729 - , 730 - , 731 - , 732 - , 733 - , 734 - , 735 - , 736 - , 737 - , 738 - , 739 - , 740 - , 741 - , 742 - , 743 - , 744 - , 745 - , 746 - , 747 - , 748 - , 749 - , 750 - , 751 - , 752 - , 753 - , 754 - , 755 - , 756 - , 757 - , 758 - , 759 - , 760 - , 761 - , 762 - , 763 - , 764 - , 765 - , 766 - , 767 - , 768 - , 769 - , 770 - , 771 - , 772 - , 773 - , 774 - , 775 - , 776 - , 777 - , 778 - , 779 - , 780 - , 781 - , 782 - , 783 - , 784 - , 785 - , 786 - , 787 - , 788 - , 789 - , 790 - , 791 - , 792 - , 793 - , 794 - , 795 - , 796 - , 797 - , 798 - , 799 - , 800 - , 801 - , 802 - , 803 - , 804 - , 805 - , 806 - , 807 - , 808 - , 809 - , 810 - , 811 - , 812 - , 813 - , 814 - , 815 - , 816 - , 817 - , 818 - , 819 - , 820 - , 821 - , 822 - , 823 - , 824 - , 825 - , 826 - , 827 - , 828 - , 829 - , 830 - , 831 - , 832 - , 833 - , 834 - , 835 - , 836 - , 837 - , 838 - , 839 - , 840 - , 841 - , 842 - , 843 - , 844 - , 845 - , 846 - , 847 - , 848 - , 849 - , 850 - , 851 - , 852 - , 853 - , 854 - , 855 - , 856 - , 857 - , 858 - , 859 - , 860 - , 861 - , 862 - , 863 - , 864 - , 865 - , 866 - , 867 - , 868 - , 869 - , 870 - , 871 - , 872 - , 873 - , 874 - , 875 - , 876 - , 877 - , 878 - , 879 - , 880 - , 881 - , 882 - , 883 - , 884 - , 885 - , 886 - , 887 - , 888 - , 889 - , 890 - , 891 - , 892 - , 893 - , 894 - , 895 - , 896 - , 897 - , 898 - , 899 - , 900 - , 901 - , 902 - , 903 - , 904 - , 905 - , 906 - , 907 - , 908 - , 909 - , 910 - , 911 - , 912 - , 913 - , 914 - , 915 - , 916 - , 917 - , 918 - , 919 - , 920 - , 921 - , 922 - , 923 - , 924 - , 925 - , 926 - , 927 - , 928 - , 929 - , 930 - , 931 - , 932 - , 933 - , 934 - , 935 - , 936 - , 937 - , 938 - , 939 - , 940 - , 941 - , 942 - , 943 - , 944 - , 945 - , 946 - , 947 - , 948 - , 949 - , 950 - , 951 - , 952 - , 953 - , 954 - , 955 - , 956 - , 957 - , 958 - , 959 - , 960 - , 961 - , 962 - , 963 - , 964 - , 965 - , 966 - , 967 - , 968 - , 969 - , 970 - , 971 - , 972 - , 973 - , 974 - , 975 - , 976 - , 977 - , 978 - , 979 - , 980 - , 981 - , 982 - , 983 - , 984 - , 985 - , 986 - , 987 - , 988 - , 989 - , 990 - , 991 - , 992 - , 993 - , 994 - , 995 - , 996 - , 997 - , 998 - , 999 - , 1000 - , 1001 - , 1002 - , 1003 - , 1004 - , 1005 - , 1006 - , 1007 - , 1008 - , 1009 - , 1010 - , 1011 - , 1012 - , 1013 - , 1014 - , 1015 - , 1016 - , 1017 - , 1018 - , 1019 - , 1020 - , 1021 - , 1022 - , 1023 - , 1024 - , 1025 - , 1026 - , 1027 - , 1028 - , 1029 - , 1030 - , 1031 - , 1032 - , 1033 - , 1034 - , 1035 - , 1036 - , 1037 - , 1038 - , 1039 - , 1040 - , 1041 - , 1042 - , 1043 - , 1044 - , 1045 - , 1046 - , 1047 - , 1048 - , 1049 - , 1050 - , 1051 - , 1052 - , 1053 - , 1054 - , 1055 - , 1056 - , 1057 - , 1058 - , 1059 - , 1060 - , 1061 - , 1062 - , 1063 - , 1064 - , 1065 - , 1066 - , 1067 - , 1068 - , 1069 - , 1070 - , 1071 - , 1072 - , 1073 - , 1074 - , 1075 - , 1076 - , 1077 - , 1078 - , 1079 - , 1080 - , 1081 - , 1082 - , 1083 - , 1084 - , 1085 - , 1086 - , 1087 - , 1088 - , 1089 - , 1090 - , 1091 - , 1092 - , 1093 - , 1094 - , 1095 - , 1096 - , 1097 - , 1098 - , 1099 - , 1100 - , 1101 - , 1102 - , 1103 - , 1104 - , 1105 - , 1106 - , 1107 - , 1108 - , 1109 - , 1110 - , 1111 - , 1112 - , 1113 - , 1114 - , 1115 - , 1116 - , 1117 - , 1118 - , 1119 - , 1120 - , 1121 - , 1122 - , 1123 - , 1124 - , 1125 - , 1126 - , 1127 - , 1128 - , 1129 - , 1130 - , 1131 - , 1132 - , 1133 - , 1134 - , 1135 - , 1136 - , 1137 - , 1138 - , 1139 - , 1140 - , 1141 - , 1142 - , 1143 - , 1144 - , 1145 - , 1146 - , 1147 - , 1148 - , 1149 - , 1150 - , 1151 - , 1152 - , 1153 - , 1154 - , 1155 - , 1156 - , 1157 - , 1158 - , 1159 - , 1160 - , 1161 - , 1162 - , 1163 - , 1164 - , 1165 - , 1166 - , 1167 - , 1168 - , 1169 - , 1170 - , 1171 - , 1172 - , 1173 - , 1174 - , 1175 - , 1176 - , 1177 - , 1178 - , 1179 - , 1180 - , 1181 - , 1182 - , 1183 - , 1184 - , 1185 - , 1186 - , 1187 - , 1188 - , 1189 - , 1190 - , 1191 - , 1192 - , 1193 - , 1194 - , 1195 - , 1196 - , 1197 - , 1198 - , 1199 - , 1200 - , 1201 - , 1202 - , 1203 - , 1204 - , 1205 - , 1206 - , 1207 - , 1208 - , 1209 - , 1210 - , 1211 - , 1212 - , 1213 - , 1214 - , 1215 - , 1216 - , 1217 - , 1218 - , 1219 - , 1220 - , 1221 - , 1222 - , 1223 - , 1224 - , 1225 - , 1226 - , 1227 - , 1228 - , 1229 - , 1230 - , 1231 - , 1232 - , 1233 - , 1234 - , 1235 - , 1236 - , 1237 - , 1238 - , 1239 - , 1240 - , 1241 - , 1242 - , 1243 - , 1244 - , 1245 - , 1246 - , 1247 - , 1248 - , 1249 - , 1250 - , 1251 - , 1252 - , 1253 - , 1254 - , 1255 - , 1256 - , 1257 - , 1258 - , 1259 - , 1260 - , 1261 - , 1262 - , 1263 - , 1264 - , 1265 - , 1266 - , 1267 - , 1268 - , 1269 - , 1270 - , 1271 - , 1272 - , 1273 - , 1274 - , 1275 - , 1276 - , 1277 - , 1278 - , 1279 - , 1280 - , 1281 - , 1282 - , 1283 - , 1284 - , 1285 - , 1286 - , 1287 - , 1288 - , 1289 - , 1290 - , 1291 - , 1292 - , 1293 - , 1294 - , 1295 - , 1296 - , 1297 - , 1298 - , 1299 - , 1300 - , 1301 - , 1302 - , 1303 - , 1304 - , 1305 - , 1306 - , 1307 - , 1308 - , 1309 - , 1310 - , 1311 - , 1312 - , 1313 - , 1314 - , 1315 - , 1316 - , 1317 - , 1318 - , 1319 - , 1320 - , 1321 - , 1322 - , 1323 - , 1324 - , 1325 - , 1326 - , 1327 - , 1328 - , 1329 - , 1330 - , 1331 - , 1332 - , 1333 - , 1334 - , 1335 - , 1336 - , 1337 - , 1338 - , 1339 - , 1340 - , 1341 - , 1342 - , 1343 - , 1344 - , 1345 - , 1346 - , 1347 - , 1348 - , 1349 - , 1350 - , 1351 - , 1352 - , 1353 - , 1354 - , 1355 - , 1356 - , 1357 - , 1358 - , 1359 - , 1360 - , 1361 - , 1362 - , 1363 - , 1364 - , 1365 - , 1366 - , 1367 - , 1368 - , 1369 - , 1370 - , 1371 - , 1372 - , 1373 - , 1374 - , 1375 - , 1376 - , 1377 - , 1378 - , 1379 - , 1380 - , 1381 - , 1382 - , 1383 - , 1384 - , 1385 - , 1386 - , 1387 - , 1388 - , 1389 - , 1390 - , 1391 - , 1392 - , 1393 - , 1394 - , 1395 - , 1396 - , 1397 - , 1398 - , 1399 - , 1400 - , 1401 - , 1402 - , 1403 - , 1404 - , 1405 - , 1406 - , 1407 - , 1408 - , 1409 - , 1410 - , 1411 - , 1412 - , 1413 - , 1414 - , 1415 - , 1416 - , 1417 - , 1418 - , 1419 - , 1420 - , 1421 - , 1422 - , 1423 - , 1424 - , 1425 - , 1426 - , 1427 - , 1428 - , 1429 - , 1430 - , 1431 - , 1432 - , 1433 - , 1434 - , 1435 - , 1436 - , 1437 - , 1438 - , 1439 - , 1440 - , 1441 - , 1442 - , 1443 - , 1444 - , 1445 - , 1446 - , 1447 - , 1448 - , 1449 - , 1450 - , 1451 - , 1452 - , 1453 - , 1454 - , 1455 - , 1456 - , 1457 - , 1458 - , 1459 - , 1460 - , 1461 - , 1462 - , 1463 - , 1464 - , 1465 - , 1466 - , 1467 - , 1468 - , 1469 - , 1470 - , 1471 - , 1472 - , 1473 - , 1474 - , 1475 - , 1476 - , 1477 - , 1478 - , 1479 - , 1480 - , 1481 - , 1482 - , 1483 - , 1484 - , 1485 - , 1486 - , 1487 - , 1488 - , 1489 - , 1490 - , 1491 - , 1492 - , 1493 - , 1494 - , 1495 - , 1496 - , 1497 - , 1498 - , 1499 - , 1500 - , 1501 - , 1502 - , 1503 - , 1504 - , 1505 - , 1506 - , 1507 - , 1508 - , 1509 - , 1510 - , 1511 - , 1512 - , 1513 - , 1514 - , 1515 - , 1516 - , 1517 - , 1518 - , 1519 - , 1520 - , 1521 - , 1522 - , 1523 - , 1524 - , 1525 - , 1526 - , 1527 - , 1528 - , 1529 - , 1530 - , 1531 - , 1532 - , 1533 - , 1534 - , 1535 - , 1536 - , 1537 - , 1538 - , 1539 - , 1540 - , 1541 - , 1542 - , 1543 - , 1544 - , 1545 - , 1546 - , 1547 - , 1548 - , 1549 - , 1550 - , 1551 - , 1552 - , 1553 - , 1554 - , 1555 - , 1556 - , 1557 - , 1558 - , 1559 - , 1560 - , 1561 - , 1562 - , 1563 - , 1564 - , 1565 - , 1566 - , 1567 - , 1568 - , 1569 - , 1570 - , 1571 - , 1572 - , 1573 - , 1574 - , 1575 - , 1576 - , 1577 - , 1578 - , 1579 - , 1580 - , 1581 - , 1582 - , 1583 - , 1584 - , 1585 - , 1586 - , 1587 - , 1588 - , 1589 - , 1590 - , 1591 - , 1592 - , 1593 - , 1594 - , 1595 - , 1596 - , 1597 - , 1598 - , 1599 - , 1600 - , 1601 - , 1602 - , 1603 - , 1604 - , 1605 - , 1606 - , 1607 - , 1608 - , 1609 - , 1610 - , 1611 - , 1612 - , 1613 - , 1614 - , 1615 - , 1616 - , 1617 - , 1618 - , 1619 - , 1620 - , 1621 - , 1622 - , 1623 - , 1624 - , 1625 - , 1626 - , 1627 - , 1628 - , 1629 - , 1630 - , 1631 - , 1632 - , 1633 - , 1634 - , 1635 - , 1636 - , 1637 - , 1638 - , 1639 - , 1640 - , 1641 - , 1642 - , 1643 - , 1644 - , 1645 - , 1646 - , 1647 - , 1648 - , 1649 - , 1650 - , 1651 - , 1652 - , 1653 - , 1654 - , 1655 - , 1656 - , 1657 - , 1658 - , 1659 - , 1660 - , 1661 - , 1662 - , 1663 - , 1664 - , 1665 - , 1666 - , 1667 - , 1668 - , 1669 - , 1670 - , 1671 - , 1672 - , 1673 - , 1674 - , 1675 - , 1676 - , 1677 - , 1678 - , 1679 - , 1680 - , 1681 - , 1682 - , 1683 - , 1684 - , 1685 - , 1686 - , 1687 - , 1688 - , 1689 - , 1690 - , 1691 - , 1692 - , 1693 - , 1694 - , 1695 - , 1696 - , 1697 - , 1698 - , 1699 - , 1700 - , 1701 - , 1702 - , 1703 - , 1704 - , 1705 - , 1706 - , 1707 - , 1708 - , 1709 - , 1710 - , 1711 - , 1712 - , 1713 - , 1714 - , 1715 - , 1716 - , 1717 - , 1718 - , 1719 - , 1720 - , 1721 - , 1722 - , 1723 - , 1724 - , 1725 - , 1726 - , 1727 - , 1728 - , 1729 - , 1730 - , 1731 - , 1732 - , 1733 - , 1734 - , 1735 - , 1736 - , 1737 - , 1738 - , 1739 - , 1740 - , 1741 - , 1742 - , 1743 - , 1744 - , 1745 - , 1746 - , 1747 - , 1748 - , 1749 - , 1750 - , 1751 - , 1752 - , 1753 - , 1754 - , 1755 - , 1756 - , 1757 - , 1758 - , 1759 - , 1760 - , 1761 - , 1762 - , 1763 - , 1764 - , 1765 - , 1766 - , 1767 - , 1768 - , 1769 - , 1770 - , 1771 - , 1772 - , 1773 - , 1774 - , 1775 - , 1776 - , 1777 - , 1778 - , 1779 - , 1780 - , 1781 - , 1782 - , 1783 - , 1784 - , 1785 - , 1786 - , 1787 - , 1788 - , 1789 - , 1790 - , 1791 - , 1792 - , 1793 - , 1794 - , 1795 - , 1796 - , 1797 - , 1798 - , 1799 - , 1800 - , 1801 - , 1802 - , 1803 - , 1804 - , 1805 - , 1806 - , 1807 - , 1808 - , 1809 - , 1810 - , 1811 - , 1812 - , 1813 - , 1814 - , 1815 - , 1816 - , 1817 - , 1818 - , 1819 - , 1820 - , 1821 - , 1822 - , 1823 - , 1824 - , 1825 - , 1826 - , 1827 - , 1828 - , 1829 - , 1830 - , 1831 - , 1832 - , 1833 - , 1834 - , 1835 - , 1836 - , 1837 - , 1838 - , 1839 - , 1840 - , 1841 - , 1842 - , 1843 - , 1844 - , 1845 - , 1846 - , 1847 - , 1848 - , 1849 - , 1850 - , 1851 - , 1852 - , 1853 - , 1854 - , 1855 - , 1856 - , 1857 - , 1858 - , 1859 - , 1860 - , 1861 - , 1862 - , 1863 - , 1864 - , 1865 - , 1866 - , 1867 - , 1868 - , 1869 - , 1870 - , 1871 - , 1872 - , 1873 - , 1874 - , 1875 - , 1876 - , 1877 - , 1878 - , 1879 - , 1880 - , 1881 - , 1882 - , 1883 - , 1884 - , 1885 - , 1886 - , 1887 - , 1888 - , 1889 - , 1890 - , 1891 - , 1892 - , 1893 - , 1894 - , 1895 - , 1896 - , 1897 - , 1898 - , 1899 - , 1900 - , 1901 - , 1902 - , 1903 - , 1904 - , 1905 - , 1906 - , 1907 - , 1908 - , 1909 - , 1910 - , 1911 - , 1912 - , 1913 - , 1914 - , 1915 - , 1916 - , 1917 - , 1918 - , 1919 - , 1920 - , 1921 - , 1922 - , 1923 - , 1924 - , 1925 - , 1926 - , 1927 - , 1928 - , 1929 - , 1930 - , 1931 - , 1932 - , 1933 - , 1934 - , 1935 - , 1936 - , 1937 - , 1938 - , 1939 - , 1940 - , 1941 - , 1942 - , 1943 - , 1944 - , 1945 - , 1946 - , 1947 - , 1948 - , 1949 - , 1950 - , 1951 - , 1952 - , 1953 - , 1954 - , 1955 - , 1956 - , 1957 - , 1958 - , 1959 - , 1960 - , 1961 - , 1962 - , 1963 - , 1964 - , 1965 - , 1966 - , 1967 - , 1968 - , 1969 - , 1970 - , 1971 - , 1972 - , 1973 - , 1974 - , 1975 - , 1976 - , 1977 - , 1978 - , 1979 - , 1980 - , 1981 - , 1982 - , 1983 - , 1984 - , 1985 - , 1986 - , 1987 - , 1988 - , 1989 - , 1990 - , 1991 - , 1992 - , 1993 - , 1994 - , 1995 - , 1996 - , 1997 - , 1998 - , 1999 - , 2000 - ] - -``` diff --git a/unison-src/transcripts/fix2712.md b/unison-src/transcripts/fix2712.md deleted file mode 100644 index fce7511665..0000000000 --- a/unison-src/transcripts/fix2712.md +++ /dev/null @@ -1,27 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison -unique type Map k v = Tip | Bin Nat k v (Map k v) (Map k v) - -mapWithKey : (k ->{e} a ->{e} b) -> Map k a ->{e} Map k b -mapWithKey f m = Tip -``` - -```ucm -.> add -``` - -```unison - -naiomi = - susan: Nat -> Nat -> () - susan a b = () - - pam: Map Nat Nat - pam = Tip - - mapWithKey susan pam - -``` diff --git a/unison-src/transcripts/fix2712.output.md b/unison-src/transcripts/fix2712.output.md deleted file mode 100644 index 08cdb89a30..0000000000 --- a/unison-src/transcripts/fix2712.output.md +++ /dev/null @@ -1,55 +0,0 @@ -```unison -unique type Map k v = Tip | Bin Nat k v (Map k v) (Map k v) - -mapWithKey : (k ->{e} a ->{e} b) -> Map k a ->{e} Map k b -mapWithKey f m = Tip -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Map k v - mapWithKey : (k ->{e} a ->{e} b) -> Map k a ->{e} Map k b - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Map k v - mapWithKey : (k ->{e} a ->{e} b) -> Map k a ->{e} Map k b - -``` -```unison -naiomi = - susan: Nat -> Nat -> () - susan a b = () - - pam: Map Nat Nat - pam = Tip - - mapWithKey susan pam - -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - naiomi : Map Nat () - -``` diff --git a/unison-src/transcripts/fix2795.md b/unison-src/transcripts/fix2795.md deleted file mode 100644 index d4b61c99b3..0000000000 --- a/unison-src/transcripts/fix2795.md +++ /dev/null @@ -1,5 +0,0 @@ -```ucm -.> builtins.mergeio -.> load unison-src/transcripts/fix2795/docs.u -.> display test -``` diff --git a/unison-src/transcripts/fix2795.output.md b/unison-src/transcripts/fix2795.output.md deleted file mode 100644 index 13a789f037..0000000000 --- a/unison-src/transcripts/fix2795.output.md +++ /dev/null @@ -1,31 +0,0 @@ -```ucm -.> builtins.mergeio - - Done. - -.> load unison-src/transcripts/fix2795/docs.u - - Loading changes detected in - unison-src/transcripts/fix2795/docs.u. - - I found and typechecked these definitions in - unison-src/transcripts/fix2795/docs.u. If you do an `add` or - `update`, here's how your codebase would change: - - ⍟ These new definitions are ok to `add`: - - t1 : Text - test : Doc2 - -.> display test - - t : Text - t = "hi" - t - ⧨ - "hi" - - t1 : Text - t1 = "hi" - -``` diff --git a/unison-src/transcripts/fix2795/docs.u b/unison-src/transcripts/fix2795/docs.u deleted file mode 100644 index c5bb69aa6e..0000000000 --- a/unison-src/transcripts/fix2795/docs.u +++ /dev/null @@ -1,12 +0,0 @@ -test = {{ - ``` - t : Text - t = "hi" - - t - ``` - @source{t1} - -}} - -t1 = "hi" diff --git a/unison-src/transcripts/fix2840.md b/unison-src/transcripts/fix2840.md index be481b5bbd..31d4c103df 100644 --- a/unison-src/transcripts/fix2840.md +++ b/unison-src/transcripts/fix2840.md @@ -1,12 +1,12 @@ This bugfix addresses an issue where embedded Unison code in UCM was expected to be present in the active codebase when the `display` command was used render `Doc` values. -```ucm:hide -.> builtins.merge +``` ucm :hide +scratch/main> builtins.merge ``` First, a few \[hidden] definitions necessary for typechecking a simple Doc2. -```unison:hide:all +``` unison :hide-all structural type Optional a = None | Some a unique[b7a4fb87e34569319591130bf3ec6e24c9955b6a] type Doc2 @@ -62,19 +62,19 @@ syntax.docParagraph = Paragraph syntax.docWord = Word ``` -```ucm -.> add +``` ucm +scratch/main> add ``` Next, define and display a simple Doc: -```unison:hide +``` unison :hide README = {{ Hi }} ``` -```ucm -.> display README +``` ucm +scratch/main> display README ``` Previously, the error was: diff --git a/unison-src/transcripts/fix2840.output.md b/unison-src/transcripts/fix2840.output.md index c47df9a2c7..e8e54f3085 100644 --- a/unison-src/transcripts/fix2840.output.md +++ b/unison-src/transcripts/fix2840.output.md @@ -1,12 +1,16 @@ This bugfix addresses an issue where embedded Unison code in UCM was expected to be present in the active codebase when the `display` command was used render `Doc` values. -First, a few \[hidden] definitions necessary for typechecking a simple Doc2. +``` ucm :hide +scratch/main> builtins.merge +``` + +First, a few \[hidden\] definitions necessary for typechecking a simple Doc2. -```ucm -.> add +``` ucm +scratch/main> add ⍟ I've added these definitions: - + type Doc2 type Doc2.SpecialForm type Doc2.Term @@ -15,27 +19,27 @@ First, a few \[hidden] definitions necessary for typechecking a simple Doc2. syntax.docParagraph : [Doc2] -> Doc2 syntax.docUntitledSection : [Doc2] -> Doc2 syntax.docWord : Text -> Doc2 - ``` + Next, define and display a simple Doc: -```unison + +``` unison :hide README = {{ Hi }} ``` -```ucm -.> display README +``` ucm +scratch/main> display README Hi - ``` + Previously, the error was: -``` +``` ⚙️ Processing stanza 5 of 7.ucm: PE [("die",SrcLoc {srcLocPackage = "unison-parser-typechecker-0.0.0-He2Hp1llokT2nN4MnUfUXz", srcLocModule = "Unison.Runtime.Interface", srcLocFile = "src/Unison/Runtime/Interface.hs", srcLocStartLine = 118, srcLocStartCol = 18, srcLocEndLine = 118, srcLocEndCol = 60})] Lit AnnotatedText (fromList [Segment {segment = "Unknown term reference: #4522d", annotation = Nothing}]) - ``` but as of this PR, it's okay. diff --git a/unison-src/transcripts/fix2970.md b/unison-src/transcripts/fix2970.md deleted file mode 100644 index d9a6a6b532..0000000000 --- a/unison-src/transcripts/fix2970.md +++ /dev/null @@ -1,10 +0,0 @@ -Also fixes #1519 (it's the same issue). - -```ucm -.> builtins.merge -``` - -```unison -foo.+.doc : Nat -foo.+.doc = 10 -``` diff --git a/unison-src/transcripts/fix2970.output.md b/unison-src/transcripts/fix2970.output.md deleted file mode 100644 index 904508e2cd..0000000000 --- a/unison-src/transcripts/fix2970.output.md +++ /dev/null @@ -1,26 +0,0 @@ -Also fixes #1519 (it's the same issue). - -```ucm -.> builtins.merge - - Done. - -``` -```unison -foo.+.doc : Nat -foo.+.doc = 10 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo.+.doc : Nat - -``` diff --git a/unison-src/transcripts/fix3037.md b/unison-src/transcripts/fix3037.md deleted file mode 100644 index c16c1f284f..0000000000 --- a/unison-src/transcripts/fix3037.md +++ /dev/null @@ -1,32 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -Tests for an unsound case of ability checking that was erroneously being -accepted before. In certain cases, abilities were able to be added to rows in -invariant positions. - -```unison:error -structural type Runner g = Runner (forall a. '{g} a -> {} a) - -pureRunner : Runner {} -pureRunner = Runner base.force - --- this compiles, but shouldn't the effect type parameter on Runner be invariant? -runner : Runner {IO} -runner = pureRunner -``` - -Application version: - -```unison:error -structural type A g = A (forall a. '{g} a ->{} a) - -anA : A {} -anA = A base.force - -h : A {IO} -> () -h _ = () - -> h anA -``` diff --git a/unison-src/transcripts/fix3037.output.md b/unison-src/transcripts/fix3037.output.md deleted file mode 100644 index 1ffd18c3bc..0000000000 --- a/unison-src/transcripts/fix3037.output.md +++ /dev/null @@ -1,64 +0,0 @@ -Tests for an unsound case of ability checking that was erroneously being -accepted before. In certain cases, abilities were able to be added to rows in -invariant positions. - -```unison -structural type Runner g = Runner (forall a. '{g} a -> {} a) - -pureRunner : Runner {} -pureRunner = Runner base.force - --- this compiles, but shouldn't the effect type parameter on Runner be invariant? -runner : Runner {IO} -runner = pureRunner -``` - -```ucm - - Loading changes detected in scratch.u. - - I found an ability mismatch when checking the expression in red - - 3 | pureRunner : Runner {} - 4 | pureRunner = Runner base.force - 5 | - 6 | -- this compiles, but shouldn't the effect type parameter on Runner be invariant? - 7 | runner : Runner {IO} - 8 | runner = pureRunner - - - When trying to match Runner {} with Runner {IO} the right hand - side contained extra abilities: {IO} - - - -``` -Application version: - -```unison -structural type A g = A (forall a. '{g} a ->{} a) - -anA : A {} -anA = A base.force - -h : A {IO} -> () -h _ = () - -> h anA -``` - -```ucm - - Loading changes detected in scratch.u. - - I found an ability mismatch when checking the application - - 9 | > h anA - - - When trying to match A {} with A {IO} the right hand side - contained extra abilities: {IO} - - - -``` diff --git a/unison-src/transcripts/fix3171.md b/unison-src/transcripts/fix3171.md deleted file mode 100644 index 62790dd1aa..0000000000 --- a/unison-src/transcripts/fix3171.md +++ /dev/null @@ -1,14 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -Tests an case where decompiling could cause function arguments to occur in the -opposite order for partially applied functions. - -```unison -f : Nat -> Nat -> Nat -> () -> Nat -f x y z _ = x + y * z - -> f 1 2 -> f 1 2 3 -``` diff --git a/unison-src/transcripts/fix3171.output.md b/unison-src/transcripts/fix3171.output.md deleted file mode 100644 index 6a6ba04962..0000000000 --- a/unison-src/transcripts/fix3171.output.md +++ /dev/null @@ -1,35 +0,0 @@ -Tests an case where decompiling could cause function arguments to occur in the -opposite order for partially applied functions. - -```unison -f : Nat -> Nat -> Nat -> () -> Nat -f x y z _ = x + y * z - -> f 1 2 -> f 1 2 3 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - f : Nat -> Nat -> Nat -> 'Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 4 | > f 1 2 - ⧩ - z _ -> 1 Nat.+ 2 Nat.* z - - 5 | > f 1 2 3 - ⧩ - _ -> 1 Nat.+ 2 Nat.* 3 - -``` diff --git a/unison-src/transcripts/fix3196.md b/unison-src/transcripts/fix3196.md deleted file mode 100644 index d04592aa6c..0000000000 --- a/unison-src/transcripts/fix3196.md +++ /dev/null @@ -1,32 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -Tests ability checking in scenarios where one side is concrete and the other is -a variable. This was supposed to be covered, but the method wasn't actually -symmetric, so doing `equate l r` might work, but not `equate r l`. - -Below were cases that caused the failing order. - -```unison -structural type W es = W - -unique ability Zoot where - zoot : () - -woot : W {g} -> '{g, Zoot} a ->{Zoot} a -woot w a = todo () - -ex = do - w = (W : W {Zoot}) - woot w do bug "why don't you typecheck?" - -w1 : W {Zoot} -w1 = W - -w2 : W {g} -> W {g} -w2 = cases W -> W - -> w2 w1 -``` diff --git a/unison-src/transcripts/fix3196.output.md b/unison-src/transcripts/fix3196.output.md deleted file mode 100644 index 3a5e2944d1..0000000000 --- a/unison-src/transcripts/fix3196.output.md +++ /dev/null @@ -1,54 +0,0 @@ - -Tests ability checking in scenarios where one side is concrete and the other is -a variable. This was supposed to be covered, but the method wasn't actually -symmetric, so doing `equate l r` might work, but not `equate r l`. - -Below were cases that caused the failing order. - -```unison -structural type W es = W - -unique ability Zoot where - zoot : () - -woot : W {g} -> '{g, Zoot} a ->{Zoot} a -woot w a = todo () - -ex = do - w = (W : W {Zoot}) - woot w do bug "why don't you typecheck?" - -w1 : W {Zoot} -w1 = W - -w2 : W {g} -> W {g} -w2 = cases W -> W - -> w2 w1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type W es - ability Zoot - ex : '{Zoot} r - w1 : W {Zoot} - w2 : W {g} -> W {g} - woot : W {g} -> '{g, Zoot} a ->{Zoot} a - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 19 | > w2 w1 - ⧩ - W - -``` diff --git a/unison-src/transcripts/fix3215.md b/unison-src/transcripts/fix3215.md deleted file mode 100644 index af0e67e868..0000000000 --- a/unison-src/transcripts/fix3215.md +++ /dev/null @@ -1,21 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -Tests a case where concrete abilities were appearing multiple times in an -inferred type. This was due to the pre-pass that figures out which abilities -are being matched on. It was just concatenating the ability for each pattern -into a list, and not checking whether there were duplicates. - -```unison -structural ability T where - nat : Nat - int : Int - flo : Float - -f = cases - {nat -> k} -> 5 - {int -> k} -> 5 - {flo -> k} -> 5 - {x} -> 5 -``` diff --git a/unison-src/transcripts/fix3215.output.md b/unison-src/transcripts/fix3215.output.md deleted file mode 100644 index aaa3e8f4c3..0000000000 --- a/unison-src/transcripts/fix3215.output.md +++ /dev/null @@ -1,32 +0,0 @@ -Tests a case where concrete abilities were appearing multiple times in an -inferred type. This was due to the pre-pass that figures out which abilities -are being matched on. It was just concatenating the ability for each pattern -into a list, and not checking whether there were duplicates. - -```unison -structural ability T where - nat : Nat - int : Int - flo : Float - -f = cases - {nat -> k} -> 5 - {int -> k} -> 5 - {flo -> k} -> 5 - {x} -> 5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability T - f : Request {g, T} x -> Nat - -``` diff --git a/unison-src/transcripts/fix3244.md b/unison-src/transcripts/fix3244.md deleted file mode 100644 index 0ae745e897..0000000000 --- a/unison-src/transcripts/fix3244.md +++ /dev/null @@ -1,21 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -This tests an previously erroneous case in the pattern compiler. It was assuming -that the variables bound in a guard matched the variables bound in the rest of -the branch exactly, but apparently this needn't be the case. - -```unison - -foo t = - (x, _) = t - f w = w + x - - match t with - (x, y) - | y < 5 -> f x - | otherwise -> x + y - -> foo (10,20) -``` diff --git a/unison-src/transcripts/fix3244.output.md b/unison-src/transcripts/fix3244.output.md deleted file mode 100644 index 94231d1745..0000000000 --- a/unison-src/transcripts/fix3244.output.md +++ /dev/null @@ -1,37 +0,0 @@ -This tests an previously erroneous case in the pattern compiler. It was assuming -that the variables bound in a guard matched the variables bound in the rest of -the branch exactly, but apparently this needn't be the case. - -```unison -foo t = - (x, _) = t - f w = w + x - - match t with - (x, y) - | y < 5 -> f x - | otherwise -> x + y - -> foo (10,20) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo : (Nat, Nat) -> Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 10 | > foo (10,20) - ⧩ - 30 - -``` diff --git a/unison-src/transcripts/fix3265.md b/unison-src/transcripts/fix3265.md deleted file mode 100644 index fcf9ce8fb9..0000000000 --- a/unison-src/transcripts/fix3265.md +++ /dev/null @@ -1,41 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -Tests cases that produced bad decompilation output previously. There -are three cases that need to be 'fixed up.' - 1. lambda expressions with free variables need to be beta reduced - 2. let defined functions need to have arguments removed and - occurrences rewritten. - 3. let-rec defined functions need to have arguments removed, but - it is a more complicated process. - -```unison -> Any (w x -> let - f0 y = match y with - 0 -> x - n -> 1 + f1 (drop y 1) - f1 y = match y with - 0 -> w + x - n -> 1 + f0 (drop y 1) - f2 x = f2 x - f3 y = 1 + y + f2 x - g h = h 1 + x - g (z -> x + f0 z)) -``` - -Also check for some possible corner cases. - -`f` should not have its `x` argument eliminated, because it doesn't -always occur with `x` as the first argument, but if we aren't careful, -we might do that, because we find the first occurrence of `f`, and -discard its arguments, where `f` also occurs. - -```unison -> Any (x -> let - f x y = match y with - 0 -> 0 - _ -> f x (f y (drop y 1)) - - f x 20) -``` diff --git a/unison-src/transcripts/fix3265.output.md b/unison-src/transcripts/fix3265.output.md deleted file mode 100644 index 93e8db747f..0000000000 --- a/unison-src/transcripts/fix3265.output.md +++ /dev/null @@ -1,89 +0,0 @@ -Tests cases that produced bad decompilation output previously. There -are three cases that need to be 'fixed up.' - 1. lambda expressions with free variables need to be beta reduced - 2. let defined functions need to have arguments removed and - occurrences rewritten. - 3. let-rec defined functions need to have arguments removed, but - it is a more complicated process. - -```unison -> Any (w x -> let - f0 y = match y with - 0 -> x - n -> 1 + f1 (drop y 1) - f1 y = match y with - 0 -> w + x - n -> 1 + f0 (drop y 1) - f2 x = f2 x - f3 y = 1 + y + f2 x - g h = h 1 + x - g (z -> x + f0 z)) -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > Any (w x -> let - ⧩ - Any - (w x -> - let - use Nat + drop - f1 y = match y with - 0 -> w + x - n -> 1 + f0 (drop y 1) - f0 y = match y with - 0 -> x - n -> 1 + f1 (drop y 1) - f2 x = f2 x - f3 x y = 1 + y + f2 x - g h = h 1 + x - g (z -> x + f0 z)) - -``` -Also check for some possible corner cases. - -`f` should not have its `x` argument eliminated, because it doesn't -always occur with `x` as the first argument, but if we aren't careful, -we might do that, because we find the first occurrence of `f`, and -discard its arguments, where `f` also occurs. - -```unison -> Any (x -> let - f x y = match y with - 0 -> 0 - _ -> f x (f y (drop y 1)) - - f x 20) -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > Any (x -> let - ⧩ - Any - (x -> - let - f x y = match y with - 0 -> 0 - _ -> f x (f y (Nat.drop y 1)) - f x 20) - -``` diff --git a/unison-src/transcripts/fix3634.md b/unison-src/transcripts/fix3634.md deleted file mode 100644 index 0cb5f88dd9..0000000000 --- a/unison-src/transcripts/fix3634.md +++ /dev/null @@ -1,21 +0,0 @@ -```ucm:hide -.> builtins.mergeio -``` - - -```unison -structural type M a = N | J a - -d = {{ - -{{ docExample 0 '(x -> J x) }} - -{J} - -}} -``` - -```ucm -.> add -.> display d -``` \ No newline at end of file diff --git a/unison-src/transcripts/fix3634.output.md b/unison-src/transcripts/fix3634.output.md deleted file mode 100644 index 46f009f8cd..0000000000 --- a/unison-src/transcripts/fix3634.output.md +++ /dev/null @@ -1,43 +0,0 @@ -```unison -structural type M a = N | J a - -d = {{ - -{{ docExample 0 '(x -> J x) }} - -{J} - -}} -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type M a - (also named builtin.Optional) - d : Doc2 - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - structural type M a - (also named builtin.Optional) - d : Doc2 - -.> display d - - `x -> J x` - - J - -``` diff --git a/unison-src/transcripts/fix3678.md b/unison-src/transcripts/fix3678.md deleted file mode 100644 index 13bed5d26c..0000000000 --- a/unison-src/transcripts/fix3678.md +++ /dev/null @@ -1,14 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -Array comparison was indexing out of bounds. - -```unison -arr = Scope.run do - ma = Scope.arrayOf "asdf" 0 - freeze! ma - -> compare arr arr -``` diff --git a/unison-src/transcripts/fix3678.output.md b/unison-src/transcripts/fix3678.output.md deleted file mode 100644 index f99633e649..0000000000 --- a/unison-src/transcripts/fix3678.output.md +++ /dev/null @@ -1,31 +0,0 @@ - -Array comparison was indexing out of bounds. - -```unison -arr = Scope.run do - ma = Scope.arrayOf "asdf" 0 - freeze! ma - -> compare arr arr -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - arr : ImmutableArray Text - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 5 | > compare arr arr - ⧩ - +0 - -``` diff --git a/unison-src/transcripts/fix3752.md b/unison-src/transcripts/fix3752.md deleted file mode 100644 index 72979087f5..0000000000 --- a/unison-src/transcripts/fix3752.md +++ /dev/null @@ -1,22 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -These were failing to type check before, because id was not -generalized. - -```unison - -foo = do - id x = - _ = 1 - x - id () - id "hello" - -bar = do - id x = x - id () - id "hello" -``` - diff --git a/unison-src/transcripts/fix3752.output.md b/unison-src/transcripts/fix3752.output.md deleted file mode 100644 index fd477070ba..0000000000 --- a/unison-src/transcripts/fix3752.output.md +++ /dev/null @@ -1,31 +0,0 @@ -These were failing to type check before, because id was not -generalized. - -```unison -foo = do - id x = - _ = 1 - x - id () - id "hello" - -bar = do - id x = x - id () - id "hello" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bar : 'Text - foo : 'Text - -``` diff --git a/unison-src/transcripts/fix3759.md b/unison-src/transcripts/fix3759.md deleted file mode 100644 index 63047bc914..0000000000 --- a/unison-src/transcripts/fix3759.md +++ /dev/null @@ -1,57 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -```unison:hide -unique type codebase.Foo = Foo - -Woot.state : Nat -Woot.state = 42 - -Woot.frobnicate : Nat -Woot.frobnicate = 43 -``` - -```ucm:hide -.> add -``` - -```unison -unique type Oog.Foo = Foo Text - -unique ability Blah where - foo : Foo -> () - -unique type Something = { state : Text } - -oog = do - foo (Foo "hi" : Oog.Foo) - -ex = do - s = Something "hello" - state s ++ " world!" - --- check that using locally unique suffix shadows the `Foo` in codebase -fn1 : Foo -> Foo -> Nat -fn1 = cases Foo a, Foo b -> Text.size a Nat.+ Text.size b - --- check that using local fully qualified name works fine -fn2 : Oog.Foo -> Oog.Foo -> Text -fn2 = cases Foo a, Foo b -> a Text.++ b - --- check that using fully qualified name works fine -fn3 : codebase.Foo -> codebase.Foo -> Text -fn3 = cases codebase.Foo.Foo, codebase.Foo.Foo -> "!!!!!!" - -> fn3 codebase.Foo.Foo codebase.Foo.Foo - --- now checking that terms fully qualified names work fine -blah.frobnicate = "Yay!" - -> Something.state (Something "hi") -> Woot.state + 1 -> Woot.frobnicate + 2 -> frobnicate Text.++ " 🎉" -> blah.frobnicate Text.++ " 🎉" -``` \ No newline at end of file diff --git a/unison-src/transcripts/fix3759.output.md b/unison-src/transcripts/fix3759.output.md deleted file mode 100644 index d4f1d9b2a1..0000000000 --- a/unison-src/transcripts/fix3759.output.md +++ /dev/null @@ -1,105 +0,0 @@ - -```unison -unique type codebase.Foo = Foo - -Woot.state : Nat -Woot.state = 42 - -Woot.frobnicate : Nat -Woot.frobnicate = 43 -``` - -```unison -unique type Oog.Foo = Foo Text - -unique ability Blah where - foo : Foo -> () - -unique type Something = { state : Text } - -oog = do - foo (Foo "hi" : Oog.Foo) - -ex = do - s = Something "hello" - state s ++ " world!" - --- check that using locally unique suffix shadows the `Foo` in codebase -fn1 : Foo -> Foo -> Nat -fn1 = cases Foo a, Foo b -> Text.size a Nat.+ Text.size b - --- check that using local fully qualified name works fine -fn2 : Oog.Foo -> Oog.Foo -> Text -fn2 = cases Foo a, Foo b -> a Text.++ b - --- check that using fully qualified name works fine -fn3 : codebase.Foo -> codebase.Foo -> Text -fn3 = cases codebase.Foo.Foo, codebase.Foo.Foo -> "!!!!!!" - -> fn3 codebase.Foo.Foo codebase.Foo.Foo - --- now checking that terms fully qualified names work fine -blah.frobnicate = "Yay!" - -> Something.state (Something "hi") -> Woot.state + 1 -> Woot.frobnicate + 2 -> frobnicate Text.++ " 🎉" -> blah.frobnicate Text.++ " 🎉" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ability Blah - type Oog.Foo - type Something - Something.state : Something -> Text - Something.state.modify : (Text ->{g} Text) - -> Something - ->{g} Something - Something.state.set : Text -> Something -> Something - blah.frobnicate : Text - ex : 'Text - fn1 : Oog.Foo -> Oog.Foo -> Nat - fn2 : Oog.Foo -> Oog.Foo -> Text - fn3 : codebase.Foo - -> codebase.Foo - -> Text - oog : '{Blah} () - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 27 | > fn3 codebase.Foo.Foo codebase.Foo.Foo - ⧩ - "!!!!!!" - - 32 | > Something.state (Something "hi") - ⧩ - "hi" - - 33 | > Woot.state + 1 - ⧩ - 43 - - 34 | > Woot.frobnicate + 2 - ⧩ - 45 - - 35 | > frobnicate Text.++ " 🎉" - ⧩ - "Yay! 🎉" - - 36 | > blah.frobnicate Text.++ " 🎉" - ⧩ - "Yay! 🎉" - -``` diff --git a/unison-src/transcripts/fix3773.md b/unison-src/transcripts/fix3773.md deleted file mode 100644 index 1a0ab22c78..0000000000 --- a/unison-src/transcripts/fix3773.md +++ /dev/null @@ -1,13 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -```unison -foo = - _ = 1 - _ = 22 - 42 - -> foo + 20 -``` \ No newline at end of file diff --git a/unison-src/transcripts/fix3773.output.md b/unison-src/transcripts/fix3773.output.md deleted file mode 100644 index 09027c3a11..0000000000 --- a/unison-src/transcripts/fix3773.output.md +++ /dev/null @@ -1,30 +0,0 @@ - -```unison -foo = - _ = 1 - _ = 22 - 42 - -> foo + 20 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo : Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 6 | > foo + 20 - ⧩ - 62 - -``` diff --git a/unison-src/transcripts/fix4172.md b/unison-src/transcripts/fix4172.md deleted file mode 100644 index 2c7d6c3b14..0000000000 --- a/unison-src/transcripts/fix4172.md +++ /dev/null @@ -1,31 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -```unison -debug a = match Debug.toText a with - None -> "" - Some (Left a) -> a - Some (Right a) -> a - -test> t1 = if bool then [Ok "Yay"] - else [Fail (debug [1,2,3])] -bool = true - -allowDebug = debug [1,2,3] -``` - -```ucm -.> add -.> test -``` - -```unison -bool = false -``` - -```ucm:error -.> update.old -.> test -``` diff --git a/unison-src/transcripts/fix4172.output.md b/unison-src/transcripts/fix4172.output.md deleted file mode 100644 index 59a5d83b87..0000000000 --- a/unison-src/transcripts/fix4172.output.md +++ /dev/null @@ -1,100 +0,0 @@ - -```unison -debug a = match Debug.toText a with - None -> "" - Some (Left a) -> a - Some (Right a) -> a - -test> t1 = if bool then [Ok "Yay"] - else [Fail (debug [1,2,3])] -bool = true - -allowDebug = debug [1,2,3] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - allowDebug : Text - bool : Boolean - debug : a -> Text - t1 : [Result] - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 6 | test> t1 = if bool then [Ok "Yay"] - - ✅ Passed Yay - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - allowDebug : Text - bool : Boolean - debug : a -> Text - t1 : [Result] - -.> test - - Cached test results (`help testcache` to learn more) - - ◉ t1 Yay - - ✅ 1 test(s) passing - - Tip: Use view t1 to view the source of a test. - -``` -```unison -bool = false -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - bool : Boolean - -``` -```ucm -.> update.old - - ⍟ I've updated these names to your new definition: - - bool : Boolean - -.> test - - ✅ - - - - - - New test results: - - ✗ t1 [1, 2, 3] - - 🚫 1 test(s) failing - - Tip: Use view t1 to view the source of a test. - -``` diff --git a/unison-src/transcripts/fix4280.md b/unison-src/transcripts/fix4280.md deleted file mode 100644 index f4cf09a011..0000000000 --- a/unison-src/transcripts/fix4280.md +++ /dev/null @@ -1,12 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison -foo.bar._baz = 5 - -bonk : Nat -bonk = - use foo.bar _baz - _baz -``` diff --git a/unison-src/transcripts/fix4280.output.md b/unison-src/transcripts/fix4280.output.md deleted file mode 100644 index 8b918418f8..0000000000 --- a/unison-src/transcripts/fix4280.output.md +++ /dev/null @@ -1,23 +0,0 @@ -```unison -foo.bar._baz = 5 - -bonk : Nat -bonk = - use foo.bar _baz - _baz -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bonk : Nat - foo.bar._baz : Nat - -``` diff --git a/unison-src/transcripts/fix4397.md b/unison-src/transcripts/fix4397.md deleted file mode 100644 index 9f81185ccf..0000000000 --- a/unison-src/transcripts/fix4397.md +++ /dev/null @@ -1,8 +0,0 @@ -```unison:error -structural type Foo f - = Foo (f ()) -unique type Baz = Baz (Foo Bar) - -unique type Bar - = Bar Baz -``` diff --git a/unison-src/transcripts/fix4397.output.md b/unison-src/transcripts/fix4397.output.md deleted file mode 100644 index e80ab21d49..0000000000 --- a/unison-src/transcripts/fix4397.output.md +++ /dev/null @@ -1,20 +0,0 @@ -```unison -structural type Foo f - = Foo (f ()) -unique type Baz = Baz (Foo Bar) - -unique type Bar - = Bar Baz -``` - -```ucm - - Loading changes detected in scratch.u. - - Kind mismatch arising from - 3 | unique type Baz = Baz (Foo Bar) - - Foo expects an argument of kind: Type -> Type; however, it - is applied to Bar which has kind: Type. - -``` diff --git a/unison-src/transcripts/fix4415.md b/unison-src/transcripts/fix4415.md deleted file mode 100644 index 5db9b53517..0000000000 --- a/unison-src/transcripts/fix4415.md +++ /dev/null @@ -1,5 +0,0 @@ - -```unison -unique type Foo = Foo -unique type sub.Foo = -``` diff --git a/unison-src/transcripts/fix4415.output.md b/unison-src/transcripts/fix4415.output.md deleted file mode 100644 index b6d881fa2a..0000000000 --- a/unison-src/transcripts/fix4415.output.md +++ /dev/null @@ -1,20 +0,0 @@ - -```unison -unique type Foo = Foo -unique type sub.Foo = -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - type sub.Foo - -``` diff --git a/unison-src/transcripts/fix4424.md b/unison-src/transcripts/fix4424.md deleted file mode 100644 index 19963478f0..0000000000 --- a/unison-src/transcripts/fix4424.md +++ /dev/null @@ -1,27 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -Some basics: - -```unison:hide -unique type Cat.Dog = Mouse Nat -unique type Rat.Dog = Bird - -countCat = cases - Cat.Dog.Mouse x -> Bird -``` - -```ucm -.> add -``` - -Now I want to add a constructor. - -```unison:hide -unique type Rat.Dog = Bird | Mouse -``` - -```ucm -.> update -``` diff --git a/unison-src/transcripts/fix4424.output.md b/unison-src/transcripts/fix4424.output.md deleted file mode 100644 index bb00ce7303..0000000000 --- a/unison-src/transcripts/fix4424.output.md +++ /dev/null @@ -1,39 +0,0 @@ -Some basics: - -```unison -unique type Cat.Dog = Mouse Nat -unique type Rat.Dog = Bird - -countCat = cases - Cat.Dog.Mouse x -> Bird -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - type Cat.Dog - type Rat.Dog - countCat : Cat.Dog -> Rat.Dog - -``` -Now I want to add a constructor. - -```unison -unique type Rat.Dog = Bird | Mouse -``` - -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Everything typechecks, so I'm saving the results... - - Done. - -``` diff --git a/unison-src/transcripts/fix4482.md b/unison-src/transcripts/fix4482.md deleted file mode 100644 index 380d693c87..0000000000 --- a/unison-src/transcripts/fix4482.md +++ /dev/null @@ -1,16 +0,0 @@ -```ucm:hide -myproj/main> builtins.merge -``` - -```unison -lib.foo0.lib.bonk1.bar = 203 -lib.foo0.baz = 1 -lib.foo1.zonk = 204 -lib.foo1.lib.bonk2.qux = 1 -mybar = bar + bar -``` - -```ucm:error -myproj/main> add -myproj/main> upgrade foo0 foo1 -``` diff --git a/unison-src/transcripts/fix4482.output.md b/unison-src/transcripts/fix4482.output.md deleted file mode 100644 index d61ddd6657..0000000000 --- a/unison-src/transcripts/fix4482.output.md +++ /dev/null @@ -1,63 +0,0 @@ -```unison -lib.foo0.lib.bonk1.bar = 203 -lib.foo0.baz = 1 -lib.foo1.zonk = 204 -lib.foo1.lib.bonk2.qux = 1 -mybar = bar + bar -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - lib.foo0.baz : Nat - lib.foo0.lib.bonk1.bar : Nat - lib.foo1.lib.bonk2.qux : Nat - lib.foo1.zonk : Nat - mybar : Nat - -``` -```ucm -myproj/main> add - - ⍟ I've added these definitions: - - lib.foo0.baz : Nat - lib.foo0.lib.bonk1.bar : Nat - lib.foo1.lib.bonk2.qux : Nat - lib.foo1.zonk : Nat - mybar : Nat - -myproj/main> upgrade foo0 foo1 - - I couldn't automatically upgrade foo0 to foo1. However, I've - added the definitions that need attention to the top of - scratch.u. - - When you're done, you can run - - upgrade.commit - - to merge your changes back into main and delete the temporary - branch. Or, if you decide to cancel the upgrade instead, you - can run - - delete.branch /upgrade-foo0-to-foo1 - - to delete the temporary branch and switch back to main. - -``` -```unison:added-by-ucm scratch.u -mybar : Nat -mybar = - use Nat + - use lib.foo0.lib.bonk1 bar - bar + bar -``` - diff --git a/unison-src/transcripts/fix4498.md b/unison-src/transcripts/fix4498.md deleted file mode 100644 index d1781e2e33..0000000000 --- a/unison-src/transcripts/fix4498.md +++ /dev/null @@ -1,16 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison -lib.dep0.bonk.foo = 5 -lib.dep0.zonk.foo = "hi" -lib.dep0.lib.dep1.foo = 6 -myterm = foo + 2 -``` - -```ucm -.> add -.> view myterm -``` - diff --git a/unison-src/transcripts/fix4498.output.md b/unison-src/transcripts/fix4498.output.md deleted file mode 100644 index e13c5f8f09..0000000000 --- a/unison-src/transcripts/fix4498.output.md +++ /dev/null @@ -1,41 +0,0 @@ -```unison -lib.dep0.bonk.foo = 5 -lib.dep0.zonk.foo = "hi" -lib.dep0.lib.dep1.foo = 6 -myterm = foo + 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - lib.dep0.bonk.foo : Nat - lib.dep0.lib.dep1.foo : Nat - lib.dep0.zonk.foo : Text - myterm : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - lib.dep0.bonk.foo : Nat - lib.dep0.lib.dep1.foo : Nat - lib.dep0.zonk.foo : Text - myterm : Nat - -.> view myterm - - myterm : Nat - myterm = - use Nat + - bonk.foo + 2 - -``` diff --git a/unison-src/transcripts/fix4515.md b/unison-src/transcripts/fix4515.md deleted file mode 100644 index 8cae1afc2b..0000000000 --- a/unison-src/transcripts/fix4515.md +++ /dev/null @@ -1,25 +0,0 @@ -```ucm:hide -myproject/main> builtins.merge -``` - -```unison -unique type Foo = Foo1 -unique type Bar = X Foo -unique type Baz = X Foo - -useBar : Bar -> Nat -useBar = cases - Bar.X _ -> 1 -``` - -```ucm -myproject/main> add -``` - -```unison -unique type Foo = Foo1 | Foo2 -``` - -```ucm -myproject/main> update -``` diff --git a/unison-src/transcripts/fix4515.output.md b/unison-src/transcripts/fix4515.output.md deleted file mode 100644 index e2f03e9d5a..0000000000 --- a/unison-src/transcripts/fix4515.output.md +++ /dev/null @@ -1,68 +0,0 @@ -```unison -unique type Foo = Foo1 -unique type Bar = X Foo -unique type Baz = X Foo - -useBar : Bar -> Nat -useBar = cases - Bar.X _ -> 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Bar - type Baz - type Foo - useBar : Bar -> Nat - -``` -```ucm -myproject/main> add - - ⍟ I've added these definitions: - - type Bar - type Baz - type Foo - useBar : Bar -> Nat - -``` -```unison -unique type Foo = Foo1 | Foo2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -```ucm -myproject/main> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Everything typechecks, so I'm saving the results... - - Done. - -``` diff --git a/unison-src/transcripts/fix4528.md b/unison-src/transcripts/fix4528.md deleted file mode 100644 index c6c540c959..0000000000 --- a/unison-src/transcripts/fix4528.md +++ /dev/null @@ -1,15 +0,0 @@ -```ucm:hide -foo/main> builtins.merge -``` - -```unison -structural type Foo = MkFoo Nat - -main : () -> Foo -main _ = MkFoo 5 -``` - -```ucm -foo/main> add -foo/main> run main -``` diff --git a/unison-src/transcripts/fix4528.output.md b/unison-src/transcripts/fix4528.output.md deleted file mode 100644 index 4715b6f47f..0000000000 --- a/unison-src/transcripts/fix4528.output.md +++ /dev/null @@ -1,34 +0,0 @@ -```unison -structural type Foo = MkFoo Nat - -main : () -> Foo -main _ = MkFoo 5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type Foo - main : 'Foo - -``` -```ucm -foo/main> add - - ⍟ I've added these definitions: - - structural type Foo - main : 'Foo - -foo/main> run main - - MkFoo 5 - -``` diff --git a/unison-src/transcripts/fix4556.md b/unison-src/transcripts/fix4556.md deleted file mode 100644 index d4775b587b..0000000000 --- a/unison-src/transcripts/fix4556.md +++ /dev/null @@ -1,22 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison -thing = 3 -foo.hello = 5 + thing -bar.hello = 5 + thing -hey = foo.hello -``` - -```ucm -.> add -``` - -```unison -thing = 2 -``` - -```ucm -.> update -``` diff --git a/unison-src/transcripts/fix4556.output.md b/unison-src/transcripts/fix4556.output.md deleted file mode 100644 index d65321a311..0000000000 --- a/unison-src/transcripts/fix4556.output.md +++ /dev/null @@ -1,65 +0,0 @@ -```unison -thing = 3 -foo.hello = 5 + thing -bar.hello = 5 + thing -hey = foo.hello -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bar.hello : Nat - foo.hello : Nat - hey : Nat - thing : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - bar.hello : Nat - foo.hello : Nat - hey : Nat - thing : Nat - -``` -```unison -thing = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - thing : Nat - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Everything typechecks, so I'm saving the results... - - Done. - -``` diff --git a/unison-src/transcripts/fix4592.md b/unison-src/transcripts/fix4592.md deleted file mode 100644 index cf272e1948..0000000000 --- a/unison-src/transcripts/fix4592.md +++ /dev/null @@ -1,8 +0,0 @@ -```ucm:hide -.> builtins.mergeio -``` - -```unison -doc = {{ {{ bug "bug" - 52 }} }} -``` diff --git a/unison-src/transcripts/fix4592.output.md b/unison-src/transcripts/fix4592.output.md deleted file mode 100644 index d1711bb55b..0000000000 --- a/unison-src/transcripts/fix4592.output.md +++ /dev/null @@ -1,18 +0,0 @@ -```unison -doc = {{ {{ bug "bug" - 52 }} }} -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - doc : Doc2 - -``` diff --git a/unison-src/transcripts/fix4618.md b/unison-src/transcripts/fix4618.md deleted file mode 100644 index 3755f10996..0000000000 --- a/unison-src/transcripts/fix4618.md +++ /dev/null @@ -1,21 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison -foo = 5 -unique type Bugs.Zonk = Bugs -``` - -```ucm -.> add -``` - -```unison -foo = 4 -unique type Bugs = -``` - -```ucm -.> update -``` diff --git a/unison-src/transcripts/fix4618.output.md b/unison-src/transcripts/fix4618.output.md deleted file mode 100644 index ee988cf57f..0000000000 --- a/unison-src/transcripts/fix4618.output.md +++ /dev/null @@ -1,60 +0,0 @@ -```unison -foo = 5 -unique type Bugs.Zonk = Bugs -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Bugs.Zonk - foo : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Bugs.Zonk - foo : Nat - -``` -```unison -foo = 4 -unique type Bugs = -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Bugs - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : Nat - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -``` diff --git a/unison-src/transcripts/fix4722.md b/unison-src/transcripts/fix4722.md deleted file mode 100644 index e674df56b6..0000000000 --- a/unison-src/transcripts/fix4722.md +++ /dev/null @@ -1,40 +0,0 @@ - -Tests an improvement to type checking related to abilities. - -`foo` below typechecks fine as long as all the branches are _checked_ -against their expected type. However, it's annoying to have to -annotate them. The old code was checking a match by just synthesizing -and subtyping, but we can instead check a match by pushing the -expected type into each case, allowing top-level annotations to act -like annotations on each case. - -```ucm:hide -.> builtins.merge -``` - -```unison -ability X a where yield : {X a} () -ability Y where y : () - -type Foo b a = One a -type Bar a - = Leaf a - | Branch (Bar a) (Bar a) - -f : (a -> ()) -> '{g, X a} () -> '{g, X a} () -> '{g, X a} () -f _ x y = y - -abra : a -> '{Y, X z} r -abra = bug "" - -cadabra : (y -> z) -> '{g, X y} r -> '{g, X z} r -cadabra = bug "" - -foo : Bar (Optional b) -> '{Y, X (Foo z ('{Y} r))} () -foo = cases - Leaf a -> match a with - None -> abra a - Some _ -> cadabra One (abra a) - Branch l r -> - f (_ -> ()) (foo l) (foo r) -``` diff --git a/unison-src/transcripts/fix4722.output.md b/unison-src/transcripts/fix4722.output.md deleted file mode 100644 index 85611e9d91..0000000000 --- a/unison-src/transcripts/fix4722.output.md +++ /dev/null @@ -1,60 +0,0 @@ - -Tests an improvement to type checking related to abilities. - -`foo` below typechecks fine as long as all the branches are _checked_ -against their expected type. However, it's annoying to have to -annotate them. The old code was checking a match by just synthesizing -and subtyping, but we can instead check a match by pushing the -expected type into each case, allowing top-level annotations to act -like annotations on each case. - -```unison -ability X a where yield : {X a} () -ability Y where y : () - -type Foo b a = One a -type Bar a - = Leaf a - | Branch (Bar a) (Bar a) - -f : (a -> ()) -> '{g, X a} () -> '{g, X a} () -> '{g, X a} () -f _ x y = y - -abra : a -> '{Y, X z} r -abra = bug "" - -cadabra : (y -> z) -> '{g, X y} r -> '{g, X z} r -cadabra = bug "" - -foo : Bar (Optional b) -> '{Y, X (Foo z ('{Y} r))} () -foo = cases - Leaf a -> match a with - None -> abra a - Some _ -> cadabra One (abra a) - Branch l r -> - f (_ -> ()) (foo l) (foo r) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Bar a - type Foo b a - ability X a - ability Y - abra : a -> '{Y, X z} r - cadabra : (y ->{h} z) -> '{g, X y} r -> '{g, X z} r - f : (a ->{h} ()) - -> '{g, X a} () - -> '{g, X a} () - -> '{g, X a} () - foo : Bar (Optional b) -> '{Y, X (Foo z ('{Y} r))} () - -``` diff --git a/unison-src/transcripts/fix4780.md b/unison-src/transcripts/fix4780.md deleted file mode 100644 index a8fad41440..0000000000 --- a/unison-src/transcripts/fix4780.md +++ /dev/null @@ -1,10 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -Just a simple test case to see whether partially applied -builtins decompile properly. - -```unison -> (+) 2 -``` diff --git a/unison-src/transcripts/fix4780.output.md b/unison-src/transcripts/fix4780.output.md deleted file mode 100644 index 9338c39660..0000000000 --- a/unison-src/transcripts/fix4780.output.md +++ /dev/null @@ -1,23 +0,0 @@ -Just a simple test case to see whether partially applied -builtins decompile properly. - -```unison -> (+) 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > (+) 2 - ⧩ - (Nat.+) 2 - -``` diff --git a/unison-src/transcripts/fix4898.md b/unison-src/transcripts/fix4898.md deleted file mode 100644 index 9bc68041b2..0000000000 --- a/unison-src/transcripts/fix4898.md +++ /dev/null @@ -1,17 +0,0 @@ -```ucm -.> builtins.merge -``` - -```unison -double : Int -> Int -double x = x + x - -redouble : Int -> Int -redouble x = double x + double x -``` - -```ucm -.> add -.> dependents double -.> delete.term 1 -``` diff --git a/unison-src/transcripts/fix4898.output.md b/unison-src/transcripts/fix4898.output.md deleted file mode 100644 index dceafc4cb3..0000000000 --- a/unison-src/transcripts/fix4898.output.md +++ /dev/null @@ -1,52 +0,0 @@ -```ucm -.> builtins.merge - - Done. - -``` -```unison -double : Int -> Int -double x = x + x - -redouble : Int -> Int -redouble x = double x + double x -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - double : Int -> Int - redouble : Int -> Int - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - double : Int -> Int - redouble : Int -> Int - -.> dependents double - - Dependents of: double - - Terms: - - 1. redouble - - Tip: Try `view 1` to see the source of any numbered item in - the above list. - -.> delete.term 1 - - Done. - -``` diff --git a/unison-src/transcripts/fix5055.md b/unison-src/transcripts/fix5055.md deleted file mode 100644 index b5c377d381..0000000000 --- a/unison-src/transcripts/fix5055.md +++ /dev/null @@ -1,15 +0,0 @@ -```ucm -test-5055/main> builtins.merge -``` - -```unison -foo.add x y = x Int.+ y - -foo.subtract x y = x Int.- y -``` - -```ucm -test-5055/main> add -test-5055/main> ls foo -test-5055/main> view 1 -``` diff --git a/unison-src/transcripts/fix5055.output.md b/unison-src/transcripts/fix5055.output.md deleted file mode 100644 index a9fe9ee5d0..0000000000 --- a/unison-src/transcripts/fix5055.output.md +++ /dev/null @@ -1,47 +0,0 @@ -```ucm -test-5055/main> builtins.merge - - Done. - -``` -```unison -foo.add x y = x Int.+ y - -foo.subtract x y = x Int.- y -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo.add : Int -> Int -> Int - foo.subtract : Int -> Int -> Int - -``` -```ucm -test-5055/main> add - - ⍟ I've added these definitions: - - foo.add : Int -> Int -> Int - foo.subtract : Int -> Int -> Int - -test-5055/main> ls foo - - 1. add (Int -> Int -> Int) - 2. subtract (Int -> Int -> Int) - -test-5055/main> view 1 - - foo.add : Int -> Int -> Int - foo.add x y = - use Int + - x + y - -``` diff --git a/unison-src/transcripts/fix614.md b/unison-src/transcripts/fix614.md deleted file mode 100644 index 3e0ad6c76b..0000000000 --- a/unison-src/transcripts/fix614.md +++ /dev/null @@ -1,54 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -This transcript demonstrates that Unison forces actions in blocks to have a return type of `()`. - -This works, as expected: - -```unison -structural ability Stream a where emit : a -> () - -ex1 = do - Stream.emit 1 - Stream.emit 2 - 42 -``` - -```ucm:hide -.> add -``` - -This does not typecheck, we've accidentally underapplied `Stream.emit`: - -```unison:error -ex2 = do - Stream.emit - 42 -``` - -We can explicitly ignore an unused result like so: - -```unison -ex3 = do - _ = Stream.emit - () -``` - -Using a helper function like `void` also works fine: - -```unison -void x = () - -ex4 = - void [1,2,3] - () -``` - -One more example: - -```unison:error -ex4 = - [1,2,3] -- no good - () -``` diff --git a/unison-src/transcripts/fix614.output.md b/unison-src/transcripts/fix614.output.md deleted file mode 100644 index b679698eb6..0000000000 --- a/unison-src/transcripts/fix614.output.md +++ /dev/null @@ -1,120 +0,0 @@ -This transcript demonstrates that Unison forces actions in blocks to have a return type of `()`. - -This works, as expected: - -```unison -structural ability Stream a where emit : a -> () - -ex1 = do - Stream.emit 1 - Stream.emit 2 - 42 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability Stream a - ex1 : '{Stream Nat} Nat - -``` -This does not typecheck, we've accidentally underapplied `Stream.emit`: - -```unison -ex2 = do - Stream.emit - 42 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found a value of type: a ->{Stream a} Unit - where I expected to find: Unit - - 2 | Stream.emit - 3 | 42 - - Hint: Actions within a block must have type Unit. - Use _ = to ignore a result. - -``` -We can explicitly ignore an unused result like so: - -```unison -ex3 = do - _ = Stream.emit - () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex3 : '() - -``` -Using a helper function like `void` also works fine: - -```unison -void x = () - -ex4 = - void [1,2,3] - () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex4 : () - void : x -> () - -``` -One more example: - -```unison -ex4 = - [1,2,3] -- no good - () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found a value of type: [Nat] - where I expected to find: Unit - - 2 | [1,2,3] -- no good - 3 | () - - from right here: - - 2 | [1,2,3] -- no good - - Hint: Actions within a block must have type Unit. - Use _ = to ignore a result. - -``` diff --git a/unison-src/transcripts/fix689.md b/unison-src/transcripts/fix689.md deleted file mode 100644 index b22106eed4..0000000000 --- a/unison-src/transcripts/fix689.md +++ /dev/null @@ -1,13 +0,0 @@ -Tests the fix for https://github.com/unisonweb/unison/issues/689 - -```ucm:hide -.> builtins.merge -``` - -``` unison -structural ability SystemTime where - systemTime : ##Nat - -tomorrow = '(SystemTime.systemTime + 24 * 60 * 60) -``` - diff --git a/unison-src/transcripts/fix689.output.md b/unison-src/transcripts/fix689.output.md deleted file mode 100644 index 9bb9dcc064..0000000000 --- a/unison-src/transcripts/fix689.output.md +++ /dev/null @@ -1,23 +0,0 @@ -Tests the fix for https://github.com/unisonweb/unison/issues/689 - -```unison -structural ability SystemTime where - systemTime : ##Nat - -tomorrow = '(SystemTime.systemTime + 24 * 60 * 60) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability SystemTime - tomorrow : '{SystemTime} Nat - -``` diff --git a/unison-src/transcripts/fix693.md b/unison-src/transcripts/fix693.md deleted file mode 100644 index bcb714af97..0000000000 --- a/unison-src/transcripts/fix693.md +++ /dev/null @@ -1,57 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -```unison -structural ability X t where - x : t -> a -> a - -structural ability Abort where - abort : a -``` - -```ucm -.> add -``` - -This code should not type check. The match on X.x ought to introduce a -skolem variable `a` such that `c : a` and the continuation has type -`a ->{X} b`. Thus, `handle c with h : Optional a`, which is not the -correct result type. - -```unison:error -h0 : Request {X t} b -> Optional b -h0 req = match req with - { X.x _ c -> _ } -> handle c with h0 - { d } -> Some d -``` - -This code should not check because `t` does not match `b`. - -```unison:error -h1 : Request {X t} b -> Optional b -h1 req = match req with - { X.x t _ -> _ } -> handle t with h1 - { d } -> Some d -``` - -This code should not check for reasons similar to the first example, -but with the continuation rather than a parameter. - -```unison:error -h2 : Request {Abort} r -> r -h2 req = match req with - { Abort.abort -> k } -> handle k 5 with h2 - { r } -> r -``` - -This should work fine. - -```unison -h3 : Request {X b, Abort} b -> Optional b -h3 = cases - { r } -> Some r - { Abort.abort -> _ } -> None - { X.x b _ -> _ } -> Some b -``` diff --git a/unison-src/transcripts/fix693.output.md b/unison-src/transcripts/fix693.output.md deleted file mode 100644 index 6d869d63a1..0000000000 --- a/unison-src/transcripts/fix693.output.md +++ /dev/null @@ -1,137 +0,0 @@ - -```unison -structural ability X t where - x : t -> a -> a - -structural ability Abort where - abort : a -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability Abort - structural ability X t - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - structural ability Abort - structural ability X t - -``` -This code should not type check. The match on X.x ought to introduce a -skolem variable `a` such that `c : a` and the continuation has type -`a ->{X} b`. Thus, `handle c with h : Optional a`, which is not the -correct result type. - -```unison -h0 : Request {X t} b -> Optional b -h0 req = match req with - { X.x _ c -> _ } -> handle c with h0 - { d } -> Some d -``` - -```ucm - - Loading changes detected in scratch.u. - - Each case of a match / with expression need to have the same - type. - - Here, one is: Optional b - and another is: Optional a - - - 3 | { X.x _ c -> _ } -> handle c with h0 - - from these spots, respectively: - - 1 | h0 : Request {X t} b -> Optional b - - -``` -This code should not check because `t` does not match `b`. - -```unison -h1 : Request {X t} b -> Optional b -h1 req = match req with - { X.x t _ -> _ } -> handle t with h1 - { d } -> Some d -``` - -```ucm - - Loading changes detected in scratch.u. - - Each case of a match / with expression need to have the same - type. - - Here, one is: Optional b - and another is: Optional t - - - 3 | { X.x t _ -> _ } -> handle t with h1 - - from these spots, respectively: - - 1 | h1 : Request {X t} b -> Optional b - - -``` -This code should not check for reasons similar to the first example, -but with the continuation rather than a parameter. - -```unison -h2 : Request {Abort} r -> r -h2 req = match req with - { Abort.abort -> k } -> handle k 5 with h2 - { r } -> r -``` - -```ucm - - Loading changes detected in scratch.u. - - The 1st argument to `k` - - has type: Nat - but I expected: a - - 3 | { Abort.abort -> k } -> handle k 5 with h2 - - -``` -This should work fine. - -```unison -h3 : Request {X b, Abort} b -> Optional b -h3 = cases - { r } -> Some r - { Abort.abort -> _ } -> None - { X.x b _ -> _ } -> Some b -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - h3 : Request {X b, Abort} b -> Optional b - -``` diff --git a/unison-src/transcripts/fix845.md b/unison-src/transcripts/fix845.md deleted file mode 100644 index 4e361ca7cc..0000000000 --- a/unison-src/transcripts/fix845.md +++ /dev/null @@ -1,57 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -Add `List.zonk` to the codebase: - -```unison -List.zonk : [a] -> [a] -List.zonk xs = xs - -Text.zonk : Text -> Text -Text.zonk txt = txt ++ "!! " -``` - -```ucm:hide -.> add -``` - -Now, typecheck a file with a reference to `Blah.zonk` (which doesn't exist in the codebase). This should fail: - -```unison:error --- should not typecheck as there's no `Blah.zonk` in the codebase -> Blah.zonk [1,2,3] -``` - -Here's another example, just checking that TDNR works for definitions in the same file: - -```unison -foo.bar.baz = 42 - -qux.baz = "hello" - -ex = baz ++ ", world!" - -> ex -``` - -Here's another example, checking that TDNR works when multiple codebase definitions have matching names: - -```unison -ex = zonk "hi" - -> ex -``` - -Last example, showing that TDNR works when there are multiple matching names in both the file and the codebase: - -```unison -woot.zonk = "woot" -woot2.zonk = 9384 - -ex = zonk "hi" -- should resolve to Text.zonk, from the codebase - ++ zonk -- should resolve to the local `woot.zonk` from this file - -> ex -``` diff --git a/unison-src/transcripts/fix845.output.md b/unison-src/transcripts/fix845.output.md deleted file mode 100644 index fbdc9fc732..0000000000 --- a/unison-src/transcripts/fix845.output.md +++ /dev/null @@ -1,148 +0,0 @@ - -Add `List.zonk` to the codebase: - -```unison -List.zonk : [a] -> [a] -List.zonk xs = xs - -Text.zonk : Text -> Text -Text.zonk txt = txt ++ "!! " -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - List.zonk : [a] -> [a] - Text.zonk : Text -> Text - -``` -Now, typecheck a file with a reference to `Blah.zonk` (which doesn't exist in the codebase). This should fail: - -```unison --- should not typecheck as there's no `Blah.zonk` in the codebase -> Blah.zonk [1,2,3] -``` - -```ucm - - Loading changes detected in scratch.u. - - I couldn't figure out what Blah.zonk refers to here: - - 2 | > Blah.zonk [1,2,3] - - I think its type should be: - - [Nat] -> o - - Some common causes of this error include: - * Your current namespace is too deep to contain the - definition in its subtree - * The definition is part of a library which hasn't been - added to this project - * You have a typo in the name - -``` -Here's another example, just checking that TDNR works for definitions in the same file: - -```unison -foo.bar.baz = 42 - -qux.baz = "hello" - -ex = baz ++ ", world!" - -> ex -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex : Text - foo.bar.baz : Nat - qux.baz : Text - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 7 | > ex - ⧩ - "hello, world!" - -``` -Here's another example, checking that TDNR works when multiple codebase definitions have matching names: - -```unison -ex = zonk "hi" - -> ex -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex : Text - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 3 | > ex - ⧩ - "hi!! " - -``` -Last example, showing that TDNR works when there are multiple matching names in both the file and the codebase: - -```unison -woot.zonk = "woot" -woot2.zonk = 9384 - -ex = zonk "hi" -- should resolve to Text.zonk, from the codebase - ++ zonk -- should resolve to the local `woot.zonk` from this file - -> ex -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ex : Text - woot.zonk : Text - woot2.zonk : Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 7 | > ex - ⧩ - "hi!! woot" - -``` diff --git a/unison-src/transcripts/fix849.md b/unison-src/transcripts/fix849.md deleted file mode 100644 index 4d111f9cc1..0000000000 --- a/unison-src/transcripts/fix849.md +++ /dev/null @@ -1,12 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -See [this ticket](https://github.com/unisonweb/unison/issues/849). - -```unison -x = 42 - -> x -``` diff --git a/unison-src/transcripts/fix849.output.md b/unison-src/transcripts/fix849.output.md deleted file mode 100644 index 33720e550e..0000000000 --- a/unison-src/transcripts/fix849.output.md +++ /dev/null @@ -1,29 +0,0 @@ - -See [this ticket](https://github.com/unisonweb/unison/issues/849). - -```unison -x = 42 - -> x -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - x : Nat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 3 | > x - ⧩ - 42 - -``` diff --git a/unison-src/transcripts/fix942.md b/unison-src/transcripts/fix942.md deleted file mode 100644 index 5c12cb8c06..0000000000 --- a/unison-src/transcripts/fix942.md +++ /dev/null @@ -1,37 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -First we add some code: - -```unison -x = 0 -y = x + 1 -z = y + 2 -``` - -```ucm -.> add -``` - -Now we edit `x` to be `7`, which should make `z` equal `10`: - -```unison -x = 7 -``` - -```ucm -.> update -.> view x y z -``` - -Uh oh! `z` is still referencing the old version. Just to confirm: - -```unison -test> t1 = if z == 3 then [Fail "nooo!!!"] else [Ok "great"] -``` - -```ucm -.> add -.> test -``` diff --git a/unison-src/transcripts/fix942.output.md b/unison-src/transcripts/fix942.output.md deleted file mode 100644 index fd5f055d22..0000000000 --- a/unison-src/transcripts/fix942.output.md +++ /dev/null @@ -1,125 +0,0 @@ -First we add some code: - -```unison -x = 0 -y = x + 1 -z = y + 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - x : Nat - y : Nat - z : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - x : Nat - y : Nat - z : Nat - -``` -Now we edit `x` to be `7`, which should make `z` equal `10`: - -```unison -x = 7 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - x : Nat - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Everything typechecks, so I'm saving the results... - - Done. - -.> view x y z - - x : Nat - x = 7 - - y : Nat - y = - use Nat + - x + 1 - - z : Nat - z = - use Nat + - y + 2 - -``` -Uh oh! `z` is still referencing the old version. Just to confirm: - -```unison -test> t1 = if z == 3 then [Fail "nooo!!!"] else [Ok "great"] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - t1 : [Result] - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | test> t1 = if z == 3 then [Fail "nooo!!!"] else [Ok "great"] - - ✅ Passed great - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - t1 : [Result] - -.> test - - Cached test results (`help testcache` to learn more) - - ◉ t1 great - - ✅ 1 test(s) passing - - Tip: Use view t1 to view the source of a test. - -``` diff --git a/unison-src/transcripts/fix987.md b/unison-src/transcripts/fix987.md deleted file mode 100644 index 0db69b1d78..0000000000 --- a/unison-src/transcripts/fix987.md +++ /dev/null @@ -1,37 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -First we'll add a definition: - -```unison -structural ability DeathStar where - attack : Text -> () - -spaceAttack1 x = - y = attack "saturn" - z = attack "neptune" - "All done" -``` - -Add it to the codebase: - -```ucm -.> add -``` - -Now we'll try to add a different definition that runs the actions in a different order. This should work fine: - -```unison -spaceAttack2 x = - z = attack "neptune" - y = attack "saturn" - "All done" -``` - -```ucm -.> add -``` - -Previously, this would fail because the hashing algorithm was being given one big let rec block whose binding order was normalized. diff --git a/unison-src/transcripts/fix987.output.md b/unison-src/transcripts/fix987.output.md deleted file mode 100644 index 5f6119c225..0000000000 --- a/unison-src/transcripts/fix987.output.md +++ /dev/null @@ -1,69 +0,0 @@ - -First we'll add a definition: - -```unison -structural ability DeathStar where - attack : Text -> () - -spaceAttack1 x = - y = attack "saturn" - z = attack "neptune" - "All done" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability DeathStar - spaceAttack1 : x ->{DeathStar} Text - -``` -Add it to the codebase: - -```ucm -.> add - - ⍟ I've added these definitions: - - structural ability DeathStar - spaceAttack1 : x ->{DeathStar} Text - -``` -Now we'll try to add a different definition that runs the actions in a different order. This should work fine: - -```unison -spaceAttack2 x = - z = attack "neptune" - y = attack "saturn" - "All done" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - spaceAttack2 : x ->{DeathStar} Text - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - spaceAttack2 : x ->{DeathStar} Text - -``` -Previously, this would fail because the hashing algorithm was being given one big let rec block whose binding order was normalized. diff --git a/unison-src/transcripts/formatter.md b/unison-src/transcripts/formatter.md deleted file mode 100644 index 3848c0ba99..0000000000 --- a/unison-src/transcripts/formatter.md +++ /dev/null @@ -1,102 +0,0 @@ -```ucm:hide -.> builtins.mergeio -``` - -```unison:hide -{{ # Doc -This is a *doc*! - -term link {x} - -type link {type Optional} - -}} -x : - Nat - -> Nat -x y = - x = 1 + 1 - x + y --- Should keep comments after - --- symbolyDefinition -(<|>) : Nat -> Nat -> (Nat, Nat) -(<|>) a b = (a, b) - -symbolyEndOfBlock = - x = 1 - (+:) - - --- Test for a previous regression that added extra brackets. -oneLiner = {{ one liner }} --- After - --- Before -explicit.doc = {{ -# Here's a top-level doc - -With a paragraph - -Or two -}} --- After - -{{ A doc before an ability }} -ability Thing where - more : Nat -> Text -> Nat - doThing : Nat -> Int - - -{{ Ability with single constructor }} -structural ability Ask a where - ask : {Ask a} a - --- Regression test for: https://github.com/unisonweb/unison/issues/4666 -provide : a -> '{Ask a} r -> r -provide a action = - h = cases - {ask -> resume} -> handle resume a with h - {r} -> r - handle !action with h - -{{ -A Doc before a type -}} -structural type Optional a = More Text - | Some - | Other a - | None Nat - -{{ A doc before a type with no type-vars }} -type Two = One Nat | Two Text - --- Regression for https://github.com/unisonweb/unison/issues/4669 - -multilineBold = {{ - -**This paragraph is really really really really really long and spans multiple lines -with a strike-through block** - -_This paragraph is really really really really really long and spans multiple lines -with a strike-through block_ - -~This paragraph is really really really really really long and spans multiple lines -with a strike-through block~ - -}} -``` - -```ucm -.> debug.format -``` - -Formatter should leave things alone if the file doesn't typecheck. - -```unison:error -brokenDoc = {{ hello }} + 1 -``` - -```ucm -.> debug.format -``` diff --git a/unison-src/transcripts/formatter.output.md b/unison-src/transcripts/formatter.output.md deleted file mode 100644 index 95af2a545d..0000000000 --- a/unison-src/transcripts/formatter.output.md +++ /dev/null @@ -1,205 +0,0 @@ -```unison -{{ # Doc -This is a *doc*! - -term link {x} - -type link {type Optional} - -}} -x : - Nat - -> Nat -x y = - x = 1 + 1 - x + y --- Should keep comments after - --- symbolyDefinition -(<|>) : Nat -> Nat -> (Nat, Nat) -(<|>) a b = (a, b) - -symbolyEndOfBlock = - x = 1 - (+:) - - --- Test for a previous regression that added extra brackets. -oneLiner = {{ one liner }} --- After - --- Before -explicit.doc = {{ -# Here's a top-level doc - -With a paragraph - -Or two -}} --- After - -{{ A doc before an ability }} -ability Thing where - more : Nat -> Text -> Nat - doThing : Nat -> Int - - -{{ Ability with single constructor }} -structural ability Ask a where - ask : {Ask a} a - --- Regression test for: https://github.com/unisonweb/unison/issues/4666 -provide : a -> '{Ask a} r -> r -provide a action = - h = cases - {ask -> resume} -> handle resume a with h - {r} -> r - handle !action with h - -{{ -A Doc before a type -}} -structural type Optional a = More Text - | Some - | Other a - | None Nat - -{{ A doc before a type with no type-vars }} -type Two = One Nat | Two Text - --- Regression for https://github.com/unisonweb/unison/issues/4669 - -multilineBold = {{ - -**This paragraph is really really really really really long and spans multiple lines -with a strike-through block** - -_This paragraph is really really really really really long and spans multiple lines -with a strike-through block_ - -~This paragraph is really really really really really long and spans multiple lines -with a strike-through block~ - -}} -``` - -```ucm -.> debug.format - -``` -```unison:added-by-ucm scratch.u -x.doc = - {{ - # Doc This is a **doc**! - - term link {x} - - type link {type Optional} - }} -x : Nat -> Nat -x y = - use Nat + - x = 1 + 1 - x + y --- Should keep comments after - --- symbolyDefinition -(<|>) : Nat -> Nat -> (Nat, Nat) -a <|> b = (a, b) - -symbolyEndOfBlock = - x = 1 - (+:) - - --- Test for a previous regression that added extra brackets. -oneLiner = {{ one liner }} --- After - --- Before -explicit.doc = - {{ - # Here's a top-level doc - - With a paragraph - - Or two - }} --- After - -Thing.doc = {{ A doc before an ability }} -ability Thing where - more : Nat -> Text ->{Thing} Nat - doThing : Nat ->{Thing} Int - - -Ask.doc = {{ Ability with single constructor }} -structural ability Ask a where ask : {Ask a} a - --- Regression test for: https://github.com/unisonweb/unison/issues/4666 -provide : a -> '{Ask a} r -> r -provide a action = - h = cases - { ask -> resume } -> handle resume a with h - { r } -> r - handle !action with h - -Optional.doc = {{ A Doc before a type }} -structural type Optional a = More Text | Some | Other a | None Nat - -Two.doc = {{ A doc before a type with no type-vars }} -type Two = One Nat | Two Text - --- Regression for https://github.com/unisonweb/unison/issues/4669 - -multilineBold = - {{ - **This paragraph is really really really really really long and spans - multiple lines with a strike-through block** - - __This paragraph is really really really really really long and spans - multiple lines with a strike-through block__ - - ~~This paragraph is really really really really really long and spans - multiple lines with a strike-through block~~ - }} -``` - -Formatter should leave things alone if the file doesn't typecheck. - -```unison -brokenDoc = {{ hello }} + 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I couldn't figure out what + refers to here: - - 1 | brokenDoc = {{ hello }} + 1 - - The name + is ambiguous. I tried to resolve it by type but no - term with that name would pass typechecking. I think its type - should be: - - Doc2 -> Nat -> o - - If that's not what you expected, you may have a type error - somewhere else in your code. - Help me out by using a more specific name here or adding a - type annotation. - - I found some terms in scope with matching names but different - types. If one of these is what you meant, try using its full - name: - - (Float.+) : Float -> Float -> Float - (Int.+) : Int -> Int -> Int - (Nat.+) : Nat -> Nat -> Nat - -``` -```ucm -.> debug.format - -``` diff --git a/unison-src/transcripts/fuzzy-options.md b/unison-src/transcripts/fuzzy-options.md deleted file mode 100644 index 13d953c938..0000000000 --- a/unison-src/transcripts/fuzzy-options.md +++ /dev/null @@ -1,45 +0,0 @@ -# Test that the options selector for fuzzy finding is working as expected for different argument types. - -If an argument is required but doesn't have a fuzzy resolver, the command should just print the help. - - -```ucm:error --- The second argument of move.term is a 'new-name' and doesn't have a fuzzy resolver -.> move.term -``` - -If a fuzzy resolver doesn't have any options available it should print a message instead of -opening an empty fuzzy-select. - -```ucm:error -.empty> view -``` - - -```unison:hide -optionOne = 1 - -nested.optionTwo = 2 -``` - -Definition args - -```ucm -.> add -.> debug.fuzzy-options view _ -``` - - -Namespace args - -```ucm -.> add -.> debug.fuzzy-options find-in _ -``` - -Project Branch args - -```ucm -myproject/main> branch mybranch -.> debug.fuzzy-options switch _ -``` diff --git a/unison-src/transcripts/fuzzy-options.output.md b/unison-src/transcripts/fuzzy-options.output.md deleted file mode 100644 index f48f5cd6fb..0000000000 --- a/unison-src/transcripts/fuzzy-options.output.md +++ /dev/null @@ -1,82 +0,0 @@ -# Test that the options selector for fuzzy finding is working as expected for different argument types. - -If an argument is required but doesn't have a fuzzy resolver, the command should just print the help. - - -```ucm --- The second argument of move.term is a 'new-name' and doesn't have a fuzzy resolver -.> move.term - -`move.term foo bar` renames `foo` to `bar`. - -``` -If a fuzzy resolver doesn't have any options available it should print a message instead of -opening an empty fuzzy-select. - -```ucm - ☝️ The namespace .empty is empty. - -.empty> view - -⚠️ - -Sorry, I was expecting an argument for the definition to view, and I couldn't find any to suggest to you. 😅 - -``` -```unison -optionOne = 1 - -nested.optionTwo = 2 -``` - -Definition args - -```ucm - ☝️ The namespace . is empty. - -.> add - - ⍟ I've added these definitions: - - nested.optionTwo : ##Nat - optionOne : ##Nat - -.> debug.fuzzy-options view _ - - Select a definition to view: - * optionOne - * nested.optionTwo - -``` -Namespace args - -```ucm -.> add - - ⊡ Ignored previously added definitions: nested.optionTwo - optionOne - -.> debug.fuzzy-options find-in _ - - Select a namespace: - * nested - -``` -Project Branch args - -```ucm -myproject/main> branch mybranch - - Done. I've created the mybranch branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /mybranch`. - -.> debug.fuzzy-options switch _ - - Select a project or branch to switch to: - * myproject/main - * myproject/mybranch - * myproject - -``` diff --git a/unison-src/transcripts/generic-parse-errors.md b/unison-src/transcripts/generic-parse-errors.md deleted file mode 100644 index b22b2f039a..0000000000 --- a/unison-src/transcripts/generic-parse-errors.md +++ /dev/null @@ -1,26 +0,0 @@ -Just a bunch of random parse errors to test the error formatting. - -```unison:error -x = - foo.123 -``` - -```unison:error -namespace.blah = 1 -``` - -```unison:error -x = 1 ] -``` - -```unison:error -x = a.#abc -``` - -```unison:error -x = "hi -``` - -```unison:error -y : a -``` diff --git a/unison-src/transcripts/generic-parse-errors.output.md b/unison-src/transcripts/generic-parse-errors.output.md deleted file mode 100644 index b055ba9689..0000000000 --- a/unison-src/transcripts/generic-parse-errors.output.md +++ /dev/null @@ -1,107 +0,0 @@ -Just a bunch of random parse errors to test the error formatting. - -```unison -x = - foo.123 -``` - -```ucm - - Loading changes detected in scratch.u. - - I got confused here: - - 2 | foo.123 - - - I was surprised to find a 1 here. - I was expecting one of these instead: - - * end of input - * hash (ex: #af3sj3) - * identifier (ex: abba1, snake_case, .foo.bar#xyz, .foo.++#xyz, or 🌻) - -``` -```unison -namespace.blah = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - The identifier used here isn't allowed to be a reserved keyword: - - 1 | namespace.blah = 1 - - -``` -```unison -x = 1 ] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found a closing ']' here without a matching '['. - - 1 | x = 1 ] - - -``` -```unison -x = a.#abc -``` - -```ucm - - Loading changes detected in scratch.u. - - I got confused here: - - 1 | x = a.#abc - - - I was surprised to find a '.' here. - -``` -```unison -x = "hi -``` - -```ucm - - Loading changes detected in scratch.u. - - I got confused here: - - 2 | - - I was surprised to find an end of input here. - I was expecting one of these instead: - - * " - * \s - * literal character - -``` -```unison -y : a -``` - -```ucm - - Loading changes detected in scratch.u. - - I got confused here: - - 2 | - - I was surprised to find an end of section here. - I was expecting one of these instead: - - * -> - * newline or semicolon - -``` diff --git a/unison-src/transcripts/hello.md b/unison-src/transcripts/hello.md index 187eb86ec3..566e6b5694 100644 --- a/unison-src/transcripts/hello.md +++ b/unison-src/transcripts/hello.md @@ -1,8 +1,7 @@ - # Hello! -```ucm:hide -.> builtins.merge +``` ucm :hide +scratch/main> builtins.merge ``` This markdown file is also a Unison transcript file. Transcript files are an easy way to create self-documenting Unison programs, libraries, and tutorials. @@ -26,15 +25,15 @@ Take a look at [the elaborated output](hello.output.md) to see what this file lo In the `unison` fenced block, you can give an (optional) file name (defaults to `scratch.u`), like so: -```unison myfile.u +``` unison myfile.u x = 42 ``` Let's go ahead and add that to the codebase, then make sure it's there: -```ucm -.> add -.> view x +``` ucm +scratch/main> add +scratch/main> view x ``` If `view` returned no results, the transcript would fail at this point. @@ -43,19 +42,19 @@ If `view` returned no results, the transcript would fail at this point. You may not always want to view the output of typechecking and evaluation every time, in which case, you can add `:hide` to the block. For instance: -```unison:hide +``` unison :hide y = 99 ``` This works for `ucm` blocks as well. -```ucm:hide -.> rename.term x answerToUltimateQuestionOfLife +``` ucm :hide +scratch/main> rename.term x answerToUltimateQuestionOfLife ``` -Doing `unison:hide:all` hides the block altogether, both input and output - this is useful for doing behind-the-scenes control of `ucm`'s state. +Doing `unison :hide-all` hides the block altogether, both input and output - this is useful for doing behind-the-scenes control of `ucm`'s state. -```unison:hide:all +``` unison :hide-all > [: you won't see me :] ``` @@ -63,7 +62,7 @@ Doing `unison:hide:all` hides the block altogether, both input and output - this Sometimes, you have a block which you are _expecting_ to fail, perhaps because you're illustrating how something would be a type error. Adding `:error` to the block will check for this. For instance, this program has a type error: -```unison:error +``` unison :error hmm : .builtin.Nat hmm = "Not, in fact, a number" ``` diff --git a/unison-src/transcripts/hello.output.md b/unison-src/transcripts/hello.output.md index 8104114e03..9ab978d5ce 100644 --- a/unison-src/transcripts/hello.output.md +++ b/unison-src/transcripts/hello.output.md @@ -1,101 +1,98 @@ +# Hello\! -# Hello! +``` ucm :hide +scratch/main> builtins.merge +``` This markdown file is also a Unison transcript file. Transcript files are an easy way to create self-documenting Unison programs, libraries, and tutorials. The format is just a regular markdown file with some fenced code blocks that are typechecked and elaborated by `ucm`. For example, you can call this transcript via: -``` +``` $ ucm transcript hello.md - ``` This runs it on a freshly generated empty codebase. Alternately `ucm transcript.fork --codebase /path/to/code hello.md` runs the transcript on a freshly generated copy of the provided codebase. Do `ucm help` to learn more about usage. Fenced code blocks of type `unison` and `ucm` are treated specially: -* `ucm` blocks are executed, and the output is interleaved into the output markdown file after each command, replacing the original `ucm` block. -* `unison` blocks are typechecked, and a `ucm` block with the output of typechecking and execution of the file is inserted immediately afterwards. + - `ucm` blocks are executed, and the output is interleaved into the output markdown file after each command, replacing the original `ucm` block. + - `unison` blocks are typechecked, and a `ucm` block with the output of typechecking and execution of the file is inserted immediately afterwards. Take a look at [the elaborated output](hello.output.md) to see what this file looks like after passing through the transcript runner. -## Let's try it out!! +## Let's try it out\!\! In the `unison` fenced block, you can give an (optional) file name (defaults to `scratch.u`), like so: -```unison ---- -title: myfile.u ---- +``` unison myfile.u x = 42 - ``` - -```ucm - +``` ucm :added-by-ucm Loading changes detected in myfile.u. I found and typechecked these definitions in myfile.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: x : Nat - ``` + Let's go ahead and add that to the codebase, then make sure it's there: -```ucm -.> add +``` ucm +scratch/main> add ⍟ I've added these definitions: - + x : Nat -.> view x +scratch/main> view x x : Nat x = 42 - ``` + If `view` returned no results, the transcript would fail at this point. ## Hiding output You may not always want to view the output of typechecking and evaluation every time, in which case, you can add `:hide` to the block. For instance: -```unison +``` unison :hide y = 99 ``` This works for `ucm` blocks as well. -Doing `unison:hide:all` hides the block altogether, both input and output - this is useful for doing behind-the-scenes control of `ucm`'s state. +``` ucm :hide +scratch/main> rename.term x answerToUltimateQuestionOfLife +``` + +Doing `unison :hide-all` hides the block altogether, both input and output - this is useful for doing behind-the-scenes control of `ucm`'s state. ## Expecting failures -Sometimes, you have a block which you are _expecting_ to fail, perhaps because you're illustrating how something would be a type error. Adding `:error` to the block will check for this. For instance, this program has a type error: +Sometimes, you have a block which you are *expecting* to fail, perhaps because you're illustrating how something would be a type error. Adding `:error` to the block will check for this. For instance, this program has a type error: -```unison +``` unison :error hmm : .builtin.Nat hmm = "Not, in fact, a number" ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found a value of type: Text where I expected to find: Nat - + 1 | hmm : .builtin.Nat 2 | hmm = "Not, in fact, a number" - + from right here: - - 2 | hmm = "Not, in fact, a number" - + 2 | hmm = "Not, in fact, a number" ``` diff --git a/unison-src/transcripts/higher-rank.md b/unison-src/transcripts/higher-rank.md deleted file mode 100644 index 7fe63de504..0000000000 --- a/unison-src/transcripts/higher-rank.md +++ /dev/null @@ -1,82 +0,0 @@ - -This transcript does some testing of higher-rank types. Regression tests related to higher-rank types can be added here. - -```ucm:hide -.> alias.type ##Nat Nat -.> alias.type ##Text Text -.> alias.type ##IO IO -``` - -In this example, a higher-rank function is defined, `f`. No annotation is needed at the call-site of `f`, because the lambda is being checked against the polymorphic type `forall a . a -> a`, rather than inferred: - -```unison -f : (forall a . a -> a) -> (Nat, Text) -f id = (id 1, id "hi") - -> f (x -> x) -``` - -Another example, involving abilities. Here the ability-polymorphic function is instantiated with two different ability lists, `{}` and `{IO}`: - -```unison -f : (forall a g . '{g} a -> '{g} a) -> () -> () -f id _ = - _ = (id ('1 : '{} Nat), id ('("hi") : '{IO} Text)) - () -``` - -Here's an example, showing that polymorphic functions can be fields of a constructor, and the functions remain polymorphic even when the field is bound to a name during pattern matching: - -```unison -unique type Functor f = Functor (forall a b . (a -> b) -> f a -> f b) - -Functor.map : Functor f -> (forall a b . (a -> b) -> f a -> f b) -Functor.map = cases Functor f -> f - -Functor.blah : Functor f -> () -Functor.blah = cases Functor f -> - g : forall a b . (a -> b) -> f a -> f b - g = f - () -``` - -This example is similar, but involves abilities: - -```unison -unique ability Remote t where doRemoteStuff : t () -unique type Loc = Loc (forall t a . '{Remote t} a ->{Remote t} t a) - -Loc.blah : Loc -> () -Loc.blah = cases Loc f -> - f0 : '{Remote tx} ax ->{Remote tx} tx ax - f0 = f - () - --- In this case, no annotation is needed since the lambda --- is checked against a polymorphic type -Loc.transform : (forall t a . '{Remote t} a -> '{Remote t} a) - -> Loc -> Loc -Loc.transform nt = cases Loc f -> Loc (a -> f (nt a)) - --- In this case, the annotation is needed since f' is inferred --- on its own it won't infer the higher-rank type -Loc.transform2 : (forall t a . '{Remote t} a -> '{Remote t} a) - -> Loc -> Loc -Loc.transform2 nt = cases Loc f -> - f' : forall t a . '{Remote t} a ->{Remote t} t a - f' a = f (nt a) - Loc f' -``` - -## Types with polymorphic fields - -```unison:hide -structural type HigherRanked = HigherRanked (forall a. a -> a) -``` - -We should be able to add and view records with higher-rank fields. - -```ucm -.higher_ranked> add -.higher_ranked> view HigherRanked -``` diff --git a/unison-src/transcripts/higher-rank.output.md b/unison-src/transcripts/higher-rank.output.md deleted file mode 100644 index a64a48ae39..0000000000 --- a/unison-src/transcripts/higher-rank.output.md +++ /dev/null @@ -1,156 +0,0 @@ - -This transcript does some testing of higher-rank types. Regression tests related to higher-rank types can be added here. - -In this example, a higher-rank function is defined, `f`. No annotation is needed at the call-site of `f`, because the lambda is being checked against the polymorphic type `forall a . a -> a`, rather than inferred: - -```unison -f : (forall a . a -> a) -> (Nat, Text) -f id = (id 1, id "hi") - -> f (x -> x) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - f : (∀ a. a ->{g} a) ->{g} (Nat, Text) - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 4 | > f (x -> x) - ⧩ - (1, "hi") - -``` -Another example, involving abilities. Here the ability-polymorphic function is instantiated with two different ability lists, `{}` and `{IO}`: - -```unison -f : (forall a g . '{g} a -> '{g} a) -> () -> () -f id _ = - _ = (id ('1 : '{} Nat), id ('("hi") : '{IO} Text)) - () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - f : (∀ a g. '{g} a ->{h} '{g} a) -> '{h} () - -``` -Here's an example, showing that polymorphic functions can be fields of a constructor, and the functions remain polymorphic even when the field is bound to a name during pattern matching: - -```unison -unique type Functor f = Functor (forall a b . (a -> b) -> f a -> f b) - -Functor.map : Functor f -> (forall a b . (a -> b) -> f a -> f b) -Functor.map = cases Functor f -> f - -Functor.blah : Functor f -> () -Functor.blah = cases Functor f -> - g : forall a b . (a -> b) -> f a -> f b - g = f - () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Functor f - Functor.blah : Functor f -> () - Functor.map : Functor f - -> (∀ a b. (a -> b) -> f a -> f b) - -``` -This example is similar, but involves abilities: - -```unison -unique ability Remote t where doRemoteStuff : t () -unique type Loc = Loc (forall t a . '{Remote t} a ->{Remote t} t a) - -Loc.blah : Loc -> () -Loc.blah = cases Loc f -> - f0 : '{Remote tx} ax ->{Remote tx} tx ax - f0 = f - () - --- In this case, no annotation is needed since the lambda --- is checked against a polymorphic type -Loc.transform : (forall t a . '{Remote t} a -> '{Remote t} a) - -> Loc -> Loc -Loc.transform nt = cases Loc f -> Loc (a -> f (nt a)) - --- In this case, the annotation is needed since f' is inferred --- on its own it won't infer the higher-rank type -Loc.transform2 : (forall t a . '{Remote t} a -> '{Remote t} a) - -> Loc -> Loc -Loc.transform2 nt = cases Loc f -> - f' : forall t a . '{Remote t} a ->{Remote t} t a - f' a = f (nt a) - Loc f' -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Loc - ability Remote t - Loc.blah : Loc -> () - Loc.transform : (∀ t a. '{Remote t} a -> '{Remote t} a) - -> Loc - -> Loc - Loc.transform2 : (∀ t a. '{Remote t} a -> '{Remote t} a) - -> Loc - -> Loc - -``` -## Types with polymorphic fields - -```unison -structural type HigherRanked = HigherRanked (forall a. a -> a) -``` - -We should be able to add and view records with higher-rank fields. - -```ucm - ☝️ The namespace .higher_ranked is empty. - -.higher_ranked> add - - ⍟ I've added these definitions: - - structural type HigherRanked - -.higher_ranked> view HigherRanked - - structural type HigherRanked = HigherRanked (∀ a. a -> a) - -``` diff --git a/unison-src/transcripts/idempotent/abilities.md b/unison-src/transcripts/idempotent/abilities.md new file mode 100644 index 0000000000..20d0f9745b --- /dev/null +++ b/unison-src/transcripts/idempotent/abilities.md @@ -0,0 +1,31 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Some random ability stuff to ensure things work. + +``` unison :hide + +unique ability A where + one : Nat ->{A} Nat + two : Nat -> Nat ->{A} Nat + three : Nat -> Nat -> Nat ->{A} Nat + four : Nat ->{A} (Nat -> Nat -> Nat -> Nat) + +ha : Request {A} r -> r +ha = cases + { x } -> x + { one i -> c } -> handle c (i+1) with ha + { two i j -> c } -> handle c (i+j) with ha + { three i j k -> c } -> handle c (i+j+k) with ha + { four i -> c } -> handle c (j k l -> i+j+k+l) with ha +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ability A + ha : Request {A} r -> r +``` diff --git a/unison-src/transcripts/idempotent/ability-order-doesnt-affect-hash.md b/unison-src/transcripts/idempotent/ability-order-doesnt-affect-hash.md new file mode 100644 index 0000000000..da9c866125 --- /dev/null +++ b/unison-src/transcripts/idempotent/ability-order-doesnt-affect-hash.md @@ -0,0 +1,32 @@ +The order of a set of abilities is normalized before hashing. + +``` unison :hide +unique ability Foo where + foo : () + +unique ability Bar where + bar : () + +term1 : () ->{Foo, Bar} () +term1 _ = () + +term2 : () ->{Bar, Foo} () +term2 _ = () +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ability Bar + ability Foo + term1 : '{Bar, Foo} () + term2 : '{Bar, Foo} () + +scratch/main> names term1 + + Term + Hash: #42m1ui9g56 + Names: term1 term2 +``` diff --git a/unison-src/transcripts/idempotent/ability-term-conflicts-on-update.md b/unison-src/transcripts/idempotent/ability-term-conflicts-on-update.md new file mode 100644 index 0000000000..83ecb5c59d --- /dev/null +++ b/unison-src/transcripts/idempotent/ability-term-conflicts-on-update.md @@ -0,0 +1,230 @@ +# Regression test for updates which conflict with an existing ability constructor + +https://github.com/unisonweb/unison/issues/2786 + +``` ucm :hide +scratch/main> builtins.merge lib.builtins +``` + +First we add an ability to the codebase. +Note that this will create the name `Channels.send` as an ability constructor. + +``` unison +unique ability Channels where + send : a -> {Channels} () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ability Channels +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ability Channels +``` + +Now we update the ability, changing the name of the constructor, *but*, we simultaneously +add a new top-level term with the same name as the constructor which is being +removed from Channels. + +``` unison +unique ability Channels where + sends : [a] -> {Channels} () + +Channels.send : a -> () +Channels.send a = () + +thing : '{Channels} () +thing _ = send 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Channels.send : a -> () + thing : '{Channels} () + + ⍟ These names already exist. You can `update` them to your + new definition: + + ability Channels +``` + +These should fail with a term/ctor conflict since we exclude the ability from the update. + +``` ucm :error +scratch/main> update.old patch Channels.send + + x These definitions failed: + + Reason + term/ctor collision Channels.send : a -> () + + Tip: Use `help filestatus` to learn more. + +scratch/main> update.old patch thing + + ⍟ I've added these definitions: + + Channels.send : a -> () + thing : '{Channels} () + + ⍟ I've updated these names to your new definition: + + ability Channels +``` + +If however, `Channels.send` and `thing` *depend* on `Channels`, updating them should succeed since it pulls in the ability as a dependency. + +``` unison +unique ability Channels where + sends : [a] -> {Channels} () + +Channels.send : a -> () +Channels.send a = sends [a] + +thing : '{Channels} () +thing _ = send 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⊡ Previously added definitions will be ignored: Channels + + ⍟ These names already exist. You can `update` them to your + new definition: + + Channels.send : a ->{Channels} () + thing : '{Channels} () +``` + +These updates should succeed since `Channels` is a dependency. + +``` ucm +scratch/main> update.old.preview patch Channels.send + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⊡ Previously added definitions will be ignored: Channels + + ⍟ These names already exist. You can `update` them to your + new definition: + + Channels.send : a ->{Channels} () + +scratch/main> update.old.preview patch thing + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⊡ Previously added definitions will be ignored: Channels + + ⍟ These names already exist. You can `update` them to your + new definition: + + Channels.send : a ->{Channels} () + thing : '{Channels} () +``` + +We should also be able to successfully update the whole thing. + +``` ucm +scratch/main> update.old + + ⊡ Ignored previously added definitions: Channels + + ⍟ I've updated these names to your new definition: + + Channels.send : a ->{Channels} () + thing : '{Channels} () +``` + +# Constructor-term conflict + +``` ucm :hide +scratch/main2> builtins.merge lib.builtins +``` + +``` unison +X.x = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + X.x : Nat +``` + +``` ucm +scratch/main2> add + + ⍟ I've added these definitions: + + X.x : Nat +``` + +``` unison +structural ability X where + x : () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + x These definitions would fail on `add` or `update`: + + Reason + blocked structural ability X + ctor/term collision X.x + + Tip: Use `help filestatus` to learn more. +``` + +This should fail with a ctor/term conflict. + +``` ucm :error +scratch/main2> add + + x These definitions failed: + + Reason + blocked structural ability X + ctor/term collision X.x + + Tip: Use `help filestatus` to learn more. +``` diff --git a/unison-src/transcripts/idempotent/add-run.md b/unison-src/transcripts/idempotent/add-run.md new file mode 100644 index 0000000000..46e1ffccfc --- /dev/null +++ b/unison-src/transcripts/idempotent/add-run.md @@ -0,0 +1,244 @@ +# add.run + +## Basic usage + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison :hide +even : Nat -> Boolean +even x = if x == 0 then true else odd (drop x 1) + +odd : Nat -> Boolean +odd x = if x == 0 then false else even (drop x 1) + +is2even : 'Boolean +is2even = '(even 2) +``` + +it errors if there isn't a previous run + +``` ucm :error +scratch/main> add.run foo + + ⚠️ + + There is no previous evaluation to save. Use `run` to evaluate + something before attempting to save it. +``` + +``` ucm +scratch/main> run is2even + + true +``` + +it errors if the desired result name conflicts with a name in the +unison file + +``` ucm :error +scratch/main> add.run is2even + + ⚠️ + + Cannot save the last run result into `is2even` because that + name conflicts with a name in the scratch file. +``` + +otherwise, the result is successfully persisted + +``` ucm +scratch/main> add.run foo.bar.baz + + ⍟ I've added these definitions: + + foo.bar.baz : Boolean +``` + +``` ucm +scratch/main> view foo.bar.baz + + foo.bar.baz : Boolean + foo.bar.baz = true +``` + +## It resolves references within the unison file + +``` unison +z b = b Nat.+ 12 +y a b = a Nat.+ b Nat.+ z 10 + + + + +main : '{IO, Exception} (Nat -> Nat -> Nat) +main _ = y +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + main : '{IO, Exception} (Nat -> Nat -> Nat) + y : Nat -> Nat -> Nat + z : Nat -> Nat +``` + +``` ucm +scratch/main> run main + + a b -> a Nat.+ b Nat.+ z 10 + +scratch/main> add.run result + + ⍟ I've added these definitions: + + result : Nat -> Nat -> Nat + z : Nat -> Nat +``` + +## It resolves references within the codebase + +``` unison +inc : Nat -> Nat +inc x = x + 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + inc : Nat -> Nat +``` + +``` ucm +scratch/main> add inc + + ⍟ I've added these definitions: + + inc : Nat -> Nat +``` + +``` unison :hide +main : '(Nat -> Nat) +main _ x = inc x +``` + +``` ucm +scratch/main> run main + + inc + +scratch/main> add.run natfoo + + ⍟ I've added these definitions: + + natfoo : Nat -> Nat + +scratch/main> view natfoo + + natfoo : Nat -> Nat + natfoo = inc +``` + +## It captures scratch file dependencies at run time + +``` unison +x = 1 +y = x + x +main = 'y +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + main : 'Nat + x : Nat + y : Nat +``` + +``` ucm +scratch/main> run main + + 2 +``` + +``` unison :hide +x = 50 +``` + +this saves 2 to xres, rather than 100 + +``` ucm +scratch/main> add.run xres + + ⍟ I've added these definitions: + + xres : Nat + +scratch/main> view xres + + xres : Nat + xres = 2 +``` + +## It fails with a message if add cannot complete cleanly + +``` unison :hide +main = '5 +``` + +``` ucm :error +scratch/main> run main + + 5 + +scratch/main> add.run xres + + x These definitions failed: + + Reason + needs update xres : Nat + + Tip: Use `help filestatus` to learn more. +``` + +## It works with absolute names + +``` unison :hide +main = '5 +``` + +``` ucm +scratch/main> run main + + 5 + +scratch/main> add.run .an.absolute.name + + ⍟ I've added these definitions: + + .an.absolute.name : Nat + +scratch/main> view .an.absolute.name + + .an.absolute.name : Nat + .an.absolute.name = 5 +``` diff --git a/unison-src/transcripts/idempotent/add-test-watch-roundtrip.md b/unison-src/transcripts/idempotent/add-test-watch-roundtrip.md new file mode 100644 index 0000000000..846cd1537d --- /dev/null +++ b/unison-src/transcripts/idempotent/add-test-watch-roundtrip.md @@ -0,0 +1,24 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison :hide +test> foo : [Test.Result] +foo = [] +``` + +Apparently when we add a test watch, we add a type annotation to it, even if it already has one. We don't want this to happen though\! + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : [Result] + +scratch/main> view foo + + foo : [Result] + foo : [Result] + foo = [] +``` diff --git a/unison-src/transcripts/idempotent/addupdatemessages.md b/unison-src/transcripts/idempotent/addupdatemessages.md new file mode 100644 index 0000000000..a91b32bfa3 --- /dev/null +++ b/unison-src/transcripts/idempotent/addupdatemessages.md @@ -0,0 +1,152 @@ +# Adds and updates + +Let's set up some definitions to start: + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +x = 1 +y = 2 + +structural type X = One Nat +structural type Y = Two Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type X + structural type Y + x : Nat + y : Nat +``` + +Expected: `x` and `y`, `X`, and `Y` exist as above. UCM tells you this. + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type X + structural type Y + x : Nat + y : Nat +``` + +Let's add an alias for `1` and `One`: + +``` unison +z = 1 + +structural type Z = One Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type Z + (also named X) + z : Nat + (also named x) +``` + +Expected: `z` is now `1`. UCM tells you that this definition is also called `x`. +Also, `Z` is an alias for `X`. + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type Z + (also named X) + z : Nat + (also named x) +``` + +Let's update something that has an alias (to a value that doesn't have a name already): + +``` unison +x = 3 +structural type X = Three Nat Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + structural type X + (The old definition is also named Z.) + x : Nat + (The old definition is also named z.) +``` + +Expected: `x` is now `3` and `X` has constructor `Three`. UCM tells you the old definitions were also called `z` and `Z` and these names have also been updated. + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. +``` + +Update it to something that already exists with a different name: + +``` unison +x = 2 +structural type X = Two Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + structural type X + (also named Y) + x : Nat + (also named y) +``` + +Expected: `x` is now `2` and `X` is `Two`. UCM says the old definition was also named `z/Z`, and was also updated. And it says the new definition is also named `y/Y`. + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` diff --git a/unison-src/transcripts/idempotent/alias-term.md b/unison-src/transcripts/idempotent/alias-term.md new file mode 100644 index 0000000000..553afa52b3 --- /dev/null +++ b/unison-src/transcripts/idempotent/alias-term.md @@ -0,0 +1,47 @@ +`alias.term` makes a new name for a term. + +``` ucm :hide +project/main> builtins.mergeio lib.builtins +``` + +``` ucm +project/main> alias.term lib.builtins.bug foo + + Done. + +project/main> ls + + 1. foo (a -> b) + 2. lib/ (643 terms, 92 types) +``` + +It won't create a conflicted name, though. + +``` ucm :error +project/main> alias.term lib.builtins.todo foo + + ⚠️ + + A term by that name already exists. +``` + +``` ucm +project/main> ls + + 1. foo (a -> b) + 2. lib/ (643 terms, 92 types) +``` + +You can use `debug.alias.term.force` for that. + +``` ucm +project/main> debug.alias.term.force lib.builtins.todo foo + + Done. + +project/main> ls + + 1. foo (a -> b) + 2. foo (a -> b) + 3. lib/ (643 terms, 92 types) +``` diff --git a/unison-src/transcripts/idempotent/alias-type.md b/unison-src/transcripts/idempotent/alias-type.md new file mode 100644 index 0000000000..98a7de829b --- /dev/null +++ b/unison-src/transcripts/idempotent/alias-type.md @@ -0,0 +1,47 @@ +`alias.type` makes a new name for a type. + +``` ucm :hide +project/main> builtins.mergeio lib.builtins +``` + +``` ucm +project/main> alias.type lib.builtins.Nat Foo + + Done. + +project/main> ls + + 1. Foo (builtin type) + 2. lib/ (643 terms, 92 types) +``` + +It won't create a conflicted name, though. + +``` ucm :error +project/main> alias.type lib.builtins.Int Foo + + ⚠️ + + A type by that name already exists. +``` + +``` ucm +project/main> ls + + 1. Foo (builtin type) + 2. lib/ (643 terms, 92 types) +``` + +You can use `debug.alias.type.force` for that. + +``` ucm +project/main> debug.alias.type.force lib.builtins.Int Foo + + Done. + +project/main> ls + + 1. Foo (builtin type) + 2. Foo (builtin type) + 3. lib/ (643 terms, 92 types) +``` diff --git a/unison-src/transcripts/idempotent/anf-tests.md b/unison-src/transcripts/idempotent/anf-tests.md new file mode 100644 index 0000000000..18cca0ade1 --- /dev/null +++ b/unison-src/transcripts/idempotent/anf-tests.md @@ -0,0 +1,57 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +This tests a variable related bug in the ANF compiler. + +The nested let would get flattened out, resulting in: + +``` +bar = result +``` + +which would be handled by renaming. However, the *context* portion of +the rest of the code was not being renamed correctly, so `bar` would +remain in the definition of `baz`. + +``` unison +foo _ = + id x = x + void x = () + bar = let + void (Debug.watch "hello" "hello") + result = 5 + void (Debug.watch "goodbye" "goodbye") + result + baz = id bar + baz + +> !foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : ∀ _. _ -> Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 12 | > !foo + ⧩ + 5 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : ∀ _. _ -> Nat +``` diff --git a/unison-src/transcripts/idempotent/any-extract.md b/unison-src/transcripts/idempotent/any-extract.md new file mode 100644 index 0000000000..a6621b64ba --- /dev/null +++ b/unison-src/transcripts/idempotent/any-extract.md @@ -0,0 +1,48 @@ +# Unit tests for Any.unsafeExtract + +``` ucm :hide +scratch/main> builtins.mergeio + +scratch/main> load unison-src/transcripts-using-base/base.u + +scratch/main> add +``` + +Any.unsafeExtract is a way to extract the value contained in an Any. This is unsafe because it allows the programmer to coerce a value into any type, which would cause undefined behaviour if used to coerce a value to the wrong type. + +``` unison + +test> Any.unsafeExtract.works = + use Nat != + checks [1 == Any.unsafeExtract (Any 1), + not (1 == Any.unsafeExtract (Any 2)), + (Some 1) == Any.unsafeExtract (Any (Some 1)) + ] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Any.unsafeExtract.works : [Result] + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 4 | checks [1 == Any.unsafeExtract (Any 1), + + ✅ Passed Passed +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + Any.unsafeExtract.works : [Result] +``` diff --git a/unison-src/transcripts/idempotent/api-doc-rendering.md b/unison-src/transcripts/idempotent/api-doc-rendering.md new file mode 100644 index 0000000000..a4ed862c42 --- /dev/null +++ b/unison-src/transcripts/idempotent/api-doc-rendering.md @@ -0,0 +1,951 @@ +# Doc rendering + +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison :hide +structural type Maybe a = Nothing | Just a +otherTerm = "text" + +otherDoc : (Text -> Doc2) -> Doc2 +otherDoc mkMsg = {{ +This doc should be embedded. + +{{mkMsg "message"}} + +}} + +{{ +# Heading + +## Heading 2 + +Term Link: {otherTerm} + +Type Link: {type Maybe} + +Term source: + +@source{term} + +Term signature: + +@signature{term} + +* List item + +1. Numbered list item + +> Block quote + + Code block + +Inline code: + +`` 1 + 2 `` + +`"doesn't typecheck" + 1` + +[Link](https://unison-lang.org) + +![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) + +**Bold** + +*Italic* + +~~Strikethrough~~ + +Horizontal rule + +--- + +Table + +| Header 1 | Header 2 | +| -------- | -------- | +| Cell 1 | Cell 2 | +| Cell 3 | Cell 4 | + + +Video + +{{ Special (Embed (Any (Video [(MediaSource "test.mp4" None)] [("poster", "test.png")]))) }} + +Transclusion/evaluation: + +{{otherDoc (a -> Word a )}} + +}} +term = 42 +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> display term.doc + + # Heading + + # Heading 2 + + Term Link: otherTerm + + Type Link: Maybe + + Term source: + + term : Nat + term = 42 + + Term signature: + + term : Nat + + * List item + + 1. Numbered list item + + > Block quote + + Code block + + Inline code: + + `1 Nat.+ 2` + + `"doesn't typecheck" + 1` + + Link + + ![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) + + Bold + + Italic + + ~~Strikethrough~~ + + Horizontal rule + + --- + + Table + + | Header 1 | Header 2 | | -------- | -------- | | Cell 1 | + Cell 2 | | Cell 3 | Cell 4 | + + Video + + + {{ embed {{ + Video + [MediaSource "test.mp4" Nothing] + [("poster", "test.png")] }} }} + + + Transclusion/evaluation: + + This doc should be embedded. + + message +``` + +``` api +GET /api/projects/scratch/branches/main/getDefinition?names=term + { + "missingDefinitions": [], + "termDefinitions": { + "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": { + "bestTermName": "term", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "42" + } + ], + "tag": "UserObject" + }, + "termDocs": [ + [ + "doc", + "#kjfaflbrgl89j2uq4ruubejakm6s02cp3m61ufu7rv7tkbd4nmkvcn1fciue53v0msir9t7ds111ab9er8qfa06gsa9ddfrdfgc99mo", + { + "contents": [ + { + "contents": [ + { + "contents": "Heading", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + [ + { + "contents": [ + { + "contents": [ + { + "contents": "Heading", + "tag": "Word" + }, + { + "contents": "2", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + [ + { + "contents": [ + { + "contents": "Term", + "tag": "Word" + }, + { + "contents": "Link:", + "tag": "Word" + }, + { + "contents": { + "contents": [ + { + "annotation": { + "contents": "#k5gpql9cbdfau6lf1aja24joc3sfctvjor8esu8bemn0in3l148otb0t3vebgqrt6qml302h62bbfeftg65gec1v8ouin5m6v2969d8", + "tag": "TermReference" + }, + "segment": "otherTerm" + } + ], + "tag": "Link" + }, + "tag": "Special" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "Type", + "tag": "Word" + }, + { + "contents": "Link:", + "tag": "Word" + }, + { + "contents": { + "contents": [ + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg", + "tag": "TypeReference" + }, + "segment": "Maybe" + } + ], + "tag": "Link" + }, + "tag": "Special" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "Term", + "tag": "Word" + }, + { + "contents": "source:", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": { + "contents": [ + { + "contents": [ + "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", + { + "contents": [ + [ + { + "annotation": { + "contents": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", + "tag": "TermReference" + }, + "segment": "term" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": ": " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + [ + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "42" + } + ] + ], + "tag": "UserObject" + } + ], + "tag": "Term" + } + ], + "tag": "Source" + }, + "tag": "Special" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "Term", + "tag": "Word" + }, + { + "contents": "signature:", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": { + "contents": [ + [ + { + "annotation": { + "contents": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", + "tag": "TermReference" + }, + "segment": "term" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": ": " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ] + ], + "tag": "Signature" + }, + "tag": "Special" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": [ + { + "contents": "List", + "tag": "Word" + }, + { + "contents": "item", + "tag": "Word" + } + ], + "tag": "Paragraph" + } + ], + "tag": "BulletedList" + }, + { + "contents": [ + 1, + [ + { + "contents": [ + { + "contents": "Numbered", + "tag": "Word" + }, + { + "contents": "list", + "tag": "Word" + }, + { + "contents": "item", + "tag": "Word" + } + ], + "tag": "Paragraph" + } + ] + ], + "tag": "NumberedList" + }, + { + "contents": [ + { + "contents": ">", + "tag": "Word" + }, + { + "contents": "Block", + "tag": "Word" + }, + { + "contents": "quote", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "Code", + "tag": "Word" + }, + { + "contents": "block", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "Inline", + "tag": "Word" + }, + { + "contents": "code:", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": { + "contents": [ + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.+", + "tag": "TermReference" + }, + "segment": "Nat.+" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "2" + } + ], + "tag": "Example" + }, + "tag": "Special" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": { + "contents": "\"doesn't typecheck\" + 1", + "tag": "Word" + }, + "tag": "Code" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": [ + { + "contents": [ + { + "contents": "Link", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": { + "contents": "https://unison-lang.org", + "tag": "Word" + }, + "tag": "Group" + } + ], + "tag": "NamedLink" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png)", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": { + "contents": [ + { + "contents": "Bold", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + "tag": "Bold" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": { + "contents": [ + { + "contents": "Italic", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + "tag": "Bold" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": { + "contents": [ + { + "contents": "Strikethrough", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + "tag": "Strikethrough" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "Horizontal", + "tag": "Word" + }, + { + "contents": "rule", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "---", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "Table", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "|", + "tag": "Word" + }, + { + "contents": "Header", + "tag": "Word" + }, + { + "contents": "1", + "tag": "Word" + }, + { + "contents": "|", + "tag": "Word" + }, + { + "contents": "Header", + "tag": "Word" + }, + { + "contents": "2", + "tag": "Word" + }, + { + "contents": "|", + "tag": "Word" + }, + { + "contents": "|", + "tag": "Word" + }, + { + "contents": "--------", + "tag": "Word" + }, + { + "contents": "|", + "tag": "Word" + }, + { + "contents": "--------", + "tag": "Word" + }, + { + "contents": "|", + "tag": "Word" + }, + { + "contents": "|", + "tag": "Word" + }, + { + "contents": "Cell", + "tag": "Word" + }, + { + "contents": "1", + "tag": "Word" + }, + { + "contents": "|", + "tag": "Word" + }, + { + "contents": "Cell", + "tag": "Word" + }, + { + "contents": "2", + "tag": "Word" + }, + { + "contents": "|", + "tag": "Word" + }, + { + "contents": "|", + "tag": "Word" + }, + { + "contents": "Cell", + "tag": "Word" + }, + { + "contents": "3", + "tag": "Word" + }, + { + "contents": "|", + "tag": "Word" + }, + { + "contents": "Cell", + "tag": "Word" + }, + { + "contents": "4", + "tag": "Word" + }, + { + "contents": "|", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "Video", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": { + "contents": [ + [ + { + "mediaSourceMimeType": null, + "mediaSourceUrl": "test.mp4" + } + ], + { + "poster": "test.png" + } + ], + "tag": "Video" + }, + "tag": "Special" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "Transclusion/evaluation:", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": [ + { + "contents": [ + { + "contents": "This", + "tag": "Word" + }, + { + "contents": "doc", + "tag": "Word" + }, + { + "contents": "should", + "tag": "Word" + }, + { + "contents": "be", + "tag": "Word" + }, + { + "contents": "embedded.", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + { + "contents": [ + { + "contents": "message", + "tag": "Word" + } + ], + "tag": "Paragraph" + } + ], + "tag": "UntitledSection" + } + ], + "tag": "Paragraph" + } + ] + ], + "tag": "Section" + } + ] + ], + "tag": "Section" + } + ] + ], + "termNames": [ + "term" + ] + } + }, + "typeDefinitions": {} + } +``` diff --git a/unison-src/transcripts/idempotent/api-find.md b/unison-src/transcripts/idempotent/api-find.md new file mode 100644 index 0000000000..33fab9d0bb --- /dev/null +++ b/unison-src/transcripts/idempotent/api-find.md @@ -0,0 +1,254 @@ +# find api + +``` unison +rachel.filesystem.x = 42 +ross.httpClient.y = 43 +joey.httpServer.z = 44 +joey.yaml.zz = 45 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + joey.httpServer.z : ##Nat + joey.yaml.zz : ##Nat + rachel.filesystem.x : ##Nat + ross.httpClient.y : ##Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + joey.httpServer.z : ##Nat + joey.yaml.zz : ##Nat + rachel.filesystem.x : ##Nat + ross.httpClient.y : ##Nat +``` + +``` api +-- Namespace segment prefix search +GET /api/projects/scratch/branches/main/find?query=http + [ + [ + { + "result": { + "segments": [ + { + "contents": "ross.", + "tag": "Gap" + }, + { + "contents": "http", + "tag": "Match" + }, + { + "contents": "Client.y", + "tag": "Gap" + } + ] + }, + "score": 156 + }, + { + "contents": { + "bestFoundTermName": "y", + "namedTerm": { + "termHash": "#emomp74i93h6ps0b5sukke0tci0ooba3f9jk21qm919a7act9u7asani84c0mqbdk4lcjrdvr9olpedp23p6df78r4trqlg0cciadc8", + "termName": "ross.httpClient.y", + "termTag": "Plain", + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + } + }, + "tag": "FoundTermResult" + } + ], + [ + { + "result": { + "segments": [ + { + "contents": "joey.", + "tag": "Gap" + }, + { + "contents": "http", + "tag": "Match" + }, + { + "contents": "Server.z", + "tag": "Gap" + } + ] + }, + "score": 156 + }, + { + "contents": { + "bestFoundTermName": "z", + "namedTerm": { + "termHash": "#a84tg4er4kfl9k2p250vp2o1dsp5kmn9a7q8g2bo723qbtbf9sagrl28fa4q0j5f2cv4alsjik6rf487ss646qt95gbm3dd13k7e1fo", + "termName": "joey.httpServer.z", + "termTag": "Plain", + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + } + }, + "tag": "FoundTermResult" + } + ] + ] +-- Namespace segment suffix search +GET /api/projects/scratch/branches/main/find?query=Server + [ + [ + { + "result": { + "segments": [ + { + "contents": "joey.http", + "tag": "Gap" + }, + { + "contents": "Server", + "tag": "Match" + }, + { + "contents": ".z", + "tag": "Gap" + } + ] + }, + "score": 223 + }, + { + "contents": { + "bestFoundTermName": "z", + "namedTerm": { + "termHash": "#a84tg4er4kfl9k2p250vp2o1dsp5kmn9a7q8g2bo723qbtbf9sagrl28fa4q0j5f2cv4alsjik6rf487ss646qt95gbm3dd13k7e1fo", + "termName": "joey.httpServer.z", + "termTag": "Plain", + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + } + }, + "tag": "FoundTermResult" + } + ] + ] +-- Substring search +GET /api/projects/scratch/branches/main/find?query=lesys + [ + [ + { + "result": { + "segments": [ + { + "contents": "rachel.fi", + "tag": "Gap" + }, + { + "contents": "lesys", + "tag": "Match" + }, + { + "contents": "tem.x", + "tag": "Gap" + } + ] + }, + "score": 175 + }, + { + "contents": { + "bestFoundTermName": "x", + "namedTerm": { + "termHash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", + "termName": "rachel.filesystem.x", + "termTag": "Plain", + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + } + }, + "tag": "FoundTermResult" + } + ] + ] +-- Cross-segment search +GET /api/projects/scratch/branches/main/find?query=joey.http + [ + [ + { + "result": { + "segments": [ + { + "contents": "joey.http", + "tag": "Match" + }, + { + "contents": "Server.z", + "tag": "Gap" + } + ] + }, + "score": 300 + }, + { + "contents": { + "bestFoundTermName": "z", + "namedTerm": { + "termHash": "#a84tg4er4kfl9k2p250vp2o1dsp5kmn9a7q8g2bo723qbtbf9sagrl28fa4q0j5f2cv4alsjik6rf487ss646qt95gbm3dd13k7e1fo", + "termName": "joey.httpServer.z", + "termTag": "Plain", + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + } + }, + "tag": "FoundTermResult" + } + ] + ] +``` diff --git a/unison-src/transcripts/idempotent/api-getDefinition.md b/unison-src/transcripts/idempotent/api-getDefinition.md new file mode 100644 index 0000000000..3093f55514 --- /dev/null +++ b/unison-src/transcripts/idempotent/api-getDefinition.md @@ -0,0 +1,526 @@ +# Get Definitions Test + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison :hide +nested.names.x.doc = {{ Documentation }} +nested.names.x = 42 +``` + +``` ucm :hide +scratch/main> add +``` + +``` api +-- Should NOT find names by suffix +GET /api/projects/scratch/branches/main/getDefinition?names=x + { + "missingDefinitions": [ + "x" + ], + "termDefinitions": {}, + "typeDefinitions": {} + } +-- Term names should strip relativeTo prefix. +GET /api/projects/scratch/branches/main/getDefinition?names=names.x&relativeTo=nested + { + "missingDefinitions": [], + "termDefinitions": { + "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": { + "bestTermName": "x", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "42" + } + ], + "tag": "UserObject" + }, + "termDocs": [ + [ + "doc", + "#ulr9f75rpcrv79d7sfo2ep2tvbntu3e360lfomird2bdpj4bnea230e8o5j0b9our8vggocpa7eck3pus14fcfajlttat1bg71t6rbg", + { + "contents": [ + { + "contents": "Documentation", + "tag": "Word" + } + ], + "tag": "Paragraph" + } + ] + ], + "termNames": [ + "nested.names.x" + ] + } + }, + "typeDefinitions": {} + } +-- Should find definitions by hash, names should be relative +GET /api/projects/scratch/branches/main/getDefinition?names=%23qkhkl0n238&relativeTo=nested + { + "missingDefinitions": [], + "termDefinitions": { + "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": { + "bestTermName": "x", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "42" + } + ], + "tag": "UserObject" + }, + "termDocs": [ + [ + "doc", + "#ulr9f75rpcrv79d7sfo2ep2tvbntu3e360lfomird2bdpj4bnea230e8o5j0b9our8vggocpa7eck3pus14fcfajlttat1bg71t6rbg", + { + "contents": [ + { + "contents": "Documentation", + "tag": "Word" + } + ], + "tag": "Paragraph" + } + ] + ], + "termNames": [ + "nested.names.x" + ] + } + }, + "typeDefinitions": {} + } +``` + +``` unison :hide +doctest.thing.doc = {{ The correct docs for the thing }} +doctest.thing = "A thing" +doctest.thingalias.doc = {{ Docs for the alias, should not be displayed }} +doctest.thingalias = "A thing" +doctest.otherstuff.thing.doc = {{ A doc for a different term with the same name, should not be displayed }} +doctest.otherstuff.thing = "A different thing" +``` + +``` ucm :hide +scratch/main> add +``` + +Only docs for the term we request should be returned, even if there are other term docs with the same suffix. + +``` api +GET /api/projects/scratch/branches/main/getDefinition?names=thing&relativeTo=doctest + { + "missingDefinitions": [], + "termDefinitions": { + "#jksc1s5kud95ro5ivngossullt2oavsd41s3u48bch67jf3gknru5j6hmjslonkd5sdqs8mr8k4rrnef8fodngbg4sm7u6au564ekjg": { + "bestTermName": "doctest.thing", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "doctest.thing", + "tag": "HashQualifier" + }, + "segment": "doctest.thing" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "doctest.thing", + "tag": "HashQualifier" + }, + "segment": "doctest.thing" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TextLiteral" + }, + "segment": "\"A thing\"" + } + ], + "tag": "UserObject" + }, + "termDocs": [ + [ + "doctest.thing.doc", + "#t9qfdoiuskj4n9go8cftj1r83s43s3o7sppafm5vr0bq5feieb7ap0cie5ed2qsf9g3ig448vffhnajinq81pnnkila1jp2epa7f26o", + { + "contents": [ + { + "contents": "The", + "tag": "Word" + }, + { + "contents": "correct", + "tag": "Word" + }, + { + "contents": "docs", + "tag": "Word" + }, + { + "contents": "for", + "tag": "Word" + }, + { + "contents": "the", + "tag": "Word" + }, + { + "contents": "thing", + "tag": "Word" + } + ], + "tag": "Paragraph" + } + ] + ], + "termNames": [ + "doctest.thing", + "doctest.thingalias" + ] + } + }, + "typeDefinitions": {} + } +``` + +If we request a doc, the api should return the source, but also the rendered doc should appear in the 'termDocs' list. + +``` api +GET /api/projects/scratch/branches/main/getDefinition?names=thing.doc&relativeTo=doctest + { + "missingDefinitions": [], + "termDefinitions": { + "#t9qfdoiuskj4n9go8cftj1r83s43s3o7sppafm5vr0bq5feieb7ap0cie5ed2qsf9g3ig448vffhnajinq81pnnkila1jp2epa7f26o": { + "bestTermName": "doctest.thing.doc", + "defnTermTag": "Doc", + "signature": [ + { + "annotation": { + "contents": "#ej86si0ur1lsjade71dojr25phk9bbom9rdks6dltolos5tjivakujcriqe02npba53n9gd7tkh8bmv08ttjb9t35lq2ch5heshqcs0", + "tag": "TypeReference" + }, + "segment": "Doc2" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "doctest.thing.doc", + "tag": "HashQualifier" + }, + "segment": "doctest.thing.doc" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#ej86si0ur1lsjade71dojr25phk9bbom9rdks6dltolos5tjivakujcriqe02npba53n9gd7tkh8bmv08ttjb9t35lq2ch5heshqcs0", + "tag": "TypeReference" + }, + "segment": "Doc2" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "doctest.thing.doc", + "tag": "HashQualifier" + }, + "segment": "doctest.thing.doc" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DocDelimiter" + }, + "segment": "{{" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": "The" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": "correct" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": "docs" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": "for" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": "the" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": "thing" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DocDelimiter" + }, + "segment": "}}" + } + ], + "tag": "UserObject" + }, + "termDocs": [ + [ + "doctest.thing.doc", + "#t9qfdoiuskj4n9go8cftj1r83s43s3o7sppafm5vr0bq5feieb7ap0cie5ed2qsf9g3ig448vffhnajinq81pnnkila1jp2epa7f26o", + { + "contents": [ + { + "contents": "The", + "tag": "Word" + }, + { + "contents": "correct", + "tag": "Word" + }, + { + "contents": "docs", + "tag": "Word" + }, + { + "contents": "for", + "tag": "Word" + }, + { + "contents": "the", + "tag": "Word" + }, + { + "contents": "thing", + "tag": "Word" + } + ], + "tag": "Paragraph" + } + ] + ], + "termNames": [ + "doctest.thing.doc" + ] + } + }, + "typeDefinitions": {} + } +``` diff --git a/unison-src/transcripts/idempotent/api-list-projects-branches.md b/unison-src/transcripts/idempotent/api-list-projects-branches.md new file mode 100644 index 0000000000..02d2d2541f --- /dev/null +++ b/unison-src/transcripts/idempotent/api-list-projects-branches.md @@ -0,0 +1,70 @@ +# List Projects And Branches Test + +``` ucm :hide +scratch/main> project.create-empty project-one + +scratch/main> project.create-empty project-two + +scratch/main> project.create-empty project-three + +project-one/main> branch branch-one + +project-one/main> branch branch-two + +project-one/main> branch branch-three +``` + +``` api +-- Should list all projects +GET /api/projects + [ + { + "projectName": "project-one" + }, + { + "projectName": "project-three" + }, + { + "projectName": "project-two" + }, + { + "projectName": "scratch" + } + ] +-- Should list projects starting with project-t +GET /api/projects?prefix=project-t + [ + { + "projectName": "project-three" + }, + { + "projectName": "project-two" + } + ] +-- Should list all branches +GET /api/projects/project-one/branches + [ + { + "branchName": "branch-one" + }, + { + "branchName": "branch-three" + }, + { + "branchName": "branch-two" + }, + { + "branchName": "main" + } + ] +-- Should list all branches beginning with branch-t +GET /api/projects/project-one/branches?prefix=branch-t + [ + { + "branchName": "branch-three" + }, + { + "branchName": "branch-two" + } + ] +``` diff --git a/unison-src/transcripts/idempotent/api-namespace-details.md b/unison-src/transcripts/idempotent/api-namespace-details.md new file mode 100644 index 0000000000..4cbbd01c51 --- /dev/null +++ b/unison-src/transcripts/idempotent/api-namespace-details.md @@ -0,0 +1,84 @@ +# Namespace Details Test + +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison +{{ Documentation }} +nested.names.x = 42 + +nested.names.readme = {{ +Here's a *README*! +}} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + nested.names.readme : Doc2 + nested.names.x : Nat + nested.names.x.doc : Doc2 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + nested.names.readme : Doc2 + nested.names.x : Nat + nested.names.x.doc : Doc2 +``` + +``` api +-- Should find names by suffix +GET /api/projects/scratch/branches/main/namespaces/nested.names + { + "fqn": "nested.names", + "hash": "#6tnmlu9knsce0u2991u6fvcmf4v44fdf0aiqtmnq7mjj0gi5sephg3lf12iv3odr5rc7vlgq75ciborrd3625c701bdmdomia2gcm3o", + "readme": { + "contents": [ + { + "contents": "Here's", + "tag": "Word" + }, + { + "contents": "a", + "tag": "Word" + }, + { + "contents": { + "contents": [ + { + "contents": { + "contents": [ + { + "contents": "README", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + "tag": "Bold" + }, + { + "contents": "!", + "tag": "Word" + } + ], + "tag": "Join" + }, + "tag": "Group" + } + ], + "tag": "Paragraph" + } + } +``` diff --git a/unison-src/transcripts/idempotent/api-namespace-list.md b/unison-src/transcripts/idempotent/api-namespace-list.md new file mode 100644 index 0000000000..7287cec514 --- /dev/null +++ b/unison-src/transcripts/idempotent/api-namespace-list.md @@ -0,0 +1,137 @@ +# Namespace list api + +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison +{{ Documentation }} +nested.names.x = 42 + +nested.names.readme = {{ I'm a readme! }} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + nested.names.readme : Doc2 + nested.names.x : Nat + nested.names.x.doc : Doc2 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + nested.names.readme : Doc2 + nested.names.x : Nat + nested.names.x.doc : Doc2 +``` + +``` api +GET /api/projects/scratch/branches/main/list?namespace=nested.names + { + "namespaceListingChildren": [ + { + "contents": { + "termHash": "#ddmmatmmiqsts2ku0i02kntd0s7rvcui4nn1cusio8thp9oqhbtilvcnhen52ibv43kr5q83f5er5q9h56s807k17tnelnrac7cch8o", + "termName": "readme", + "termTag": "Doc", + "termType": [ + { + "annotation": { + "contents": "#ej86si0ur1", + "tag": "HashQualifier" + }, + "segment": "#ej86si0ur1" + } + ] + }, + "tag": "TermObject" + }, + { + "contents": { + "termHash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", + "termName": "x", + "termTag": "Plain", + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + }, + "tag": "TermObject" + }, + { + "contents": { + "namespaceHash": "#n1egracfeljprftoktbjcase2hs4f4p8idbhs5ujipl42agld1810hrq9t7p7ped16aagni2cm1fjcjhho770jh80ipthhmg0cnsur0", + "namespaceName": "x", + "namespaceSize": 1 + }, + "tag": "Subnamespace" + } + ], + "namespaceListingFQN": "nested.names", + "namespaceListingHash": "#oms19b4f9s3c8tb5skeb8jii95ij35n3hdg038pu6rv5b0fikqe4gd7lnu6a1i6aq5tdh2opdo4s0sfrupvk6vfkr9lf0n752gbl8o0" + } +GET /api/projects/scratch/branches/main/list?namespace=names&relativeTo=nested + { + "namespaceListingChildren": [ + { + "contents": { + "termHash": "#ddmmatmmiqsts2ku0i02kntd0s7rvcui4nn1cusio8thp9oqhbtilvcnhen52ibv43kr5q83f5er5q9h56s807k17tnelnrac7cch8o", + "termName": "readme", + "termTag": "Doc", + "termType": [ + { + "annotation": { + "contents": "#ej86si0ur1", + "tag": "HashQualifier" + }, + "segment": "#ej86si0ur1" + } + ] + }, + "tag": "TermObject" + }, + { + "contents": { + "termHash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", + "termName": "x", + "termTag": "Plain", + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + }, + "tag": "TermObject" + }, + { + "contents": { + "namespaceHash": "#n1egracfeljprftoktbjcase2hs4f4p8idbhs5ujipl42agld1810hrq9t7p7ped16aagni2cm1fjcjhho770jh80ipthhmg0cnsur0", + "namespaceName": "x", + "namespaceSize": 1 + }, + "tag": "Subnamespace" + } + ], + "namespaceListingFQN": "nested.names", + "namespaceListingHash": "#oms19b4f9s3c8tb5skeb8jii95ij35n3hdg038pu6rv5b0fikqe4gd7lnu6a1i6aq5tdh2opdo4s0sfrupvk6vfkr9lf0n752gbl8o0" + } +``` diff --git a/unison-src/transcripts/idempotent/api-summaries.md b/unison-src/transcripts/idempotent/api-summaries.md new file mode 100644 index 0000000000..d10db43d61 --- /dev/null +++ b/unison-src/transcripts/idempotent/api-summaries.md @@ -0,0 +1,840 @@ +# Definition Summary APIs + +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison :hide +nat : Nat +nat = 42 +doc : Doc2 +doc = {{ Hello }} +test> mytest = [Test.Result.Ok "ok"] +func : Text -> Text +func x = x ++ "hello" + +funcWithLongType : Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text +funcWithLongType a b c d e f g h = a ++ b ++ c ++ d ++ e ++ f ++ g ++ h + +structural type Thing = This Nat | That +structural type Maybe a = Nothing | Just a + +structural ability Stream s where + send : s -> () +``` + +``` ucm :hide +scratch/main> add + +scratch/main> alias.type ##Nat Nat + +scratch/main> alias.term ##IO.putBytes.impl.v3 putBytesImpl +``` + +## Term Summary APIs + +``` api +-- term +GET /api/projects/scratch/branches/main/definitions/terms/by-hash/@qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8/summary?name=nat + { + "displayName": "nat", + "hash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", + "summary": { + "contents": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "tag": "UserObject" + }, + "tag": "Plain" + } +-- term without name uses hash +GET /api/projects/scratch/branches/main/definitions/terms/by-hash/@qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8/summary + { + "displayName": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", + "hash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", + "summary": { + "contents": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "tag": "UserObject" + }, + "tag": "Plain" + } +-- doc +GET /api/projects/scratch/branches/main/definitions/terms/by-hash/@icfnhas71n8q5rm7rmpe51hh7bltsr7rb4lv7qadc4cbsifu1mhonlqj2d7836iar2ptc648q9p4u7hf40ijvld574421b6u8gpu0lo/summary?name=doc + { + "displayName": "doc", + "hash": "#icfnhas71n8q5rm7rmpe51hh7bltsr7rb4lv7qadc4cbsifu1mhonlqj2d7836iar2ptc648q9p4u7hf40ijvld574421b6u8gpu0lo", + "summary": { + "contents": [ + { + "annotation": { + "contents": "#ej86si0ur1lsjade71dojr25phk9bbom9rdks6dltolos5tjivakujcriqe02npba53n9gd7tkh8bmv08ttjb9t35lq2ch5heshqcs0", + "tag": "TypeReference" + }, + "segment": "Doc2" + } + ], + "tag": "UserObject" + }, + "tag": "Doc" + } +-- test +GET /api/projects/scratch/branches/main/definitions/terms/by-hash/@u17p9803hdibisou6rlr1sjbccdossgh7vtkd03ovlvnsl2n91lq94sqhughc62tnrual2jlrfk922sebp4nm22o7m5u9j40emft8r8/summary?name=mytest + { + "displayName": "mytest", + "hash": "#u17p9803hdibisou6rlr1sjbccdossgh7vtkd03ovlvnsl2n91lq94sqhughc62tnrual2jlrfk922sebp4nm22o7m5u9j40emft8r8", + "summary": { + "contents": [ + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "[" + }, + { + "annotation": { + "contents": "#aql7qk3iud6vs4cvu43aimopoosgk0fnipibdkc3so13adencmibgfn0u5c01r0adei55nkl3ttsjhl8gbj7tr4gnpj63g64ftbq6s0", + "tag": "TypeReference" + }, + "segment": "Result" + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "]" + } + ], + "tag": "UserObject" + }, + "tag": "Test" + } +-- function +GET /api/projects/scratch/branches/main/definitions/terms/by-hash/@6ee6j48hk3eovokflkgbmpbfr3oqj4hedqn8ocg3i4i0ko8j7nls7njjirmnh4k2bg8h95seaot798uuloqk62u2ttiqoceulkbmq2o/summary?name=func + { + "displayName": "func", + "hash": "#6ee6j48hk3eovokflkgbmpbfr3oqj4hedqn8ocg3i4i0ko8j7nls7njjirmnh4k2bg8h95seaot798uuloqk62u2ttiqoceulkbmq2o", + "summary": { + "contents": [ + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + } + ], + "tag": "UserObject" + }, + "tag": "Plain" + } +-- constructor +GET /api/projects/scratch/branches/main/definitions/terms/by-hash/@altimqs66j3dh94dpab5pg7j5adjrndq61n803j7fg0v0ohdiut6or66bu1fiongpd45s5euiuo8ru47b928aqv8osln1ikdeg05hq0@d0/summary?name=Thing.This + { + "displayName": "Thing.This", + "hash": "#altimqs66j3dh94dpab5pg7j5adjrndq61n803j7fg0v0ohdiut6or66bu1fiongpd45s5euiuo8ru47b928aqv8osln1ikdeg05hq0#0", + "summary": { + "contents": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#altimqs66j3dh94dpab5pg7j5adjrndq61n803j7fg0v0ohdiut6or66bu1fiongpd45s5euiuo8ru47b928aqv8osln1ikdeg05hq0", + "tag": "TypeReference" + }, + "segment": "Thing" + } + ], + "tag": "UserObject" + }, + "tag": "DataConstructor" + } +-- Long type signature +GET /api/projects/scratch/branches/main/definitions/terms/by-hash/@ieskgcjjvuegpecq9pbha59ttonke7pf31keeq0jlh31ijkfq00e06fdi36ae90u24pjva6ucqdbedropjgi3g3b75nu76ll5ls8ke8/summary?name=funcWithLongType + { + "displayName": "funcWithLongType", + "hash": "#ieskgcjjvuegpecq9pbha59ttonke7pf31keeq0jlh31ijkfq00e06fdi36ae90u24pjva6ucqdbedropjgi3g3b75nu76ll5ls8ke8", + "summary": { + "contents": [ + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + } + ], + "tag": "UserObject" + }, + "tag": "Plain" + } +-- Long type signature with render width +GET /api/projects/scratch/branches/main/definitions/terms/by-hash/@ieskgcjjvuegpecq9pbha59ttonke7pf31keeq0jlh31ijkfq00e06fdi36ae90u24pjva6ucqdbedropjgi3g3b75nu76ll5ls8ke8/summary?renderWidth=20&name=funcWithLongType + { + "displayName": "funcWithLongType", + "hash": "#ieskgcjjvuegpecq9pbha59ttonke7pf31keeq0jlh31ijkfq00e06fdi36ae90u24pjva6ucqdbedropjgi3g3b75nu76ll5ls8ke8", + "summary": { + "contents": [ + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + } + ], + "tag": "UserObject" + }, + "tag": "Plain" + } +-- Builtin Term +GET /api/projects/scratch/branches/main/definitions/terms/by-hash/@@IO.putBytes.impl.v3/summary?name=putBytesImpl + { + "displayName": "putBytesImpl", + "hash": "##IO.putBytes.impl.v3", + "summary": { + "contents": [ + { + "annotation": { + "contents": "##Handle", + "tag": "TypeReference" + }, + "segment": "Handle" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Bytes", + "tag": "TypeReference" + }, + "segment": "Bytes" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "contents": "##IO", + "tag": "TypeReference" + }, + "segment": "IO" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#0o7mf021foma9acqdaibmlh1jidlijq08uf7f5se9tssttqs546pfunjpk6s31mqoq8s2o1natede8hkk6he45l95fibglidikt44v8", + "tag": "TypeReference" + }, + "segment": "Either" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#r29dja8j9dmjjp45trccchaata8eo1h6d6haar1eai74pq1jt4m7u3ldhlq79f7phfo57eq4bau39vqotl2h63k7ff1m5sj5o9ajuf8", + "tag": "TypeReference" + }, + "segment": "Failure" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": "(" + }, + { + "annotation": null, + "segment": ")" + } + ], + "tag": "BuiltinObject" + }, + "tag": "Plain" + } +``` + +## Type Summary APIs + +``` api +-- data +GET /api/projects/scratch/branches/main/definitions/types/by-hash/@altimqs66j3dh94dpab5pg7j5adjrndq61n803j7fg0v0ohdiut6or66bu1fiongpd45s5euiuo8ru47b928aqv8osln1ikdeg05hq0/summary?name=Thing + { + "displayName": "Thing", + "hash": "#altimqs66j3dh94dpab5pg7j5adjrndq61n803j7fg0v0ohdiut6or66bu1fiongpd45s5euiuo8ru47b928aqv8osln1ikdeg05hq0", + "summary": { + "contents": [ + { + "annotation": { + "tag": "DataTypeModifier" + }, + "segment": "structural" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DataTypeKeyword" + }, + "segment": "type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "Thing", + "tag": "HashQualifier" + }, + "segment": "Thing" + } + ], + "tag": "UserObject" + }, + "tag": "Data" + } +-- data with type args +GET /api/projects/scratch/branches/main/definitions/types/by-hash/@nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg/summary?name=Maybe + { + "displayName": "Maybe", + "hash": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg", + "summary": { + "contents": [ + { + "annotation": { + "tag": "DataTypeModifier" + }, + "segment": "structural" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DataTypeKeyword" + }, + "segment": "type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "Maybe", + "tag": "HashQualifier" + }, + "segment": "Maybe" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DataTypeParams" + }, + "segment": "a" + } + ], + "tag": "UserObject" + }, + "tag": "Data" + } +-- ability +GET /api/projects/scratch/branches/main/definitions/types/by-hash/@rfi1v9429f9qluv533l2iba77aadttilrpmnhljfapfnfa6sru2nr8ibpqvib9nc4s4nb9s1as45upsfqfqe6ivqi2p82b2vd866it8/summary?name=Stream + { + "displayName": "Stream", + "hash": "#rfi1v9429f9qluv533l2iba77aadttilrpmnhljfapfnfa6sru2nr8ibpqvib9nc4s4nb9s1as45upsfqfqe6ivqi2p82b2vd866it8", + "summary": { + "contents": [ + { + "annotation": { + "tag": "DataTypeModifier" + }, + "segment": "structural" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DataTypeKeyword" + }, + "segment": "ability" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "Stream", + "tag": "HashQualifier" + }, + "segment": "Stream" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DataTypeParams" + }, + "segment": "s" + } + ], + "tag": "UserObject" + }, + "tag": "Ability" + } +-- builtin type +GET /api/projects/scratch/branches/main/definitions/types/by-hash/@@Nat/summary?name=Nat + { + "displayName": "Nat", + "hash": "##Nat", + "summary": { + "contents": [ + { + "annotation": null, + "segment": "Nat" + } + ], + "tag": "BuiltinObject" + }, + "tag": "Data" + } +``` diff --git a/unison-src/transcripts/idempotent/block-on-required-update.md b/unison-src/transcripts/idempotent/block-on-required-update.md new file mode 100644 index 0000000000..4f69704692 --- /dev/null +++ b/unison-src/transcripts/idempotent/block-on-required-update.md @@ -0,0 +1,69 @@ +# Block on required update + +Should block an `add` if it requires an update on an in-file dependency. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +x = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + x : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + x : Nat +``` + +Update `x`, and add a new `y` which depends on the update + +``` unison +x = 10 +y = x + 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + y : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + x : Nat +``` + +Try to add only the new `y`. This should fail because it requires an update to `x`, but we only ran an 'add'. + +``` ucm :error +scratch/main> add y + + x These definitions failed: + + Reason + needs update x : Nat + blocked y : Nat + + Tip: Use `help filestatus` to learn more. +``` diff --git a/unison-src/transcripts/idempotent/blocks.md b/unison-src/transcripts/idempotent/blocks.md new file mode 100644 index 0000000000..167c580bb3 --- /dev/null +++ b/unison-src/transcripts/idempotent/blocks.md @@ -0,0 +1,352 @@ +## Blocks and scoping + +``` ucm :hide +scratch/main> builtins.merge +``` + +### Names introduced by a block shadow names introduced in outer scopes + +For example: + +``` unison +ex thing = + thing y = y + -- refers to `thing` in this block + -- not the argument to `ex` + bar x = thing x + 1 + bar 42 + +> ex "hello" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex : thing -> Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 8 | > ex "hello" + ⧩ + 43 +``` + +### Whether a block shadows outer names doesn't depend on the order of bindings in the block + +The `thing` reference in `bar` refers to the one declared locally in the block that `bar` is part of. This is true even if the declaration which shadows the outer name appears later in the block, for instance: + +``` unison +ex thing = + bar x = thing x + 1 + thing y = y + bar 42 + +> ex "hello" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex : thing -> Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 6 | > ex "hello" + ⧩ + 43 +``` + +### Blocks use lexical scoping and can only reference definitions in parent scopes or in the same block + +This is just the normal lexical scoping behavior. For example: + +``` unison +ex thing = + bar x = thing x + 1 -- references outer `thing` + baz z = + thing y = y -- shadows the outer `thing` + thing z -- references the inner `thing` + bar 42 + +> ex (x -> x * 100) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex : (Nat ->{g} Nat) ->{g} Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 8 | > ex (x -> x * 100) + ⧩ + 4201 +``` + +Here's another example, showing that bindings cannot reference bindings declared in blocks nested in the *body* (the final expression) of a block: + +``` unison +ex thing = + bar x = thing x + 1 -- refers to outer thing + let + thing y = y + bar 42 + +> ex (x -> x * 100) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex : (Nat ->{g} Nat) ->{g} Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 7 | > ex (x -> x * 100) + ⧩ + 4201 +``` + +### Blocks can define one or more functions which are recursive or mutually recursive + +We call these groups of definitions that reference each other in a block *cycles*. For instance: + +``` unison +sumTo n = + -- A recursive function, defined inside a block + go acc n = + if n == 0 then acc + else go (acc + n) (drop n 1) + go 0 n + +ex n = + -- Two mutually recursive functions, defined in a block + ping x = pong (x + 1) + pong x = ping (x + 2) + ping 42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex : n -> r + sumTo : Nat -> Nat +``` + +The `go` function is a one-element cycle (it reference itself), and `ping` and `pong` form a two-element cycle. + +### Cyclic references or forward reference must be guarded + +For instance, this works: + +``` unison +ex n = + ping x = pong + 1 + x + pong = 42 + ping 0 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex : n -> Nat +``` + +Since the forward reference to `pong` appears inside `ping`. + +This, however, will not compile: + +``` unison :error +ex n = + pong = ping + 1 + ping = 42 + pong +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + These definitions depend on each other cyclically but aren't guarded by a lambda: pong8 + 2 | pong = ping + 1 + 3 | ping = 42 +``` + +This also won't compile; it's a cyclic reference that isn't guarded: + +``` unison :error +ex n = + loop = loop + loop +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + These definitions depend on each other cyclically but aren't guarded by a lambda: loop8 + 2 | loop = loop +``` + +This, however, will compile. This also shows that `'expr` is another way of guarding a definition. + +``` unison +ex n = + loop = '(!loop) + !loop +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex : n -> r +``` + +Just don't try to run it as it's an infinite loop\! + +### Cyclic definitions in a block don't have access to any abilities + +The reason is it's unclear what the order should be of any requests that are made. It can also be viewed of a special case of the restriction that elements of a cycle must all be guarded. Here's an example: + +``` unison :error +structural ability SpaceAttack where + launchMissiles : Text -> Nat + +ex n = + zap1 = launchMissiles "neptune" + zap2 + zap2 = launchMissiles "pluto" + zap1 + zap1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + The expression in red needs the {SpaceAttack} ability, but this location does not have access to any abilities. + + 5 | zap1 = launchMissiles "neptune" + zap2 +``` + +### The *body* of recursive functions can certainly access abilities + +For instance, this works fine: + +``` unison +structural ability SpaceAttack where + launchMissiles : Text -> Nat + +ex n = + zap1 planet = launchMissiles planet + zap2 planet + zap2 planet = launchMissiles planet + zap1 planet + zap1 "pluto" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability SpaceAttack + ex : n ->{SpaceAttack} Nat +``` + +### Unrelated definitions not part of a cycle and are moved after the cycle + +For instance, `zap` here isn't considered part of the cycle (it doesn't reference `ping` or `pong`), so this typechecks fine: + +``` unison +structural ability SpaceAttack where + launchMissiles : Text -> Nat + +ex n = + ping x = pong (x + 1) + zap = launchMissiles "neptune" + pong x = ping (x + 2) + ping 42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability SpaceAttack + ex : n ->{SpaceAttack} r +``` + +This is actually parsed as if you moved `zap` after the cycle it find itself a part of: + +``` unison +structural ability SpaceAttack where + launchMissiles : Text -> Nat + +ex n = + ping x = pong (x + 1) + pong x = ping (x + 2) + zap = launchMissiles "neptune" + ping 42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability SpaceAttack + ex : n ->{SpaceAttack} r +``` diff --git a/unison-src/transcripts/idempotent/boolean-op-pretty-print-2819.md b/unison-src/transcripts/idempotent/boolean-op-pretty-print-2819.md new file mode 100644 index 0000000000..420466b531 --- /dev/null +++ b/unison-src/transcripts/idempotent/boolean-op-pretty-print-2819.md @@ -0,0 +1,39 @@ +Regression test for https://github.com/unisonweb/unison/pull/2819 + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +hangExample : Boolean +hangExample = + ("a long piece of text to hang the line" == "") + && ("a long piece of text to hang the line" == "") +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + hangExample : Boolean +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + hangExample : Boolean + +scratch/main> view hangExample + + hangExample : Boolean + hangExample = + "a long piece of text to hang the line" == "" + && "a long piece of text to hang the line" == "" +``` diff --git a/unison-src/transcripts/idempotent/branch-command.md b/unison-src/transcripts/idempotent/branch-command.md new file mode 100644 index 0000000000..67e97a1b4c --- /dev/null +++ b/unison-src/transcripts/idempotent/branch-command.md @@ -0,0 +1,187 @@ +The `branch` command creates a new branch. + +``` ucm :hide +scratch/main> project.create-empty foo + +scratch/main> project.create-empty bar +``` + +First, we'll create a term to include in the branches. + +``` unison :hide +someterm = 18 +``` + +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. + +scratch/main> add + + ⍟ I've added these definitions: + + someterm : Nat +``` + +Now, the `branch` demo: + +`branch` can create a branch from a different branch in the same project, from a different branch in a different +project. It can also create an empty branch. + +``` ucm +foo/main> branch topic1 + + Done. I've created the topic1 branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic1`. + +foo/main> branch /topic2 + + Done. I've created the topic2 branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic2`. + +foo/main> branch foo/topic3 + + Done. I've created the topic3 branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic3`. + +foo/main> branch main topic4 + + Done. I've created the topic4 branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic4`. + +foo/main> branch main /topic5 + + Done. I've created the topic5 branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic5`. + +foo/main> branch main foo/topic6 + + Done. I've created the topic6 branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic6`. + +foo/main> branch /main topic7 + + Done. I've created the topic7 branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic7`. + +foo/main> branch /main /topic8 + + Done. I've created the topic8 branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic8`. + +foo/main> branch /main foo/topic9 + + Done. I've created the topic9 branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic9`. + +foo/main> branch foo/main topic10 + + Done. I've created the topic10 branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic10`. + +foo/main> branch foo/main /topic11 + + Done. I've created the topic11 branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic11`. + +scratch/main> branch foo/main foo/topic12 + + Done. I've created the topic12 branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic12`. + +foo/main> branch bar/topic + + Done. I've created the bar/topic branch based off foo/main. + +bar/main> branch foo/main topic2 + + Done. I've created the bar/topic2 branch based off foo/main. + +bar/main> branch foo/main /topic3 + + Done. I've created the bar/topic3 branch based off foo/main. + +scratch/main> branch foo/main bar/topic4 + + Done. I've created the bar/topic4 branch based off foo/main. + +foo/main> branch.empty empty1 + + Done. I've created an empty branch foo/empty1. + + Tip: Use `merge /somebranch` to initialize this branch. + +foo/main> branch.empty /empty2 + + Done. I've created an empty branch foo/empty2. + + Tip: Use `merge /somebranch` to initialize this branch. + +foo/main> branch.empty foo/empty3 + + Done. I've created an empty branch foo/empty3. + + Tip: Use `merge /somebranch` to initialize this branch. + +scratch/main> branch.empty foo/empty4 + + Done. I've created an empty branch foo/empty4. + + Tip: Use `merge /somebranch` to initialize this branch. +``` + +The `branch` command can create branches named `releases/drafts/*` (because why not). + +``` ucm +foo/main> branch releases/drafts/1.2.3 + + Done. I've created the releases/drafts/1.2.3 branch based off + of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /releases/drafts/1.2.3`. + +foo/main> switch /releases/drafts/1.2.3 +``` + +The `branch` command can't create branches named `releases/*` nor `releases/drafts/*`. + +``` ucm :error +foo/main> branch releases/1.2.3 + + Branch names like releases/1.2.3 are reserved for releases. + + Tip: to download an existing release, try + `clone /releases/1.2.3`. + + Tip: to draft a new release, try `release.draft 1.2.3`. + +foo/main> switch /releases/1.2.3 + + foo/releases/1.2.3 does not exist. +``` diff --git a/unison-src/transcripts/idempotent/branch-relative-path.md b/unison-src/transcripts/idempotent/branch-relative-path.md new file mode 100644 index 0000000000..67775adbb8 --- /dev/null +++ b/unison-src/transcripts/idempotent/branch-relative-path.md @@ -0,0 +1,92 @@ +``` unison +foo = 5 +foo.bar = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : ##Nat + foo.bar : ##Nat +``` + +``` ucm +p0/main> add + + ⍟ I've added these definitions: + + foo : ##Nat + foo.bar : ##Nat +``` + +``` unison +bonk = 5 +donk.bonk = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bonk : ##Nat + (also named foo) + donk.bonk : ##Nat + (also named foo.bar) +``` + +``` ucm +p1/main> add + + ⍟ I've added these definitions: + + bonk : ##Nat + donk.bonk : ##Nat + +p1/main> fork p0/main: zzz + + Done. + +p1/main> find zzz + + 1. zzz.foo : ##Nat + 2. zzz.foo.bar : ##Nat + +p1/main> fork p0/main:foo yyy + + Done. + +p1/main> find yyy + + 1. yyy.bar : ##Nat + +p0/main> fork p1/main: p0/main:p1 + + Done. + +p0/main> ls p1 + + 1. bonk (##Nat) + 2. donk/ (1 term) + 3. yyy/ (1 term) + 4. zzz/ (2 terms) + +p0/main> ls p1.zzz + + 1. foo (##Nat) + 2. foo/ (1 term) + +p0/main> ls p1.yyy + + 1. bar (##Nat) +``` diff --git a/unison-src/transcripts/idempotent/bug-fix-4354.md b/unison-src/transcripts/idempotent/bug-fix-4354.md new file mode 100644 index 0000000000..878dfce1f7 --- /dev/null +++ b/unison-src/transcripts/idempotent/bug-fix-4354.md @@ -0,0 +1,25 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +bonk : forall a. a -> a +bonk x = + zonk : forall a. a -> a + zonk z = z + honk : a + honk = x + x +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bonk : a -> a +``` diff --git a/unison-src/transcripts/idempotent/bug-strange-closure.md b/unison-src/transcripts/idempotent/bug-strange-closure.md new file mode 100644 index 0000000000..15c5aace2d --- /dev/null +++ b/unison-src/transcripts/idempotent/bug-strange-closure.md @@ -0,0 +1,4526 @@ +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins + +scratch/main> load unison-src/transcripts-using-base/doc.md.files/syntax.u +``` + +We can display the guide before and after adding it to the codebase: + +```` ucm +scratch/main> display doc.guide + + # Unison computable documentation + + # Basic formatting + + Paragraphs are separated by one or more blanklines. + Sections have a title and 0 or more paragraphs or other + section elements. + + Text can be bold, *italicized*, ~~strikethrough~~, or + `monospaced` (or `monospaced`). + + You can link to Unison terms, types, and external URLs: + + * An external url + * Some is a term link; Optional is a type link + * A named type link and a named term link. Term links are + handy for linking to other documents! + + You can use `{{ .. }}` to escape out to regular Unison + syntax, for instance __not bold__. This is useful for + creating documents programmatically or just including + other documents. + + *Next up:* lists + + # Lists + + # Bulleted lists + + Bulleted lists can use `+`, `-`, or `*` for the bullets + (though the choice will be normalized away by the + pretty-printer). They can be nested, to any depth: + + * A + * B + * C + * C1 + * C2 + + # Numbered lists + + 1. A + 2. B + 3. C + + The first number of the list determines the starting + number in the rendered output. The other numbers are + ignored: + + 10. A + 11. B + 12. C + + Numbered lists can be nested as well, and combined with + bulleted lists: + + 1. Wake up. + * What am I doing here? + * In this nested list. + 2. Take shower. + 3. Get dressed. + + # Evaluation + + Expressions can be evaluated inline, for instance `2`. + + Blocks of code can be evaluated as well, for instance: + + id x = x + id (sqr 10) + ⧨ + 100 + + also: + + match 1 with + 1 -> "hi" + _ -> "goodbye" + ⧨ + "hi" + + To include a typechecked snippet of code without + evaluating it, you can do: + + use Nat * + cube : Nat -> Nat + cube x = x * x * x + + # Including Unison source code + + Unison definitions can be included in docs. For instance: + + structural type Optional a = Some a | None + + sqr : Nat -> Nat + sqr x = + use Nat * + x * x + + Some rendering targets also support folded source: + + structural type Optional a = Some a | None + + sqr : Nat -> Nat + sqr x = + use Nat * + x * x + + You can also include just a signature, inline, with + `sqr : Nat -> Nat`, or you can include one or more + signatures as a block: + + sqr : Nat -> Nat + + Nat.+ : Nat -> Nat -> Nat + + Or alternately: + + List.map : (a ->{e} b) -> [a] ->{e} [b] + + # Inline snippets + + You can include typechecked code snippets inline, for + instance: + + * `f x Nat.+ sqr 1` - the `2` says to ignore the first + two arguments when rendering. In richer renderers, the + `sqr` link will be clickable. + * If your snippet expression is just a single function + application, you can put it in double backticks, like + so: `sqr x`. This is equivalent to `sqr x`. + + # Non-Unison code blocks + + Use three or more single quotes to start a block with no + syntax highlighting: + + ``` raw + _____ _ + | | |___|_|___ ___ ___ + | | | | |_ -| . | | + |_____|_|_|_|___|___|_|_| + + ``` + + You can use three or more backticks plus a language name + for blocks with syntax highlighting: + + ``` Haskell + -- A fenced code block which isn't parsed by Unison + reverse = foldl (flip (:)) [] + ``` + + ``` Scala + // A fenced code block which isn't parsed by Unison + def reverse[A](xs: List[A]) = + xs.foldLeft(Nil : List[A])((acc,a) => a +: acc) + ``` + + There are also asides, callouts, tables, tooltips, and more. + These don't currently have special syntax; just use the + `{{ }}` syntax to call these functions directly. + + docAside : Doc2 -> Doc2 + + docCallout : Optional Doc2 -> Doc2 -> Doc2 + + docBlockquote : Doc2 -> Doc2 + + docTooltip : Doc2 -> Doc2 -> Doc2 + + docTable : [[Doc2]] -> Doc2 + + This is an aside. ( + Some extra detail that doesn't belong in main text. ) + + | This is an important callout, with no icon. + + | 🌻 + | + | This is an important callout, with an icon. The text + | wraps onto multiple lines. + + > "And what is the use of a book," thought Alice, "without + > pictures or conversation?" + > + > *Lewis Carroll, Alice's Adventures in Wonderland* + + Hover over me + + a b A longer paragraph that will split + onto multiple lines, such that this + row occupies multiple lines in the + rendered table. + Some text More text Zounds! + +scratch/main> add + + ⍟ I've added these definitions: + + basicFormatting : Doc2 + doc.guide : Doc2 + evaluation : Doc2 + includingSource : Doc2 + lists : Doc2 + nonUnisonCodeBlocks : Doc2 + otherElements : Doc2 + sqr : Nat -> Nat + +scratch/main> display doc.guide + + # Unison computable documentation + + # Basic formatting + + Paragraphs are separated by one or more blanklines. + Sections have a title and 0 or more paragraphs or other + section elements. + + Text can be bold, *italicized*, ~~strikethrough~~, or + `monospaced` (or `monospaced`). + + You can link to Unison terms, types, and external URLs: + + * An external url + * Some is a term link; Optional is a type link + * A named type link and a named term link. Term links are + handy for linking to other documents! + + You can use `{{ .. }}` to escape out to regular Unison + syntax, for instance __not bold__. This is useful for + creating documents programmatically or just including + other documents. + + *Next up:* lists + + # Lists + + # Bulleted lists + + Bulleted lists can use `+`, `-`, or `*` for the bullets + (though the choice will be normalized away by the + pretty-printer). They can be nested, to any depth: + + * A + * B + * C + * C1 + * C2 + + # Numbered lists + + 1. A + 2. B + 3. C + + The first number of the list determines the starting + number in the rendered output. The other numbers are + ignored: + + 10. A + 11. B + 12. C + + Numbered lists can be nested as well, and combined with + bulleted lists: + + 1. Wake up. + * What am I doing here? + * In this nested list. + 2. Take shower. + 3. Get dressed. + + # Evaluation + + Expressions can be evaluated inline, for instance `2`. + + Blocks of code can be evaluated as well, for instance: + + id x = x + id (sqr 10) + ⧨ + 100 + + also: + + match 1 with + 1 -> "hi" + _ -> "goodbye" + ⧨ + "hi" + + To include a typechecked snippet of code without + evaluating it, you can do: + + use Nat * + cube : Nat -> Nat + cube x = x * x * x + + # Including Unison source code + + Unison definitions can be included in docs. For instance: + + structural type Optional a = Some a | None + + sqr : Nat -> Nat + sqr x = + use Nat * + x * x + + Some rendering targets also support folded source: + + structural type Optional a = Some a | None + + sqr : Nat -> Nat + sqr x = + use Nat * + x * x + + You can also include just a signature, inline, with + `sqr : Nat -> Nat`, or you can include one or more + signatures as a block: + + sqr : Nat -> Nat + + Nat.+ : Nat -> Nat -> Nat + + Or alternately: + + List.map : (a ->{e} b) -> [a] ->{e} [b] + + # Inline snippets + + You can include typechecked code snippets inline, for + instance: + + * `f x Nat.+ sqr 1` - the `2` says to ignore the first + two arguments when rendering. In richer renderers, the + `sqr` link will be clickable. + * If your snippet expression is just a single function + application, you can put it in double backticks, like + so: `sqr x`. This is equivalent to `sqr x`. + + # Non-Unison code blocks + + Use three or more single quotes to start a block with no + syntax highlighting: + + ``` raw + _____ _ + | | |___|_|___ ___ ___ + | | | | |_ -| . | | + |_____|_|_|_|___|___|_|_| + + ``` + + You can use three or more backticks plus a language name + for blocks with syntax highlighting: + + ``` Haskell + -- A fenced code block which isn't parsed by Unison + reverse = foldl (flip (:)) [] + ``` + + ``` Scala + // A fenced code block which isn't parsed by Unison + def reverse[A](xs: List[A]) = + xs.foldLeft(Nil : List[A])((acc,a) => a +: acc) + ``` + + There are also asides, callouts, tables, tooltips, and more. + These don't currently have special syntax; just use the + `{{ }}` syntax to call these functions directly. + + docAside : Doc2 -> Doc2 + + docCallout : Optional Doc2 -> Doc2 -> Doc2 + + docBlockquote : Doc2 -> Doc2 + + docTooltip : Doc2 -> Doc2 -> Doc2 + + docTable : [[Doc2]] -> Doc2 + + This is an aside. ( + Some extra detail that doesn't belong in main text. ) + + | This is an important callout, with no icon. + + | 🌻 + | + | This is an important callout, with an icon. The text + | wraps onto multiple lines. + + > "And what is the use of a book," thought Alice, "without + > pictures or conversation?" + > + > *Lewis Carroll, Alice's Adventures in Wonderland* + + Hover over me + + a b A longer paragraph that will split + onto multiple lines, such that this + row occupies multiple lines in the + rendered table. + Some text More text Zounds! +```` + +But we can't display this due to a decompilation problem. + +``` unison +rendered = Pretty.get (docFormatConsole doc.guide) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + rendered : Annotated () (Either SpecialForm ConsoleText) +``` + +```` ucm +scratch/main> display rendered + + # Unison computable documentation + + # Basic formatting + + Paragraphs are separated by one or more blanklines. + Sections have a title and 0 or more paragraphs or other + section elements. + + Text can be bold, *italicized*, ~~strikethrough~~, or + `monospaced` (or `monospaced`). + + You can link to Unison terms, types, and external URLs: + + * An external url + * Some is a term link; Optional is a type link + * A named type link and a named term link. Term links are + handy for linking to other documents! + + You can use `{{ .. }}` to escape out to regular Unison + syntax, for instance __not bold__. This is useful for + creating documents programmatically or just including + other documents. + + *Next up:* lists + + # Lists + + # Bulleted lists + + Bulleted lists can use `+`, `-`, or `*` for the bullets + (though the choice will be normalized away by the + pretty-printer). They can be nested, to any depth: + + * A + * B + * C + * C1 + * C2 + + # Numbered lists + + 1. A + 2. B + 3. C + + The first number of the list determines the starting + number in the rendered output. The other numbers are + ignored: + + 10. A + 11. B + 12. C + + Numbered lists can be nested as well, and combined with + bulleted lists: + + 1. Wake up. + * What am I doing here? + * In this nested list. + 2. Take shower. + 3. Get dressed. + + # Evaluation + + Expressions can be evaluated inline, for instance `2`. + + Blocks of code can be evaluated as well, for instance: + + id x = x + id (sqr 10) + ⧨ + 100 + + also: + + match 1 with + 1 -> "hi" + _ -> "goodbye" + ⧨ + "hi" + + To include a typechecked snippet of code without + evaluating it, you can do: + + use Nat * + cube : Nat -> Nat + cube x = x * x * x + + # Including Unison source code + + Unison definitions can be included in docs. For instance: + + structural type Optional a = Some a | None + + sqr : Nat -> Nat + sqr x = + use Nat * + x * x + + Some rendering targets also support folded source: + + structural type Optional a = Some a | None + + sqr : Nat -> Nat + sqr x = + use Nat * + x * x + + You can also include just a signature, inline, with + `sqr : Nat -> Nat`, or you can include one or more + signatures as a block: + + sqr : Nat -> Nat + + Nat.+ : Nat -> Nat -> Nat + + Or alternately: + + List.map : (a ->{e} b) -> [a] ->{e} [b] + + # Inline snippets + + You can include typechecked code snippets inline, for + instance: + + * `f x Nat.+ sqr 1` - the `2` says to ignore the first + two arguments when rendering. In richer renderers, the + `sqr` link will be clickable. + * If your snippet expression is just a single function + application, you can put it in double backticks, like + so: `sqr x`. This is equivalent to `sqr x`. + + # Non-Unison code blocks + + Use three or more single quotes to start a block with no + syntax highlighting: + + ``` raw + _____ _ + | | |___|_|___ ___ ___ + | | | | |_ -| . | | + |_____|_|_|_|___|___|_|_| + + ``` + + You can use three or more backticks plus a language name + for blocks with syntax highlighting: + + ``` Haskell + -- A fenced code block which isn't parsed by Unison + reverse = foldl (flip (:)) [] + ``` + + ``` Scala + // A fenced code block which isn't parsed by Unison + def reverse[A](xs: List[A]) = + xs.foldLeft(Nil : List[A])((acc,a) => a +: acc) + ``` + + There are also asides, callouts, tables, tooltips, and more. + These don't currently have special syntax; just use the + `{{ }}` syntax to call these functions directly. + + docAside : Doc2 -> Doc2 + + docCallout : Optional Doc2 -> Doc2 -> Doc2 + + docBlockquote : Doc2 -> Doc2 + + docTooltip : Doc2 -> Doc2 -> Doc2 + + docTable : [[Doc2]] -> Doc2 + + This is an aside. ( + Some extra detail that doesn't belong in main text. ) + + | This is an important callout, with no icon. + + | 🌻 + | + | This is an important callout, with an icon. The text + | wraps onto multiple lines. + + > "And what is the use of a book," thought Alice, "without + > pictures or conversation?" + > + > *Lewis Carroll, Alice's Adventures in Wonderland* + + Hover over me + + a b A longer paragraph that will split + onto multiple lines, such that this + row occupies multiple lines in the + rendered table. + Some text More text Zounds! + +scratch/main> add + + ⍟ I've added these definitions: + + rendered : Annotated () (Either SpecialForm ConsoleText) + +scratch/main> display rendered + + # Unison computable documentation + + # Basic formatting + + Paragraphs are separated by one or more blanklines. + Sections have a title and 0 or more paragraphs or other + section elements. + + Text can be bold, *italicized*, ~~strikethrough~~, or + `monospaced` (or `monospaced`). + + You can link to Unison terms, types, and external URLs: + + * An external url + * Some is a term link; Optional is a type link + * A named type link and a named term link. Term links are + handy for linking to other documents! + + You can use `{{ .. }}` to escape out to regular Unison + syntax, for instance __not bold__. This is useful for + creating documents programmatically or just including + other documents. + + *Next up:* lists + + # Lists + + # Bulleted lists + + Bulleted lists can use `+`, `-`, or `*` for the bullets + (though the choice will be normalized away by the + pretty-printer). They can be nested, to any depth: + + * A + * B + * C + * C1 + * C2 + + # Numbered lists + + 1. A + 2. B + 3. C + + The first number of the list determines the starting + number in the rendered output. The other numbers are + ignored: + + 10. A + 11. B + 12. C + + Numbered lists can be nested as well, and combined with + bulleted lists: + + 1. Wake up. + * What am I doing here? + * In this nested list. + 2. Take shower. + 3. Get dressed. + + # Evaluation + + Expressions can be evaluated inline, for instance `2`. + + Blocks of code can be evaluated as well, for instance: + + id x = x + id (sqr 10) + ⧨ + 100 + + also: + + match 1 with + 1 -> "hi" + _ -> "goodbye" + ⧨ + "hi" + + To include a typechecked snippet of code without + evaluating it, you can do: + + use Nat * + cube : Nat -> Nat + cube x = x * x * x + + # Including Unison source code + + Unison definitions can be included in docs. For instance: + + structural type Optional a = Some a | None + + sqr : Nat -> Nat + sqr x = + use Nat * + x * x + + Some rendering targets also support folded source: + + structural type Optional a = Some a | None + + sqr : Nat -> Nat + sqr x = + use Nat * + x * x + + You can also include just a signature, inline, with + `sqr : Nat -> Nat`, or you can include one or more + signatures as a block: + + sqr : Nat -> Nat + + Nat.+ : Nat -> Nat -> Nat + + Or alternately: + + List.map : (a ->{e} b) -> [a] ->{e} [b] + + # Inline snippets + + You can include typechecked code snippets inline, for + instance: + + * `f x Nat.+ sqr 1` - the `2` says to ignore the first + two arguments when rendering. In richer renderers, the + `sqr` link will be clickable. + * If your snippet expression is just a single function + application, you can put it in double backticks, like + so: `sqr x`. This is equivalent to `sqr x`. + + # Non-Unison code blocks + + Use three or more single quotes to start a block with no + syntax highlighting: + + ``` raw + _____ _ + | | |___|_|___ ___ ___ + | | | | |_ -| . | | + |_____|_|_|_|___|___|_|_| + + ``` + + You can use three or more backticks plus a language name + for blocks with syntax highlighting: + + ``` Haskell + -- A fenced code block which isn't parsed by Unison + reverse = foldl (flip (:)) [] + ``` + + ``` Scala + // A fenced code block which isn't parsed by Unison + def reverse[A](xs: List[A]) = + xs.foldLeft(Nil : List[A])((acc,a) => a +: acc) + ``` + + There are also asides, callouts, tables, tooltips, and more. + These don't currently have special syntax; just use the + `{{ }}` syntax to call these functions directly. + + docAside : Doc2 -> Doc2 + + docCallout : Optional Doc2 -> Doc2 -> Doc2 + + docBlockquote : Doc2 -> Doc2 + + docTooltip : Doc2 -> Doc2 -> Doc2 + + docTable : [[Doc2]] -> Doc2 + + This is an aside. ( + Some extra detail that doesn't belong in main text. ) + + | This is an important callout, with no icon. + + | 🌻 + | + | This is an important callout, with an icon. The text + | wraps onto multiple lines. + + > "And what is the use of a book," thought Alice, "without + > pictures or conversation?" + > + > *Lewis Carroll, Alice's Adventures in Wonderland* + + Hover over me + + a b A longer paragraph that will split + onto multiple lines, such that this + row occupies multiple lines in the + rendered table. + Some text More text Zounds! + +scratch/main> undo + + Here are the changes I undid + + Added definitions: + + 1. rendered : Annotated () (Either SpecialForm ConsoleText) +```` + +And then this sometimes generates a GHC crash "strange closure error" but doesn't seem deterministic. + +``` unison +rendered = Pretty.get (docFormatConsole doc.guide) + +> rendered +``` + +```` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + rendered : Annotated () (Either SpecialForm ConsoleText) + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 3 | > rendered + ⧩ + Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit () (Right (Plain "# "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (ConsoleText.Bold (Plain "Unison"))) + , Lit + () + (Right + (ConsoleText.Bold + (Plain "computable"))) + , Lit + () + (Right + (ConsoleText.Bold + (Plain "documentation"))) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit () (Right (Plain "# "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (ConsoleText.Bold + (Plain "Basic"))) + , Lit + () + (Right + (ConsoleText.Bold + (Plain "formatting"))) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain "Paragraphs")) + , Lit + () (Right (Plain "are")) + , Lit + () + (Right + (Plain "separated")) + , Lit + () (Right (Plain "by")) + , Lit + () (Right (Plain "one")) + , Lit + () (Right (Plain "or")) + , Lit + () + (Right (Plain "more")) + , Lit + () + (Right + (Plain "blanklines.")) + , Lit + () + (Right + (Plain "Sections")) + , Lit + () + (Right (Plain "have")) + , Lit () (Right (Plain "a")) + , Lit + () + (Right (Plain "title")) + , Lit + () (Right (Plain "and")) + , Lit () (Right (Plain "0")) + , Lit + () (Right (Plain "or")) + , Lit + () + (Right (Plain "more")) + , Lit + () + (Right + (Plain "paragraphs")) + , Lit + () (Right (Plain "or")) + , Lit + () + (Right (Plain "other")) + , Lit + () + (Right (Plain "section")) + , Lit + () + (Right + (Plain "elements.")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "Text")) + , Lit + () (Right (Plain "can")) + , Lit + () (Right (Plain "be")) + , Annotated.Group + () + (Annotated.Append + () + [ Wrap + () + (Lit + () + (Right + (ConsoleText.Bold + (Plain + "bold")))) + , Lit + () + (Right (Plain ",")) + ]) + , Annotated.Group + () + (Annotated.Append + () + [ Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain "*")) + , Wrap + () + (Lit + () + (Right + (Plain + "italicized"))) + , Lit + () + (Right + (Plain "*")) + ]) + , Lit + () + (Right (Plain ",")) + ]) + , Annotated.Group + () + (Annotated.Append + () + [ Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "~~")) + , Wrap + () + (Lit + () + (Right + (Plain + "strikethrough"))) + , Lit + () + (Right + (Plain + "~~")) + ]) + , Lit + () + (Right (Plain ",")) + ]) + , Lit + () (Right (Plain "or")) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "`")) + , Lit + () + (Right + (Plain + "monospaced")) + , Lit + () + (Right (Plain "`")) + ]) + , Lit + () (Right (Plain "(or")) + , Annotated.Group + () + (Annotated.Append + () + [ Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain "`")) + , Lit + () + (Right + (Plain + "monospaced")) + , Lit + () + (Right + (Plain "`")) + ]) + , Lit + () + (Right + (Plain ").")) + ]) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () (Right (Plain "You")) + , Lit + () (Right (Plain "can")) + , Lit + () + (Right (Plain "link")) + , Lit + () (Right (Plain "to")) + , Lit + () + (Right (Plain "Unison")) + , Lit + () + (Right (Plain "terms,")) + , Lit + () + (Right (Plain "types,")) + , Lit + () (Right (Plain "and")) + , Lit + () + (Right + (Plain "external")) + , Lit + () + (Right (Plain "URLs:")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit + () + (Right (Plain "* "))) + (Lit + () + (Right (Plain " "))) + (Wrap + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Underline + (Plain + "An"))) + , Lit + () + (Right + (Underline + (Plain + "external"))) + , Lit + () + (Right + (Underline + (Plain + "url"))) + ]))) + , Lit + () (Right (Plain "\n")) + , Indent + () + (Lit + () + (Right (Plain "* "))) + (Lit + () + (Right (Plain " "))) + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Left + (SpecialForm.Link + (Right + (Term.Term + (Any + (do + Some)))))) + , Lit + () + (Right + (Plain "is")) + , Lit + () + (Right + (Plain "a")) + , Lit + () + (Right + (Plain "term")) + , Lit + () + (Right + (Plain "link;")) + , Lit + () + (Left + (SpecialForm.Link + (Left + (typeLink Optional)))) + , Lit + () + (Right + (Plain "is")) + , Lit + () + (Right + (Plain "a")) + , Lit + () + (Right + (Plain "type")) + , Lit + () + (Right + (Plain "link")) + ])) + , Lit + () (Right (Plain "\n")) + , Indent + () + (Lit + () + (Right (Plain "* "))) + (Lit + () + (Right (Plain " "))) + (Wrap + () + (Annotated.Append + () + [ Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Underline + (Plain + "A"))) + , Lit + () + (Right + (Underline + (Plain + "named"))) + , Lit + () + (Right + (Underline + (Plain + "type"))) + , Lit + () + (Right + (Underline + (Plain + "link"))) + ]) + , Lit + () + (Right + (Plain "and")) + , Annotated.Group + () + (Annotated.Append + () + [ Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Underline + (Plain + "a"))) + , Lit + () + (Right + (Underline + (Plain + "named"))) + , Lit + () + (Right + (Underline + (Plain + "term"))) + , Lit + () + (Right + (Underline + (Plain + "link"))) + ]) + , Lit + () + (Right + (Plain + ".")) + ]) + , Lit + () + (Right + (Plain "Term")) + , Lit + () + (Right + (Plain "links")) + , Lit + () + (Right + (Plain "are")) + , Lit + () + (Right + (Plain "handy")) + , Lit + () + (Right + (Plain "for")) + , Lit + () + (Right + (Plain + "linking")) + , Lit + () + (Right + (Plain "to")) + , Lit + () + (Right + (Plain "other")) + , Lit + () + (Right + (Plain + "documents!")) + ])) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () (Right (Plain "You")) + , Lit + () (Right (Plain "can")) + , Lit + () (Right (Plain "use")) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "`")) + , Lit + () + (Right + (Plain + "{{ .. }}")) + , Lit + () + (Right (Plain "`")) + ]) + , Lit + () (Right (Plain "to")) + , Lit + () + (Right (Plain "escape")) + , Lit + () (Right (Plain "out")) + , Lit + () (Right (Plain "to")) + , Lit + () + (Right (Plain "regular")) + , Lit + () + (Right (Plain "Unison")) + , Lit + () + (Right (Plain "syntax,")) + , Lit + () (Right (Plain "for")) + , Lit + () + (Right + (Plain "instance")) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "__not bold__")) + , Lit + () + (Right (Plain ".")) + ]) + , Lit + () + (Right (Plain "This")) + , Lit + () (Right (Plain "is")) + , Lit + () + (Right (Plain "useful")) + , Lit + () (Right (Plain "for")) + , Lit + () + (Right + (Plain "creating")) + , Lit + () + (Right + (Plain "documents")) + , Lit + () + (Right + (Plain + "programmatically")) + , Lit + () (Right (Plain "or")) + , Lit + () + (Right (Plain "just")) + , Lit + () + (Right + (Plain "including")) + , Lit + () + (Right (Plain "other")) + , Lit + () + (Right + (Plain "documents.")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "*")) + , Lit + () + (Right + (Plain "Next")) + ]) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain "up:")) + , Lit + () + (Right (Plain "*")) + ]) + , Lit + () + (Left + (SpecialForm.Link + (Right + (Term.Term + (Any (do lists)))))) + ]))) + ])))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit () (Right (Plain "# "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Lit + () + (Right + (ConsoleText.Bold + (Plain "Lists")))))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit + () + (Right (Plain "# "))) + (Lit + () + (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (ConsoleText.Bold + (Plain + "Bulleted"))) + , Lit + () + (Right + (ConsoleText.Bold + (Plain + "lists"))) + ]))) + , Lit + () (Right (Plain "\n")) + , Lit + () (Right (Plain "\n")) + , Indent + () + (Lit + () + (Right (Plain " "))) + (Lit + () + (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "Bulleted")) + , Lit + () + (Right + (Plain + "lists")) + , Lit + () + (Right + (Plain "can")) + , Lit + () + (Right + (Plain "use")) + , Annotated.Group + () + (Annotated.Append + () + [ Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "`")) + , Lit + () + (Right + (Plain + "+")) + , Lit + () + (Right + (Plain + "`")) + ]) + , Lit + () + (Right + (Plain + ",")) + ]) + , Annotated.Group + () + (Annotated.Append + () + [ Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "`")) + , Lit + () + (Right + (Plain + "-")) + , Lit + () + (Right + (Plain + "`")) + ]) + , Lit + () + (Right + (Plain + ",")) + ]) + , Lit + () + (Right + (Plain "or")) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "`")) + , Lit + () + (Right + (Plain + "*")) + , Lit + () + (Right + (Plain + "`")) + ]) + , Lit + () + (Right + (Plain "for")) + , Lit + () + (Right + (Plain "the")) + , Lit + () + (Right + (Plain + "bullets")) + , Lit + () + (Right + (Plain + "(though")) + , Lit + () + (Right + (Plain "the")) + , Lit + () + (Right + (Plain + "choice")) + , Lit + () + (Right + (Plain + "will")) + , Lit + () + (Right + (Plain "be")) + , Lit + () + (Right + (Plain + "normalized")) + , Lit + () + (Right + (Plain + "away")) + , Lit + () + (Right + (Plain "by")) + , Lit + () + (Right + (Plain "the")) + , Lit + () + (Right + (Plain + "pretty-printer).")) + , Lit + () + (Right + (Plain + "They")) + , Lit + () + (Right + (Plain "can")) + , Lit + () + (Right + (Plain "be")) + , Lit + () + (Right + (Plain + "nested,")) + , Lit + () + (Right + (Plain "to")) + , Lit + () + (Right + (Plain "any")) + , Lit + () + (Right + (Plain + "depth:")) + ]))) + , Lit + () (Right (Plain "\n")) + , Lit + () (Right (Plain "\n")) + , Indent + () + (Lit + () + (Right (Plain " "))) + (Lit + () + (Right (Plain " "))) + (Annotated.Group + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit + () + (Right + (Plain + "* "))) + (Lit + () + (Right + (Plain + " "))) + (Wrap + () + (Lit + () + (Right + (Plain + "A")))) + , Lit + () + (Right + (Plain "\n")) + , Indent + () + (Lit + () + (Right + (Plain + "* "))) + (Lit + () + (Right + (Plain + " "))) + (Wrap + () + (Lit + () + (Right + (Plain + "B")))) + , Lit + () + (Right + (Plain "\n")) + , Indent + () + (Lit + () + (Right + (Plain + "* "))) + (Lit + () + (Right + (Plain + " "))) + (Annotated.Append + () + [ Wrap + () + (Lit + () + (Right + (Plain + "C"))) + , Lit + () + (Right + (Plain + "\n")) + , Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit + ( + ) + (Right + (Plain + "* "))) + (Lit + ( + ) + (Right + (Plain + " "))) + (Wrap + ( + ) + (Lit + ( + ) + (Right + (Plain + "C1")))) + , Lit + () + (Right + (Plain + "\n")) + , Indent + () + (Lit + ( + ) + (Right + (Plain + "* "))) + (Lit + ( + ) + (Right + (Plain + " "))) + (Wrap + ( + ) + (Lit + ( + ) + (Right + (Plain + "C2")))) + ]) + ]) + ]))) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit + () + (Right (Plain "# "))) + (Lit + () + (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (ConsoleText.Bold + (Plain + "Numbered"))) + , Lit + () + (Right + (ConsoleText.Bold + (Plain + "lists"))) + ]))) + , Lit + () (Right (Plain "\n")) + , Lit + () (Right (Plain "\n")) + , Indent + () + (Lit + () + (Right (Plain " "))) + (Lit + () + (Right (Plain " "))) + (Annotated.Group + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit + () + (Right + (Plain + "1. "))) + (Lit + () + (Right + (Plain + " "))) + (Wrap + () + (Lit + () + (Right + (Plain + "A")))) + , Lit + () + (Right + (Plain "\n")) + , Indent + () + (Lit + () + (Right + (Plain + "2. "))) + (Lit + () + (Right + (Plain + " "))) + (Wrap + () + (Lit + () + (Right + (Plain + "B")))) + , Lit + () + (Right + (Plain "\n")) + , Indent + () + (Lit + () + (Right + (Plain + "3. "))) + (Lit + () + (Right + (Plain + " "))) + (Wrap + () + (Lit + () + (Right + (Plain + "C")))) + ]))) + , Lit + () (Right (Plain "\n")) + , Lit + () (Right (Plain "\n")) + , Indent + () + (Lit + () + (Right (Plain " "))) + (Lit + () + (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain "The")) + , Lit + () + (Right + (Plain + "first")) + , Lit + () + (Right + (Plain + "number")) + , Lit + () + (Right + (Plain "of")) + , Lit + () + (Right + (Plain "the")) + , Lit + () + (Right + (Plain + "list")) + , Lit + () + (Right + (Plain + "determines")) + , Lit + () + (Right + (Plain "the")) + , Lit + () + (Right + (Plain + "starting")) + , Lit + () + (Right + (Plain + "number")) + , Lit + () + (Right + (Plain "in")) + , Lit + () + (Right + (Plain "the")) + , Lit + () + (Right + (Plain + "rendered")) + , Lit + () + (Right + (Plain + "output.")) + , Lit + () + (Right + (Plain "The")) + , Lit + () + (Right + (Plain + "other")) + , Lit + () + (Right + (Plain + "numbers")) + , Lit + () + (Right + (Plain "are")) + , Lit + () + (Right + (Plain + "ignored:")) + ]))) + , Lit + () (Right (Plain "\n")) + , Lit + () (Right (Plain "\n")) + , Indent + () + (Lit + () + (Right (Plain " "))) + (Lit + () + (Right (Plain " "))) + (Annotated.Group + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit + () + (Right + (Plain + "10. "))) + (Lit + () + (Right + (Plain + " "))) + (Wrap + () + (Lit + () + (Right + (Plain + "A")))) + , Lit + () + (Right + (Plain "\n")) + , Indent + () + (Lit + () + (Right + (Plain + "11. "))) + (Lit + () + (Right + (Plain + " "))) + (Wrap + () + (Lit + () + (Right + (Plain + "B")))) + , Lit + () + (Right + (Plain "\n")) + , Indent + () + (Lit + () + (Right + (Plain + "12. "))) + (Lit + () + (Right + (Plain + " "))) + (Wrap + () + (Lit + () + (Right + (Plain + "C")))) + ]))) + , Lit + () (Right (Plain "\n")) + , Lit + () (Right (Plain "\n")) + , Indent + () + (Lit + () + (Right (Plain " "))) + (Lit + () + (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "Numbered")) + , Lit + () + (Right + (Plain + "lists")) + , Lit + () + (Right + (Plain "can")) + , Lit + () + (Right + (Plain "be")) + , Lit + () + (Right + (Plain + "nested")) + , Lit + () + (Right + (Plain "as")) + , Lit + () + (Right + (Plain + "well,")) + , Lit + () + (Right + (Plain "and")) + , Lit + () + (Right + (Plain + "combined")) + , Lit + () + (Right + (Plain + "with")) + , Lit + () + (Right + (Plain + "bulleted")) + , Lit + () + (Right + (Plain + "lists:")) + ]))) + , Lit + () (Right (Plain "\n")) + , Lit + () (Right (Plain "\n")) + , Indent + () + (Lit + () + (Right (Plain " "))) + (Lit + () + (Right (Plain " "))) + (Annotated.Group + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit + () + (Right + (Plain + "1. "))) + (Lit + () + (Right + (Plain + " "))) + (Annotated.Append + () + [ Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "Wake")) + , Lit + () + (Right + (Plain + "up.")) + ]) + , Lit + () + (Right + (Plain + "\n")) + , Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit + ( + ) + (Right + (Plain + "* "))) + (Lit + ( + ) + (Right + (Plain + " "))) + (Wrap + ( + ) + (Annotated.Append + ( + ) + [ Lit + ( + ) + (Right + (Plain + "What")) + , Lit + ( + ) + (Right + (Plain + "am")) + , Lit + ( + ) + (Right + (Plain + "I")) + , Lit + ( + ) + (Right + (Plain + "doing")) + , Lit + ( + ) + (Right + (Plain + "here?")) + ])) + , Lit + () + (Right + (Plain + "\n")) + , Indent + () + (Lit + ( + ) + (Right + (Plain + "* "))) + (Lit + ( + ) + (Right + (Plain + " "))) + (Wrap + ( + ) + (Annotated.Append + ( + ) + [ Lit + ( + ) + (Right + (Plain + "In")) + , Lit + ( + ) + (Right + (Plain + "this")) + , Lit + ( + ) + (Right + (Plain + "nested")) + , Lit + ( + ) + (Right + (Plain + "list.")) + ])) + ]) + ]) + , Lit + () + (Right + (Plain "\n")) + , Indent + () + (Lit + () + (Right + (Plain + "2. "))) + (Lit + () + (Right + (Plain + " "))) + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "Take")) + , Lit + () + (Right + (Plain + "shower.")) + ])) + , Lit + () + (Right + (Plain "\n")) + , Indent + () + (Lit + () + (Right + (Plain + "3. "))) + (Lit + () + (Right + (Plain + " "))) + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "Get")) + , Lit + () + (Right + (Plain + "dressed.")) + ])) + ]))) + ]))) + ])))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit () (Right (Plain "# "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Lit + () + (Right + (ConsoleText.Bold + (Plain "Evaluation")))))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain "Expressions")) + , Lit + () (Right (Plain "can")) + , Lit + () (Right (Plain "be")) + , Lit + () + (Right + (Plain "evaluated")) + , Lit + () + (Right (Plain "inline,")) + , Lit + () (Right (Plain "for")) + , Lit + () + (Right + (Plain "instance")) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Left + (EvalInline + (Term.Term + (Any + (do + 1 + Nat.+ 1))))) + , Lit + () + (Right (Plain ".")) + ]) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "Blocks")) + , Lit + () (Right (Plain "of")) + , Lit + () + (Right (Plain "code")) + , Lit + () (Right (Plain "can")) + , Lit + () (Right (Plain "be")) + , Lit + () + (Right + (Plain "evaluated")) + , Lit + () (Right (Plain "as")) + , Lit + () + (Right (Plain "well,")) + , Lit + () (Right (Plain "for")) + , Lit + () + (Right + (Plain "instance:")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () (Lit + () (Left + (Eval + (Term.Term + (Any + (do + id x = x + id (sqr 10)))))))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Lit + () (Right (Plain "also:"))))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () (Lit + () (Left + (Eval + (Term.Term + (Any + (do match 1 with + 1 -> "hi" + _ -> "goodbye"))))))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () (Right (Plain "To")) + , Lit + () + (Right (Plain "include")) + , Lit () (Right (Plain "a")) + , Lit + () + (Right + (Plain "typechecked")) + , Lit + () + (Right (Plain "snippet")) + , Lit + () (Right (Plain "of")) + , Lit + () + (Right (Plain "code")) + , Lit + () + (Right (Plain "without")) + , Lit + () + (Right + (Plain "evaluating")) + , Lit + () (Right (Plain "it,")) + , Lit + () (Right (Plain "you")) + , Lit + () (Right (Plain "can")) + , Lit + () (Right (Plain "do:")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () (Lit + () (Left + (ExampleBlock + 0 (Term.Term + (Any + (do + use Nat * + cube : Nat -> Nat + cube x = x * x * x + ()))))))) + ])))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit () (Right (Plain "# "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (ConsoleText.Bold + (Plain "Including"))) + , Lit + () + (Right + (ConsoleText.Bold + (Plain "Unison"))) + , Lit + () + (Right + (ConsoleText.Bold + (Plain "source"))) + , Lit + () + (Right + (ConsoleText.Bold + (Plain "code"))) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "Unison")) + , Lit + () + (Right + (Plain "definitions")) + , Lit + () (Right (Plain "can")) + , Lit + () (Right (Plain "be")) + , Lit + () + (Right + (Plain "included")) + , Lit + () (Right (Plain "in")) + , Lit + () + (Right (Plain "docs.")) + , Lit + () (Right (Plain "For")) + , Lit + () + (Right + (Plain "instance:")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Lit + () + (Left + (SpecialForm.Source + [ ( Left + (typeLink Optional) + , [] + ) + , ( Right + (Term.Term + (Any (do sqr))) + , [] + ) + ]))))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "Some")) + , Lit + () + (Right + (Plain "rendering")) + , Lit + () + (Right (Plain "targets")) + , Lit + () + (Right (Plain "also")) + , Lit + () + (Right (Plain "support")) + , Lit + () + (Right (Plain "folded")) + , Lit + () + (Right (Plain "source:")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Lit + () + (Left + (FoldedSource + [ ( Left + (typeLink Optional) + , [] + ) + , ( Right + (Term.Term + (Any (do sqr))) + , [] + ) + ]))))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () (Right (Plain "You")) + , Lit + () (Right (Plain "can")) + , Lit + () + (Right (Plain "also")) + , Lit + () + (Right (Plain "include")) + , Lit + () + (Right (Plain "just")) + , Lit () (Right (Plain "a")) + , Lit + () + (Right + (Plain "signature,")) + , Lit + () + (Right (Plain "inline,")) + , Lit + () + (Right (Plain "with")) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Left + (SignatureInline + (Term.Term + (Any + (do sqr))))) + , Lit + () + (Right (Plain ",")) + ]) + , Lit + () (Right (Plain "or")) + , Lit + () (Right (Plain "you")) + , Lit + () (Right (Plain "can")) + , Lit + () + (Right (Plain "include")) + , Lit + () (Right (Plain "one")) + , Lit + () (Right (Plain "or")) + , Lit + () + (Right (Plain "more")) + , Lit + () + (Right + (Plain "signatures")) + , Lit + () (Right (Plain "as")) + , Lit () (Right (Plain "a")) + , Lit + () + (Right (Plain "block:")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Lit + () + (Left + (SpecialForm.Signature + [ Term.Term + (Any (do sqr)) + , Term.Term + (Any (do (Nat.+))) + ]))))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () (Right (Plain "Or")) + , Lit + () + (Right + (Plain "alternately:")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Lit + () + (Left + (SpecialForm.Signature + [ Term.Term + (Any (do List.map)) + ]))))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit + () + (Right (Plain "# "))) + (Lit + () + (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (ConsoleText.Bold + (Plain + "Inline"))) + , Lit + () + (Right + (ConsoleText.Bold + (Plain + "snippets"))) + ]))) + , Lit + () (Right (Plain "\n")) + , Lit + () (Right (Plain "\n")) + , Indent + () + (Lit + () + (Right (Plain " "))) + (Lit + () + (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain "You")) + , Lit + () + (Right + (Plain "can")) + , Lit + () + (Right + (Plain + "include")) + , Lit + () + (Right + (Plain + "typechecked")) + , Lit + () + (Right + (Plain + "code")) + , Lit + () + (Right + (Plain + "snippets")) + , Lit + () + (Right + (Plain + "inline,")) + , Lit + () + (Right + (Plain "for")) + , Lit + () + (Right + (Plain + "instance:")) + ]))) + , Lit + () (Right (Plain "\n")) + , Lit + () (Right (Plain "\n")) + , Indent + () + (Lit + () + (Right (Plain " "))) + (Lit + () + (Right (Plain " "))) + (Annotated.Group + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit + () + (Right + (Plain + "* "))) + (Lit + () + (Right + (Plain + " "))) + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Left + (Example + 2 + (Term.Term + (Any + (do + f + x -> + f + x + Nat.+ sqr + 1))))) + , Lit + () + (Right + (Plain + "-")) + , Lit + () + (Right + (Plain + "the")) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + ( + ) + (Right + (Plain + "`")) + , Lit + ( + ) + (Right + (Plain + "2")) + , Lit + ( + ) + (Right + (Plain + "`")) + ]) + , Lit + () + (Right + (Plain + "says")) + , Lit + () + (Right + (Plain + "to")) + , Lit + () + (Right + (Plain + "ignore")) + , Lit + () + (Right + (Plain + "the")) + , Lit + () + (Right + (Plain + "first")) + , Lit + () + (Right + (Plain + "two")) + , Lit + () + (Right + (Plain + "arguments")) + , Lit + () + (Right + (Plain + "when")) + , Lit + () + (Right + (Plain + "rendering.")) + , Lit + () + (Right + (Plain + "In")) + , Lit + () + (Right + (Plain + "richer")) + , Lit + () + (Right + (Plain + "renderers,")) + , Lit + () + (Right + (Plain + "the")) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + ( + ) + (Right + (Plain + "`")) + , Lit + ( + ) + (Right + (Plain + "sqr")) + , Lit + ( + ) + (Right + (Plain + "`")) + ]) + , Lit + () + (Right + (Plain + "link")) + , Lit + () + (Right + (Plain + "will")) + , Lit + () + (Right + (Plain + "be")) + , Lit + () + (Right + (Plain + "clickable.")) + ])) + , Lit + () + (Right + (Plain "\n")) + , Indent + () + (Lit + () + (Right + (Plain + "* "))) + (Lit + () + (Right + (Plain + " "))) + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "If")) + , Lit + () + (Right + (Plain + "your")) + , Lit + () + (Right + (Plain + "snippet")) + , Lit + () + (Right + (Plain + "expression")) + , Lit + () + (Right + (Plain + "is")) + , Lit + () + (Right + (Plain + "just")) + , Lit + () + (Right + (Plain + "a")) + , Lit + () + (Right + (Plain + "single")) + , Lit + () + (Right + (Plain + "function")) + , Lit + () + (Right + (Plain + "application,")) + , Lit + () + (Right + (Plain + "you")) + , Lit + () + (Right + (Plain + "can")) + , Lit + () + (Right + (Plain + "put")) + , Lit + () + (Right + (Plain + "it")) + , Lit + () + (Right + (Plain + "in")) + , Lit + () + (Right + (Plain + "double")) + , Lit + () + (Right + (Plain + "backticks,")) + , Lit + () + (Right + (Plain + "like")) + , Lit + () + (Right + (Plain + "so:")) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + ( + ) + (Left + (Example + 1 + (Term.Term + (Any + (do + x -> + sqr + x))))) + , Lit + ( + ) + (Right + (Plain + ".")) + ]) + , Lit + () + (Right + (Plain + "This")) + , Lit + () + (Right + (Plain + "is")) + , Lit + () + (Right + (Plain + "equivalent")) + , Lit + () + (Right + (Plain + "to")) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + ( + ) + (Left + (Example + 1 + (Term.Term + (Any + (do + x -> + sqr + x))))) + , Lit + ( + ) + (Right + (Plain + ".")) + ]) + ])) + ]))) + ]))) + ])))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Group + () + (Annotated.Append + () + [ Indent + () + (Lit () (Right (Plain "# "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (ConsoleText.Bold + (Plain "Non-Unison"))) + , Lit + () + (Right + (ConsoleText.Bold + (Plain "code"))) + , Lit + () + (Right + (ConsoleText.Bold + (Plain "blocks"))) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () (Right (Plain "Use")) + , Lit + () + (Right (Plain "three")) + , Lit + () (Right (Plain "or")) + , Lit + () + (Right (Plain "more")) + , Lit + () + (Right (Plain "single")) + , Lit + () + (Right (Plain "quotes")) + , Lit + () (Right (Plain "to")) + , Lit + () + (Right (Plain "start")) + , Lit () (Right (Plain "a")) + , Lit + () + (Right (Plain "block")) + , Lit + () + (Right (Plain "with")) + , Lit + () (Right (Plain "no")) + , Lit + () + (Right (Plain "syntax")) + , Lit + () + (Right + (Plain "highlighting:")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "``` ")) + , Annotated.Group + () + (Lit + () + (Right (Plain "raw"))) + , Lit + () + (Right (Plain "\n")) + , Lit + () + (Right + (Plain + " _____ _ \n | | |___|_|___ ___ ___ \n | | | | |_ -| . | |\n |_____|_|_|_|___|___|_|_|\n ")) + , Lit + () + (Right (Plain "\n")) + , Lit + () + (Right (Plain "```")) + ])))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () (Right (Plain "You")) + , Lit + () (Right (Plain "can")) + , Lit + () (Right (Plain "use")) + , Lit + () + (Right (Plain "three")) + , Lit + () (Right (Plain "or")) + , Lit + () + (Right (Plain "more")) + , Lit + () + (Right + (Plain "backticks")) + , Lit + () + (Right (Plain "plus")) + , Lit () (Right (Plain "a")) + , Lit + () + (Right + (Plain "language")) + , Lit + () + (Right (Plain "name")) + , Lit + () (Right (Plain "for")) + , Lit + () + (Right (Plain "blocks")) + , Lit + () + (Right (Plain "with")) + , Lit + () + (Right (Plain "syntax")) + , Lit + () + (Right + (Plain "highlighting:")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "``` ")) + , Annotated.Group + () + (Lit + () + (Right + (Plain "Haskell"))) + , Lit + () (Right (Plain "\n")) + , Lit + () + (Right + (Plain + "-- A fenced code block which isn't parsed by Unison\nreverse = foldl (flip (:)) []")) + , Lit + () (Right (Plain "\n")) + , Lit + () (Right (Plain "```")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "``` ")) + , Annotated.Group + () + (Lit + () + (Right (Plain "Scala"))) + , Lit + () (Right (Plain "\n")) + , Lit + () + (Right + (Plain + "// A fenced code block which isn't parsed by Unison\ndef reverse[A](xs: List[A]) = \n xs.foldLeft(Nil : List[A])((acc,a) => a +: acc)")) + , Lit + () (Right (Plain "\n")) + , Lit + () (Right (Plain "```")) + ]))) + ])))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Indent + () + (Lit () (Right (Plain " "))) + (Lit () (Right (Plain " "))) + (Annotated.Group + () + (Wrap + () + (Annotated.Group + () + (Annotated.Append + () + [ Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () (Right (Plain "There")) + , Lit () (Right (Plain "are")) + , Lit + () (Right (Plain "also")) + , Lit + () + (Right (Plain "asides,")) + , Lit + () + (Right (Plain "callouts,")) + , Lit + () + (Right (Plain "tables,")) + , Lit + () + (Right (Plain "tooltips,")) + , Lit () (Right (Plain "and")) + , Lit + () (Right (Plain "more.")) + , Lit + () (Right (Plain "These")) + , Lit + () (Right (Plain "don't")) + , Lit + () + (Right (Plain "currently")) + , Lit + () (Right (Plain "have")) + , Lit + () + (Right (Plain "special")) + , Lit + () + (Right (Plain "syntax;")) + , Lit + () (Right (Plain "just")) + , Lit () (Right (Plain "use")) + , Lit () (Right (Plain "the")) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "`")) + , Lit + () + (Right + (Plain "{{ }}")) + , Lit + () + (Right (Plain "`")) + ]) + , Lit + () + (Right (Plain "syntax")) + , Lit () (Right (Plain "to")) + , Lit + () (Right (Plain "call")) + , Lit + () (Right (Plain "these")) + , Lit + () + (Right (Plain "functions")) + , Lit + () + (Right (Plain "directly.")) + ])) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Annotated.Group + () + (Wrap + () + (Lit + () + (Left + (SpecialForm.Signature + [ Term.Term + (Any (do docAside)) + , Term.Term + (Any (do docCallout)) + , Term.Term + (Any + (do docBlockquote)) + , Term.Term + (Any (do docTooltip)) + , Term.Term + (Any (do docTable)) + ])))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () (Right (Plain "This")) + , Lit () (Right (Plain "is")) + , Lit () (Right (Plain "an")) + , Lit + () + (Right (Plain "aside.")) + , Lit + () + (Right + (Foreground + BrightBlack + (Plain "("))) + , Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Foreground + BrightBlack + (Plain "Some"))) + , Lit + () + (Right + (Foreground + BrightBlack + (Plain "extra"))) + , Lit + () + (Right + (Foreground + BrightBlack + (Plain "detail"))) + , Lit + () + (Right + (Foreground + BrightBlack + (Plain "that"))) + , Lit + () + (Right + (Foreground + BrightBlack + (Plain "doesn't"))) + , Lit + () + (Right + (Foreground + BrightBlack + (Plain "belong"))) + , Lit + () + (Right + (Foreground + BrightBlack + (Plain "in"))) + , Lit + () + (Right + (Foreground + BrightBlack + (Plain "main"))) + , Lit + () + (Right + (Foreground + BrightBlack + (Plain "text."))) + ]) + , Lit + () + (Right + (Foreground + BrightBlack + (Plain ")"))) + ])) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Annotated.Group + () + (Wrap + () + (Annotated.Group + () + (Indent + () + (Lit + () (Right (Plain " | "))) + (Lit + () (Right (Plain " | "))) + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain "This")) + , Lit + () + (Right (Plain "is")) + , Lit + () + (Right (Plain "an")) + , Lit + () + (Right + (Plain "important")) + , Lit + () + (Right + (Plain "callout,")) + , Lit + () + (Right + (Plain "with")) + , Lit + () + (Right (Plain "no")) + , Lit + () + (Right + (Plain "icon.")) + ]))))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Annotated.Group + () + (Wrap + () + (Annotated.Group + () + (Indent + () + (Lit + () (Right (Plain " | "))) + (Lit + () (Right (Plain " | "))) + (Annotated.Append + () + [ Wrap + () + (Lit + () + (Right + (ConsoleText.Bold + (Plain "🌻")))) + , Lit + () + (Right (Plain "\n")) + , Lit + () (Right (Plain "")) + , Lit + () + (Right (Plain "\n")) + , Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain "This")) + , Lit + () + (Right + (Plain "is")) + , Lit + () + (Right + (Plain "an")) + , Lit + () + (Right + (Plain + "important")) + , Lit + () + (Right + (Plain + "callout,")) + , Lit + () + (Right + (Plain "with")) + , Lit + () + (Right + (Plain "an")) + , Lit + () + (Right + (Plain "icon.")) + , Lit + () + (Right + (Plain "The")) + , Lit + () + (Right + (Plain "text")) + , Lit + () + (Right + (Plain "wraps")) + , Lit + () + (Right + (Plain "onto")) + , Lit + () + (Right + (Plain + "multiple")) + , Lit + () + (Right + (Plain + "lines.")) + ]) + ])))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Annotated.Group + () + (Wrap + () + (Annotated.Group + () + (Indent + () + (Lit () (Right (Plain "> "))) + (Lit () (Right (Plain "> "))) + (Annotated.Group + () + (Annotated.Append + () + [ Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "\"And")) + , Lit + () + (Right + (Plain + "what")) + , Lit + () + (Right + (Plain + "is")) + , Lit + () + (Right + (Plain + "the")) + , Lit + () + (Right + (Plain + "use")) + , Lit + () + (Right + (Plain + "of")) + , Lit + () + (Right + (Plain "a")) + , Lit + () + (Right + (Plain + "book,\"")) + , Lit + () + (Right + (Plain + "thought")) + , Lit + () + (Right + (Plain + "Alice,")) + , Lit + () + (Right + (Plain + "\"without")) + , Lit + () + (Right + (Plain + "pictures")) + , Lit + () + (Right + (Plain + "or")) + , Lit + () + (Right + (Plain + "conversation?\"")) + ])) + , Lit + () + (Right (Plain "\n")) + , Lit + () + (Right (Plain "\n")) + , Annotated.Group + () + (Wrap + () + (Annotated.Append + () + [ Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "*")) + , Lit + () + (Right + (Plain + "Lewis")) + ]) + , Lit + () + (Right + (Plain + "Carroll,")) + , Lit + () + (Right + (Plain + "Alice's")) + , Lit + () + (Right + (Plain + "Adventures")) + , Lit + () + (Right + (Plain + "in")) + , Annotated.Group + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain + "Wonderland")) + , Lit + () + (Right + (Plain + "*")) + ]) + ])) + ]))))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Annotated.Group + () + (Wrap + () + (Wrap + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "Hover")) + , Lit + () + (Right (Plain "over")) + , Lit + () (Right (Plain "me")) + ]))) + , Lit () (Right (Plain "\n")) + , Lit () (Right (Plain "\n")) + , Annotated.Group + () + (Wrap + () + (Annotated.Table + () + [ [ Wrap + () + (Lit + () (Right (Plain "a"))) + , Wrap + () + (Lit + () (Right (Plain "b"))) + , Wrap + () + (Annotated.Append + () + [ Lit + () + (Right (Plain "A")) + , Lit + () + (Right + (Plain "longer")) + , Lit + () + (Right + (Plain + "paragraph")) + , Lit + () + (Right + (Plain "that")) + , Lit + () + (Right + (Plain "will")) + , Lit + () + (Right + (Plain "split")) + , Lit + () + (Right + (Plain "onto")) + , Lit + () + (Right + (Plain + "multiple")) + , Lit + () + (Right + (Plain "lines,")) + , Lit + () + (Right + (Plain "such")) + , Lit + () + (Right + (Plain "that")) + , Lit + () + (Right + (Plain "this")) + , Lit + () + (Right + (Plain "row")) + , Lit + () + (Right + (Plain + "occupies")) + , Lit + () + (Right + (Plain + "multiple")) + , Lit + () + (Right + (Plain "lines")) + , Lit + () + (Right + (Plain "in")) + , Lit + () + (Right + (Plain "the")) + , Lit + () + (Right + (Plain + "rendered")) + , Lit + () + (Right + (Plain "table.")) + ]) + ] + , [ Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain "Some")) + , Lit + () + (Right + (Plain "text")) + ]) + , Wrap + () + (Annotated.Append + () + [ Lit + () + (Right + (Plain "More")) + , Lit + () + (Right + (Plain "text")) + ]) + , Wrap + () + (Lit + () + (Right + (Plain "Zounds!"))) + ] + ])) + ])))) + ]) +```` diff --git a/unison-src/transcripts/idempotent/bug.md b/unison-src/transcripts/idempotent/bug.md new file mode 100644 index 0000000000..9469b77067 --- /dev/null +++ b/unison-src/transcripts/idempotent/bug.md @@ -0,0 +1,19 @@ +This tests that `:bug` behaves similarly to `:error` when the stanza fails. + +``` ucm :bug +scratch/main> do.something + + ⚠️ + I don't know how to do.something. Type `help` or `?` to get + help. +``` + +And when combined with `:error`, it should expect a successful result. + +``` ucm :error :bug +scratch/main> help edit + + edit + `edit foo` prepends the definition of `foo` to the top of the most recently saved file. + `edit` without arguments invokes a search to select a definition for editing, which requires that `fzf` can be found within your PATH. +``` diff --git a/unison-src/transcripts/idempotent/builtins-merge.md b/unison-src/transcripts/idempotent/builtins-merge.md new file mode 100644 index 0000000000..27da76caaa --- /dev/null +++ b/unison-src/transcripts/idempotent/builtins-merge.md @@ -0,0 +1,90 @@ +The `builtins.merge` command adds the known builtins to the specified subnamespace within the current namespace. + +``` ucm +scratch/main> builtins.merge builtins + + Done. + +scratch/main> ls builtins + + 1. Any (builtin type) + 2. Any/ (2 terms) + 3. Boolean (builtin type) + 4. Boolean/ (1 term) + 5. Bytes (builtin type) + 6. Bytes/ (34 terms) + 7. Char (builtin type) + 8. Char/ (22 terms, 1 type) + 9. ClientSockAddr (builtin type) + 10. Code (builtin type) + 11. Code/ (9 terms) + 12. Debug/ (3 terms) + 13. Doc (type) + 14. Doc/ (6 terms) + 15. Either (type) + 16. Either/ (2 terms) + 17. Exception (type) + 18. Exception/ (1 term) + 19. Float (builtin type) + 20. Float/ (38 terms) + 21. Handle/ (1 term) + 22. ImmutableArray (builtin type) + 23. ImmutableArray/ (3 terms) + 24. ImmutableByteArray (builtin type) + 25. ImmutableByteArray/ (8 terms) + 26. Int (builtin type) + 27. Int/ (31 terms) + 28. IsPropagated (type) + 29. IsPropagated/ (1 term) + 30. IsTest (type) + 31. IsTest/ (1 term) + 32. Link (type) + 33. Link/ (3 terms, 2 types) + 34. List (builtin type) + 35. List/ (10 terms) + 36. ListenSocket (builtin type) + 37. MutableArray (builtin type) + 38. MutableArray/ (6 terms) + 39. MutableByteArray (builtin type) + 40. MutableByteArray/ (14 terms) + 41. Nat (builtin type) + 42. Nat/ (28 terms) + 43. Optional (type) + 44. Optional/ (2 terms) + 45. Pattern (builtin type) + 46. Pattern/ (9 terms) + 47. Ref (builtin type) + 48. Ref/ (2 terms) + 49. Request (builtin type) + 50. RewriteCase (type) + 51. RewriteCase/ (1 term) + 52. RewriteSignature (type) + 53. RewriteSignature/ (1 term) + 54. RewriteTerm (type) + 55. RewriteTerm/ (1 term) + 56. Rewrites (type) + 57. Rewrites/ (1 term) + 58. Scope (builtin type) + 59. Scope/ (6 terms) + 60. SeqView (type) + 61. SeqView/ (2 terms) + 62. Socket/ (1 term) + 63. Test/ (2 terms, 1 type) + 64. Text (builtin type) + 65. Text/ (34 terms) + 66. ThreadId/ (1 term) + 67. Tuple (type) + 68. Tuple/ (1 term) + 69. UDPSocket (builtin type) + 70. Unit (type) + 71. Unit/ (1 term) + 72. Universal/ (7 terms) + 73. Value (builtin type) + 74. Value/ (5 terms) + 75. bug (a -> b) + 76. crypto/ (17 terms, 2 types) + 77. io2/ (146 terms, 32 types) + 78. metadata/ (2 terms) + 79. todo (a -> b) + 80. unsafe/ (1 term) +``` diff --git a/unison-src/transcripts/idempotent/builtins.md b/unison-src/transcripts/idempotent/builtins.md new file mode 100644 index 0000000000..e36c81246d --- /dev/null +++ b/unison-src/transcripts/idempotent/builtins.md @@ -0,0 +1,615 @@ +# Unit tests for builtin functions + +``` ucm :hide +scratch/main> builtins.mergeio + +scratch/main> load unison-src/transcripts-using-base/base.u + +scratch/main> add +``` + +This transcript defines unit tests for builtin functions. There's a single `scratch/main> test` execution at the end that will fail the transcript with a nice report if any of the tests fail. + +## `Int` functions + +``` unison :hide +use Int + +-- used for some take/drop tests later +bigN = Nat.shiftLeft 1 63 + +-- Note: you can make the tests more fine-grained if you +-- want to be able to tell which one is failing +test> Int.tests.arithmetic = + checks [ + eq (+1 + +1) +2, + +10 - +4 == +6, + eq (+11 * +6) +66, + eq (+11 * +6) +66, + +10 / +3 == +3, + +10 / +5 == +2, + mod +10 +3 == +1, + mod +10 +2 == +0, + mod -13 +3 == +2, + mod -13 -3 == -1, + mod -13 -5 == -3, + mod -13 +5 == +2, + negate +99 == -99, + increment +99 == +100, + not (isEven +99), + isEven +100, + isOdd +105, + not (isOdd +108), + signum +99 == +1, + signum -3949 == -1, + signum +0 == +0, + gt +42 -1, + lt +42 +1000, + lteq +43 +43, + lteq +43 +44, + gteq +43 +43, + gteq +43 +41 + ] + +test> Int.tests.bitTwiddling = + checks [ + and +5 +4 == +4, + and +5 +1 == +1, + or +4 +1 == +5, + xor +5 +1 == +4, + complement -1 == +0, + popCount +1 == 1, + popCount +2 == 1, + popCount +4 == 1, + popCount +5 == 2, + popCount -1 == 64, + leadingZeros +1 == 63, + trailingZeros +1 == 0, + leadingZeros +2 == 62, + trailingZeros +2 == 1, + pow +2 6 == +64, + shiftLeft +1 6 == +64, + shiftRight +64 6 == +1 + ] + +test> Int.tests.conversions = + checks [ + truncate0 -2438344 == 0, + truncate0 +999 == 999, + toText +0 == "0", + toText +10 == "10", + toText -1039 == "-1039", + fromText "+0" == Some +0, + fromText "a8f9djasdlfkj" == None, + fromText "3940" == Some +3940, + fromText "1000000000000000000000000000" == None, + fromText "-1000000000000000000000000000" == None, + toFloat +9394 == 9394.0, + toFloat -20349 == -20349.0 + ] +``` + +``` ucm :hide +scratch/main> add +``` + +## `Nat` functions + +``` unison :hide +use Nat + +test> Nat.tests.arithmetic = + checks [ + eq (1 + 1) 2, + drop 10 4 == 6, + sub 10 12 == -2, + eq (11 * 6) 66, + 10 / 3 == 3, + 10 / 5 == 2, + mod 10 3 == 1, + mod 10 2 == 0, + 18446744073709551615 / 2 == 9223372036854775807, + mod 18446744073709551615 2 == 1, + increment 99 == 100, + not (isEven 99), + isEven 100, + isOdd 105, + not (isOdd 108), + gt 42 1, + lt 42 1000, + lteq 43 43, + lteq 43 44, + gteq 43 43, + gteq 43 41, + ] + +test> Nat.tests.bitTwiddling = + checks [ + and 5 4 == 4, + and 5 1 == 1, + or 4 1 == 5, + xor 5 1 == 4, + complement (complement 0) == 0, + popCount 1 == 1, + popCount 2 == 1, + popCount 4 == 1, + popCount 5 == 2, + popCount (complement 0) == 64, + leadingZeros 1 == 63, + trailingZeros 1 == 0, + leadingZeros 2 == 62, + trailingZeros 2 == 1, + pow 2 6 == 64, + shiftLeft 1 6 == 64, + shiftRight 64 6 == 1 + ] + +test> Nat.tests.conversions = + checks [ + toFloat 2438344 == 2438344.0, + toFloat 0 == 0.0, + toText 0 == "0", + toText 32939 == "32939", + toText 10 == "10", + fromText "ooga" == None, + fromText "90" == Some 90, + fromText "-1" == None, + fromText "100000000000000000000000000" == None, + unsnoc "abc" == Some ("ab", ?c), + uncons "abc" == Some (?a, "bc"), + unsnoc "" == None, + uncons "" == None, + Text.fromCharList (Text.toCharList "abc") == "abc", + Bytes.fromList (Bytes.toList 0xsACE0BA5E) == 0xsACE0BA5E + ] +``` + +``` ucm :hide +scratch/main> add +``` + +## `Boolean` functions + +``` unison :hide +test> Boolean.tests.orTable = + checks [ + (true || true) == true, + (true || false) == true, + (false || true) == true, + (false || false) == false + ] +test> Boolean.tests.andTable = + checks [ + (true && true) == true, + (false && true) == false, + (true && false) == false, + (false && false) == false + ] +test> Boolean.tests.notTable = + checks [ + not true == false, + not false == true + ] +``` + +``` ucm :hide +scratch/main> add +``` + +## `Text` functions + +``` unison :hide +test> Text.tests.takeDropAppend = + checks [ + "yabba" ++ "dabba" == "yabbadabba", + Text.take 0 "yabba" == "", + Text.take 2 "yabba" == "ya", + Text.take 99 "yabba" == "yabba", + Text.drop 0 "yabba" == "yabba", + Text.drop 2 "yabba" == "bba", + Text.drop 99 "yabba" == "", + Text.take bigN "yabba" == "yabba", + Text.drop bigN "yabba" == "" + ] + +test> Text.tests.repeat = + checks [ + Text.repeat 4 "o" == "oooo", + Text.repeat 0 "o" == "" + ] + +test> Text.tests.alignment = + checks [ + Text.alignLeftWith 5 ?\s "a" == "a ", + Text.alignRightWith 5 ?_ "ababa" == "ababa", + Text.alignRightWith 5 ?_ "ab" == "___ab" + ] + +test> Text.tests.literalsEq = checks [":)" == ":)"] + +test> Text.tests.patterns = + use Pattern many or run isMatch capture join replicate + use Text.patterns literal digit letter anyChar space punctuation notCharIn charIn charRange notCharRange eof + l = literal + checks [ + run digit "1abc" == Some ([], "abc"), + run (capture (many digit)) "11234abc" == Some (["11234"], "abc"), + run (many letter) "abc11234abc" == Some ([], "11234abc"), + run (join [many space, capture (many anyChar)]) " abc123" == Some (["abc123"], ""), + run (many punctuation) "!!!!,,,..." == Some ([], ""), + run (charIn [?0,?1]) "0" == Some ([], ""), + run (notCharIn [?0,?1]) "0" == None, + run (many (notCharIn [?0,?1])) "asjdfskdfjlskdjflskdjf011" == Some ([], "011"), + run (capture (many (charRange ?a ?z))) "hi123" == Some (["hi"], "123"), + run (capture (many (notCharRange ?, ?,))) "abc123," == Some (["abc123"], ","), + run (capture (many (notCharIn [?,,]))) "abracadabra,123" == Some (["abracadabra"], ",123"), + run (capture (many (or digit letter))) "11234abc,remainder" == Some (["11234abc"], ",remainder"), + run (capture (replicate 1 5 (or digit letter))) "1a2ba aaa" == Some (["1a2ba"], " aaa"), + run (captureAs "foo" (many (or digit letter))) "11234abc,remainder" == Some (["foo"], ",remainder"), + run (join [(captureAs "foo" (many digit)), captureAs "bar" (many letter)]) "11234abc,remainder" == Some (["foo", "bar"], ",remainder"), + -- Regression test for: https://github.com/unisonweb/unison/issues/3530 + run (capture (replicate 0 1 (join [literal "a", literal "b"]))) "ac" == Some ([""], "ac"), + isMatch (join [many letter, eof]) "aaaaabbbb" == true, + isMatch (join [many letter, eof]) "aaaaabbbb1" == false, + isMatch (join [l "abra", many (l "cadabra")]) "abracadabracadabra" == true, + + ] + + +test> Text.tests.indexOf = + haystack = "01020304" ++ "05060708" ++ "090a0b0c01" + needle1 = "01" + needle2 = "02" + needle3 = "0304" + needle4 = "05" + needle5 = "0405" + needle6 = "0c" + needle7 = haystack + needle8 = "lopez" + needle9 = "" + checks [ + Text.indexOf needle1 haystack == Some 0, + Text.indexOf needle2 haystack == Some 2, + Text.indexOf needle3 haystack == Some 4, + Text.indexOf needle4 haystack == Some 8, + Text.indexOf needle5 haystack == Some 6, + Text.indexOf needle6 haystack == Some 22, + Text.indexOf needle7 haystack == Some 0, + Text.indexOf needle8 haystack == None, + Text.indexOf needle9 haystack == Some 0, + ] + +test> Text.tests.indexOfEmoji = + haystack = "clap 👏 your 👏 hands 👏 if 👏 you 👏 love 👏 unison" + needle1 = "👏" + needle2 = "👏 " + checks [ + Text.indexOf needle1 haystack == Some 5, + Text.indexOf needle2 haystack == Some 5, + ] + +``` + +``` ucm :hide +scratch/main> add +``` + +## `Bytes` functions + +``` unison :hide +test> Bytes.tests.at = + bs = Bytes.fromList [77, 13, 12] + checks [ + Bytes.at 1 bs == Some 13, + Bytes.at 0 bs == Some 77, + Bytes.at 99 bs == None, + Bytes.take bigN bs == bs, + Bytes.drop bigN bs == empty + ] + +test> Bytes.tests.compression = + roundTrip b = + (Bytes.zlib.decompress (Bytes.zlib.compress b) == Right b) + && (Bytes.gzip.decompress (Bytes.gzip.compress b) == Right b) + + checks [ + roundTrip 0xs2093487509823745709827345789023457892345, + roundTrip 0xs00000000000000000000000000000000000000000000, + roundTrip 0xs, + roundTrip 0xs11111111111111111111111111, + roundTrip 0xsffffffffffffffffffffffffffffff, + roundTrip 0xs222222222fffffffffffffffffffffffffffffff, + -- these fail due to bad checksums and/or headers + isLeft (zlib.decompress 0xs2093487509823745709827345789023457892345), + isLeft (gzip.decompress 0xs201209348750982374593939393939709827345789023457892345) + ] + +test> Bytes.tests.fromBase64UrlUnpadded = + checks [Exception.catch + '(fromUtf8 + (raiseMessage () (Bytes.fromBase64UrlUnpadded (toUtf8 "aGVsbG8gd29ybGQ")))) == Right "hello world" + , isLeft (Bytes.fromBase64UrlUnpadded (toUtf8 "aGVsbG8gd29ybGQ="))] + +test> Bytes.tests.indexOf = + haystack = 0xs01020304 ++ 0xs05060708 ++ 0xs090a0b0c01 + needle1 = 0xs01 + needle2 = 0xs02 + needle3 = 0xs0304 + needle4 = 0xs05 + needle5 = 0xs0405 + needle6 = 0xs0c + needle7 = haystack + needle8 = 0xsffffff + checks [ + Bytes.indexOf needle1 haystack == Some 0, + Bytes.indexOf needle2 haystack == Some 1, + Bytes.indexOf needle3 haystack == Some 2, + Bytes.indexOf needle4 haystack == Some 4, + Bytes.indexOf needle5 haystack == Some 3, + Bytes.indexOf needle6 haystack == Some 11, + Bytes.indexOf needle7 haystack == Some 0, + Bytes.indexOf needle8 haystack == None, + + ] + +``` + +``` ucm :hide +scratch/main> add +``` + +## `List` comparison + +``` unison :hide +test> checks [ + compare [] [1,2,3] == -1, + compare [1,2,3] [1,2,3,4] == -1, + compare [1,2,3,4] [1,2,3] == +1, + compare [1,2,3] [1,2,3] == +0, + compare [3] [1,2,3] == +1, + compare [1,2,3] [1,2,4] == -1, + compare [1,2,2] [1,2,1,2] == +1, + compare [1,2,3,4] [3,2,1] == -1 + ] +``` + +``` ucm :hide +scratch/main> add +``` + +Other list functions + +``` unison :hide +test> checks [ + List.take bigN [1,2,3] == [1,2,3], + List.drop bigN [1,2,3] == [] + ] +``` + +## `Any` functions + +``` unison +> [Any "hi", Any (41 + 1)] + +test> Any.test1 = checks [(Any "hi" == Any "hi")] +test> Any.test2 = checks [(not (Any "hi" == Any 42))] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Any.test1 : [Result] + Any.test2 : [Result] + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > [Any "hi", Any (41 + 1)] + ⧩ + [Any "hi", Any 42] + + 3 | test> Any.test1 = checks [(Any "hi" == Any "hi")] + + ✅ Passed Passed + + 4 | test> Any.test2 = checks [(not (Any "hi" == Any 42))] + + ✅ Passed Passed +``` + +``` ucm :hide +scratch/main> add +``` + +## Sandboxing functions + +``` unison +openFile1 t = openFile t +openFile2 t = openFile1 t + +validateSandboxedSimpl ok v = + match Value.validateSandboxed ok v with + Right [] -> true + _ -> false + +openFiles = + [ not (validateSandboxed [] openFile) + , not (validateSandboxed [] openFile1) + , not (validateSandboxed [] openFile2) + ] + +test> Sandbox.test1 = checks [validateSandboxed [] "hello"] +test> Sandbox.test2 = checks openFiles +test> Sandbox.test3 = checks [validateSandboxed [termLink openFile.impl] +openFile] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Sandbox.test1 : [Result] + Sandbox.test2 : [Result] + Sandbox.test3 : [Result] + openFile1 : Text + -> FileMode + ->{IO, Exception} Handle + openFile2 : Text + -> FileMode + ->{IO, Exception} Handle + openFiles : [Boolean] + validateSandboxedSimpl : [Link.Term] + -> Value + ->{IO} Boolean + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 15 | test> Sandbox.test1 = checks [validateSandboxed [] "hello"] + + ✅ Passed Passed + + 16 | test> Sandbox.test2 = checks openFiles + + ✅ Passed Passed + + 17 | test> Sandbox.test3 = checks [validateSandboxed [termLink openFile.impl] + + ✅ Passed Passed +``` + +``` ucm :hide +scratch/main> add +``` + +``` unison +openFilesIO = do + checks + [ not (validateSandboxedSimpl [] (value openFile)) + , not (validateSandboxedSimpl [] (value openFile1)) + , not (validateSandboxedSimpl [] (value openFile2)) + , sandboxLinks (termLink openFile) + == sandboxLinks (termLink openFile1) + , sandboxLinks (termLink openFile1) + == sandboxLinks (termLink openFile2) + ] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + openFilesIO : '{IO} [Result] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + openFilesIO : '{IO} [Result] + +scratch/main> io.test openFilesIO + + New test results: + + 1. openFilesIO ◉ Passed + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +## Universal hash functions + +Just exercises the function + +``` unison +> Universal.murmurHash 1 +test> Universal.murmurHash.tests = checks [Universal.murmurHash [1,2,3] == Universal.murmurHash [1,2,3]] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Universal.murmurHash.tests : [Result] + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > Universal.murmurHash 1 + ⧩ + 1208954131003843843 + + 2 | test> Universal.murmurHash.tests = checks [Universal.murmurHash [1,2,3] == Universal.murmurHash [1,2,3]] + + ✅ Passed Passed +``` + +``` ucm :hide +scratch/main> add +``` + +## Run the tests + +Now that all the tests have been added to the codebase, let's view the test report. This will fail the transcript (with a nice message) if any of the tests are failing. + +``` ucm +scratch/main> test + + Cached test results (`help testcache` to learn more) + + 1. Any.test1 ◉ Passed + 2. Any.test2 ◉ Passed + 3. Boolean.tests.andTable ◉ Passed + 4. Boolean.tests.notTable ◉ Passed + 5. Boolean.tests.orTable ◉ Passed + 6. Bytes.tests.at ◉ Passed + 7. Bytes.tests.compression ◉ Passed + 8. Bytes.tests.fromBase64UrlUnpadded ◉ Passed + 9. Bytes.tests.indexOf ◉ Passed + 10. Int.tests.arithmetic ◉ Passed + 11. Int.tests.bitTwiddling ◉ Passed + 12. Int.tests.conversions ◉ Passed + 13. Nat.tests.arithmetic ◉ Passed + 14. Nat.tests.bitTwiddling ◉ Passed + 15. Nat.tests.conversions ◉ Passed + 16. Sandbox.test1 ◉ Passed + 17. Sandbox.test2 ◉ Passed + 18. Sandbox.test3 ◉ Passed + 19. test.rtjqan7bcs ◉ Passed + 20. Text.tests.alignment ◉ Passed + 21. Text.tests.indexOf ◉ Passed + 22. Text.tests.indexOfEmoji ◉ Passed + 23. Text.tests.literalsEq ◉ Passed + 24. Text.tests.patterns ◉ Passed + 25. Text.tests.repeat ◉ Passed + 26. Text.tests.takeDropAppend ◉ Passed + 27. Universal.murmurHash.tests ◉ Passed + + ✅ 27 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` diff --git a/unison-src/transcripts/idempotent/bytesFromList.md b/unison-src/transcripts/idempotent/bytesFromList.md new file mode 100644 index 0000000000..4640272396 --- /dev/null +++ b/unison-src/transcripts/idempotent/bytesFromList.md @@ -0,0 +1,24 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +This should render as `Bytes.fromList [1,2,3,4]`, not `##Bytes.fromSequence [1,2,3,4]`: + +``` unison +> Bytes.fromList [1,2,3,4] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > Bytes.fromList [1,2,3,4] + ⧩ + 0xs01020304 +``` diff --git a/unison-src/transcripts/idempotent/check763.md b/unison-src/transcripts/idempotent/check763.md new file mode 100644 index 0000000000..1582be2ea7 --- /dev/null +++ b/unison-src/transcripts/idempotent/check763.md @@ -0,0 +1,38 @@ +Regression test for https://github.com/unisonweb/unison/issues/763 + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +(+-+) : Nat -> Nat -> Nat +(+-+) x y = x * y +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + +-+ : Nat -> Nat -> Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + +-+ : Nat -> Nat -> Nat + +scratch/main> move.term +-+ boppitybeep + + Done. + +scratch/main> move.term boppitybeep +-+ + + Done. +``` diff --git a/unison-src/transcripts/idempotent/check873.md b/unison-src/transcripts/idempotent/check873.md new file mode 100644 index 0000000000..713767620f --- /dev/null +++ b/unison-src/transcripts/idempotent/check873.md @@ -0,0 +1,45 @@ +See [this ticket](https://github.com/unisonweb/unison/issues/873); the point being, this shouldn't crash the runtime. :) + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +(-) = builtin.Nat.sub +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + - : Nat -> Nat -> Int +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + - : Nat -> Nat -> Int +``` + +``` unison +baz x = x - 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + baz : Nat -> Int +``` diff --git a/unison-src/transcripts/idempotent/constructor-applied-to-unit.md b/unison-src/transcripts/idempotent/constructor-applied-to-unit.md new file mode 100644 index 0000000000..a0839b594f --- /dev/null +++ b/unison-src/transcripts/idempotent/constructor-applied-to-unit.md @@ -0,0 +1,60 @@ +``` ucm :hide +scratch/main> alias.type ##Nat Nat + +scratch/main> alias.term ##Any.Any Any +``` + +``` unison +structural type Zoink a b c = Zoink a b c + +> Any () +> [ Zoink [0,1,2,3,4,5] [6,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,4,3] () ] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type Zoink a b c + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 3 | > Any () + ⧩ + Any () + + 4 | > [ Zoink [0,1,2,3,4,5] [6,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,4,3] () ] + ⧩ + [ Zoink + [0, 1, 2, 3, 4, 5] + [ 6 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 3 + ] + () + ] +``` diff --git a/unison-src/transcripts/idempotent/contrabilities.md b/unison-src/transcripts/idempotent/contrabilities.md new file mode 100644 index 0000000000..717fb877c4 --- /dev/null +++ b/unison-src/transcripts/idempotent/contrabilities.md @@ -0,0 +1,20 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +f : (() -> a) -> Nat +f x = 42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + f : '{g} a -> Nat +``` diff --git a/unison-src/transcripts/idempotent/create-author.md b/unison-src/transcripts/idempotent/create-author.md new file mode 100644 index 0000000000..fa8c9adaa1 --- /dev/null +++ b/unison-src/transcripts/idempotent/create-author.md @@ -0,0 +1,23 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +Demonstrating `create.author`: + +``` ucm +scratch/main> create.author alicecoder "Alice McGee" + + Added definitions: + + 1. metadata.authors.alicecoder : Author + 2. metadata.copyrightHolders.alicecoder : CopyrightHolder + 3. metadata.authors.alicecoder.guid : GUID + + Tip: Add License values for alicecoder under metadata. + +scratch/main> find alicecoder + + 1. metadata.authors.alicecoder : Author + 2. metadata.copyrightHolders.alicecoder : CopyrightHolder + 3. metadata.authors.alicecoder.guid : GUID +``` diff --git a/unison-src/transcripts/idempotent/cycle-update-1.md b/unison-src/transcripts/idempotent/cycle-update-1.md new file mode 100644 index 0000000000..90cb99c8b3 --- /dev/null +++ b/unison-src/transcripts/idempotent/cycle-update-1.md @@ -0,0 +1,78 @@ +Update a member of a cycle, but retain the cycle. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +ping : 'Nat +ping _ = !pong + 1 + +pong : 'Nat +pong _ = !ping + 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ping : 'Nat + pong : 'Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ping : 'Nat + pong : 'Nat +``` + +``` unison +ping : 'Nat +ping _ = !pong + 3 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + ping : 'Nat +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +scratch/main> view ping pong + + ping : 'Nat + ping _ = + use Nat + + pong() + 3 + + pong : 'Nat + pong _ = + use Nat + + ping() + 2 +``` diff --git a/unison-src/transcripts/idempotent/cycle-update-2.md b/unison-src/transcripts/idempotent/cycle-update-2.md new file mode 100644 index 0000000000..30c05de9f2 --- /dev/null +++ b/unison-src/transcripts/idempotent/cycle-update-2.md @@ -0,0 +1,76 @@ +Update a member of a cycle with a type-preserving update, but sever the cycle. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +ping : 'Nat +ping _ = !pong + 1 + +pong : 'Nat +pong _ = !ping + 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ping : 'Nat + pong : 'Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ping : 'Nat + pong : 'Nat +``` + +``` unison +ping : 'Nat +ping _ = 3 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + ping : 'Nat +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +scratch/main> view ping pong + + ping : 'Nat + ping _ = 3 + + pong : 'Nat + pong _ = + use Nat + + ping() + 2 +``` diff --git a/unison-src/transcripts/idempotent/cycle-update-3.md b/unison-src/transcripts/idempotent/cycle-update-3.md new file mode 100644 index 0000000000..f9821b96b1 --- /dev/null +++ b/unison-src/transcripts/idempotent/cycle-update-3.md @@ -0,0 +1,71 @@ +Update a member of a cycle with a type-changing update, thus severing the cycle. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +ping : 'Nat +ping _ = !pong + 1 + +pong : 'Nat +pong _ = !ping + 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ping : 'Nat + pong : 'Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ping : 'Nat + pong : 'Nat +``` + +``` unison +ping : Nat +ping = 3 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + ping : Nat +``` + +``` ucm +scratch/main> update.old + + ⍟ I've updated these names to your new definition: + + ping : Nat + +scratch/main> view ping pong + + ping : Nat + ping = 3 + + pong : 'Nat + pong _ = + use Nat + + #4t465jk908.1() + 2 +``` diff --git a/unison-src/transcripts/idempotent/cycle-update-4.md b/unison-src/transcripts/idempotent/cycle-update-4.md new file mode 100644 index 0000000000..8bfc423b3c --- /dev/null +++ b/unison-src/transcripts/idempotent/cycle-update-4.md @@ -0,0 +1,90 @@ +`update` properly discovers and establishes new cycles. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +ping : 'Nat +ping _ = 1 + +pong : 'Nat +pong _ = !ping + 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ping : 'Nat + pong : 'Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ping : 'Nat + pong : 'Nat +``` + +``` unison +ping : 'Nat +ping _ = !clang + 1 + +clang : 'Nat +clang _ = !pong + 3 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + clang : 'Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + ping : 'Nat +``` + +``` ucm +scratch/main> update.old ping + + ⍟ I've added these definitions: + + clang : 'Nat + + ⍟ I've updated these names to your new definition: + + ping : 'Nat + pong : 'Nat + +scratch/main> view ping pong clang + + clang : 'Nat + clang _ = + use Nat + + pong() + 3 + + ping : 'Nat + ping _ = + use Nat + + clang() + 1 + + pong : 'Nat + pong _ = + use Nat + + ping() + 2 +``` diff --git a/unison-src/transcripts/idempotent/debug-definitions.md b/unison-src/transcripts/idempotent/debug-definitions.md new file mode 100644 index 0000000000..5bba3af74f --- /dev/null +++ b/unison-src/transcripts/idempotent/debug-definitions.md @@ -0,0 +1,157 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison :hide +x = 30 + +y : Nat +y = + z = x + 2 + z + 10 + +structural type Optional a = Some a | None + +ability Ask a where + ask : a +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ability Ask a + structural type Optional a + (also named builtin.Optional) + x : Nat + y : Nat + +scratch/main> debug.term.abt Nat.+ + + Builtin term: ##Nat.+ + +scratch/main> debug.term.abt y + + (let Ref(ReferenceBuiltin "Nat.+") Ref(ReferenceDerived (Id "qpo3o788girkkbb43uf6ggqberfduhtnqbt7096eojlrp27jieco09mdasb7b0b06ej9hj60a00nnbbdo8he0b4e0m7vtopifiuhdig" 0)) 2 in (User "z". Ref(ReferenceBuiltin "Nat.+") (Var User "z") 10)):ReferenceBuiltin "Nat" + +scratch/main> debug.term.abt Some + + Constructor #0 of the following type: + DataDeclaration + { modifier = Structural + , annotation = External + , bound = + [ User "a" ] + , constructors' = + [ + ( External + , User "Constructor0" + , + ( User "a". Var User "a" -> ReferenceDerived + ( Id "nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg" 0 ) + ( Var User "a" ) + ) + ) + , + ( External + , User "Constructor1" + , + ( User "a". ReferenceDerived + ( Id "nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg" 0 ) + ( Var User "a" ) + ) + ) + ] + } + +scratch/main> debug.term.abt ask + + Constructor #0 of the following type: + EffectDeclaration + { toDataDecl = DataDeclaration + { modifier = Unique "a1ns7cunv2dvjmum0q8jbc54g6811cbh" + , annotation = External + , bound = + [ User "a" ] + , constructors' = + [ + ( External + , User "Constructor0" + , + ( User "a". + ( + { + [ ReferenceDerived + ( Id "d8m1kmiscgfrl5n9ruvq1432lntfntl7nnao45qlk2uqhparm0uq2im0kbspu6u6kv65hd0i5oljq9m4b78peh5ekpma7gkihtsmfh0" 0 ) + ( Var User "a" ) + ] + } Var User "a" + ) + ) + ) + ] + } + } + +scratch/main> debug.type.abt Nat + + Builtin type: ##Nat + +scratch/main> debug.type.abt Optional + + DataDeclaration + { modifier = Structural + , annotation = External + , bound = + [ User "a" ] + , constructors' = + [ + ( External + , User "Constructor0" + , + ( User "a". Var User "a" -> ReferenceDerived + ( Id "nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg" 0 ) + ( Var User "a" ) + ) + ) + , + ( External + , User "Constructor1" + , + ( User "a". ReferenceDerived + ( Id "nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg" 0 ) + ( Var User "a" ) + ) + ) + ] + } + +scratch/main> debug.type.abt Ask + + EffectDeclaration + { toDataDecl = DataDeclaration + { modifier = Unique "a1ns7cunv2dvjmum0q8jbc54g6811cbh" + , annotation = External + , bound = + [ User "a" ] + , constructors' = + [ + ( External + , User "Constructor0" + , + ( User "a". + ( + { + [ ReferenceDerived + ( Id "d8m1kmiscgfrl5n9ruvq1432lntfntl7nnao45qlk2uqhparm0uq2im0kbspu6u6kv65hd0i5oljq9m4b78peh5ekpma7gkihtsmfh0" 0 ) + ( Var User "a" ) + ] + } Var User "a" + ) + ) + ) + ] + } + } +``` diff --git a/unison-src/transcripts/idempotent/debug-name-diffs.md b/unison-src/transcripts/idempotent/debug-name-diffs.md new file mode 100644 index 0000000000..8790c7db5e --- /dev/null +++ b/unison-src/transcripts/idempotent/debug-name-diffs.md @@ -0,0 +1,108 @@ +``` unison +a.b.one = 1 +a.two = 2 + +a.x.three = 3 +a.x.four = 4 + +structural type a.x.Foo = Foo | Bar +structural type a.b.Baz = Boo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type a.b.Baz + structural type a.x.Foo + a.b.one : ##Nat + a.two : ##Nat + a.x.four : ##Nat + a.x.three : ##Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type a.b.Baz + structural type a.x.Foo + a.b.one : ##Nat + a.two : ##Nat + a.x.four : ##Nat + a.x.three : ##Nat + +scratch/main> delete.term.verbose a.b.one + + Removed definitions: + + 1. a.b.one : ##Nat + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. + +scratch/main> alias.term a.two a.newtwo + + Done. + +scratch/main> move.namespace a.x a.y + + Done. + +scratch/main> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #tteooc9j2d + + > Moves: + + Original name New name + a.x.Foo a.y.Foo + a.x.Foo.Bar a.y.Foo.Bar + a.x.Foo.Foo a.y.Foo.Foo + a.x.four a.y.four + a.x.three a.y.three + + ⊙ 2. #bicrtgqj12 + + + Adds / updates: + + a.newtwo + + = Copies: + + Original name New name(s) + a.two a.newtwo + + ⊙ 3. #bofp4huk1j + + - Deletes: + + a.b.one + + □ 4. #gss5s88mo3 (start of history) + +scratch/main> debug.name-diff 4 1 + + Kind Name Change Ref + Term a.newtwo Added #dcgdua2lj6upd1ah5v0qp09gjsej0d77d87fu6qn8e2qrssnlnmuinoio46hiu53magr7qn8vnqke8ndt0v76700o5u8gcvo7st28jg + Term a.y.four Added #vcfbbslncd2qloc03kalgsmufl3j5es6cehcrbmlj6t78d4uk5j9gpa3hhf2opln1u2kiepg5n2cn49ianf2oig0mi4c2ldn1r9lf40 + Term a.y.three Added #f3lgjvjqoocpt8v6kdgd2bgthh11a7md3qdp9rf5datccmo580btjd5bt5dro3irqs0is7vm7s1dphddjbtufch620te7ef7canmjj8 + Term a.y.Foo.Bar Added #6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0#d1 + Term a.y.Foo.Foo Added #6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0#d0 + Term a.b.one Removed #gjmq673r1vrurfotlnirv7vutdhm6sa3s02em5g22kk606mv6duvv8be402dv79312i4a0onepq5bo7citsodvq2g720nttj0ee9p0g + Term a.x.four Removed #vcfbbslncd2qloc03kalgsmufl3j5es6cehcrbmlj6t78d4uk5j9gpa3hhf2opln1u2kiepg5n2cn49ianf2oig0mi4c2ldn1r9lf40 + Term a.x.three Removed #f3lgjvjqoocpt8v6kdgd2bgthh11a7md3qdp9rf5datccmo580btjd5bt5dro3irqs0is7vm7s1dphddjbtufch620te7ef7canmjj8 + Term a.x.Foo.Bar Removed #6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0#d1 + Term a.x.Foo.Foo Removed #6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0#d0 + Type a.y.Foo Added #6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0 + Type a.x.Foo Removed #6kbe32g06nqg93cqub6ohqc4ql4o49ntgnunifds0t75qre6lacnbsr3evn8bkivj68ecbvmhkbak4dbg4fqertcpgb396rmo34tnh0 +``` diff --git a/unison-src/transcripts/idempotent/deep-names.md b/unison-src/transcripts/idempotent/deep-names.md new file mode 100644 index 0000000000..34d842859d --- /dev/null +++ b/unison-src/transcripts/idempotent/deep-names.md @@ -0,0 +1,115 @@ +First we'll set up two libraries, and then we'll use them in some projects and show what `names` are deep-loaded for them. + +Our two "libraries": + +``` unison :hide +text.a = 1 +text.b = 2 +text.c = 3 + +http.x = 6 +http.y = 7 +http.z = 8 +``` + +``` ucm :hide +scratch/main> add + +scratch/main> branch /app1 + +scratch/main> branch /app2 +``` + +Our `app1` project includes the text library twice and the http library twice as direct dependencies. + +``` ucm +scratch/app1> fork text lib.text_v1 + + Done. + +scratch/app1> fork text lib.text_v2 + + Done. + +scratch/app1> delete.namespace text + + Done. + +scratch/app1> fork http lib.http_v3 + + Done. + +scratch/app1> fork http lib.http_v4 + + Done. + +scratch/app1> delete.namespace http + + Done. +``` + +As such, we see two copies of `a` and two copies of `x` via these direct dependencies. + +``` ucm +scratch/app1> names a + + Term + Hash: #gjmq673r1v + Names: lib.text_v1.a lib.text_v2.a + +scratch/app1> names x + + Term + Hash: #nsmc4p1ra4 + Names: lib.http_v3.x lib.http_v4.x +``` + +Our `app2` project includes the `http` library twice as direct dependencies, and once as an indirect dependency via `webutil`. +It also includes the `text` library twice as indirect dependencies via `webutil` + +``` ucm +scratch/app2> fork http lib.http_v1 + + Done. + +scratch/app2> fork http lib.http_v2 + + Done. + +scratch/app2> fork text lib.webutil.lib.text_v1 + + Done. + +scratch/app2> fork text lib.webutil.lib.text_v2 + + Done. + +scratch/app2> fork http lib.webutil.lib.http + + Done. + +scratch/app2> delete.namespace http + + Done. + +scratch/app2> delete.namespace text + + Done. +``` + +Now we see two copies of `x` via direct dependencies on `http`, and one copy of `a` via indirect dependency on `text` via `webutil`. +We see neither the second indirect copy of `a` nor the indirect copy of `x` via webutil because we already have names for them. + +``` ucm +scratch/app2> names a + + Term + Hash: #gjmq673r1v + Names: lib.webutil.lib.text_v1.a + +scratch/app2> names x + + Term + Hash: #nsmc4p1ra4 + Names: lib.http_v1.x lib.http_v2.x +``` diff --git a/unison-src/transcripts/idempotent/definition-diff-api.md b/unison-src/transcripts/idempotent/definition-diff-api.md new file mode 100644 index 0000000000..77b48abfda --- /dev/null +++ b/unison-src/transcripts/idempotent/definition-diff-api.md @@ -0,0 +1,4232 @@ +``` ucm +diffs/main> builtins.mergeio lib.builtins + + Done. + +diffs/main> alias.term lib.builtins.Nat.gt lib.builtins.Nat.> + + Done. + +diffs/main> alias.term lib.builtins.Nat.drop lib.builtins.Nat.- + + Done. +``` + +``` unison +term = + _ = "Here's some text" + 1 + 1 + +type Type = Type Nat + +ability Stream a where + emit : a -> () + +take n s = + use Nat > - + h n = cases + { emit a -> k } -> if n > 0 + then + emit a + handle k() with h (n - 1) + else None + { r } -> Some r + handle s() with h n + +id x = x +unitCase = id (x -> 1) + +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ability Stream a + type Type + id : x -> x + take : Nat -> '{g} t ->{g, Stream a} Optional t + term : Nat + unitCase : x -> Nat +``` + +``` ucm +diffs/main> add + + ⍟ I've added these definitions: + + ability Stream a + type Type + id : x -> x + take : Nat -> '{g} t ->{g, Stream a} Optional t + term : Nat + unitCase : x -> Nat + +diffs/main> branch.create new + + Done. I've created the new branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /new`. +``` + +``` unison +term = + _ = "Here's some different text" + 1 + 2 + +type Type a = Type a Text + +ability Stream a where + emit : a -> () + +take n s = + use Nat > - + h n = cases + { emit a -> k } -> + emit a + if n > 0 + then handle k() with h (n - 1) + else None + { r } -> Some r + if n > 0 + then handle s () with h (n - 1) + else None + +id x = x +unitCase = id (x -> (1, ())) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⊡ Previously added definitions will be ignored: Stream id + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Type a + take : Nat -> '{g} t ->{g, Stream a} Optional t + term : Nat + unitCase : x -> (Nat, ()) +``` + +``` ucm +diffs/new> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +Diff terms + +``` api +GET /api/projects/diffs/diff/terms?oldBranchRef=main&newBranchRef=new&oldTerm=term&newTerm=term + { + "diff": { + "contents": [ + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseKeyword" + }, + "segment": "use " + }, + { + "annotation": { + "tag": "UsePrefix" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "_", + "tag": "HashQualifier" + }, + "segment": "_" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "old", + "elements": [ + { + "annotation": { + "tag": "TextLiteral" + }, + "segment": "\"Here's some text\"" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": { + "tag": "TextLiteral" + }, + "segment": "\"Here's some different text\"" + } + ] + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.+", + "tag": "TermReference" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "old", + "elements": [ + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "2" + } + ] + } + ], + "tag": "UserObject" + }, + "diffKind": "diff", + "newBranchRef": "new", + "newTerm": { + "bestTermName": "term", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseKeyword" + }, + "segment": "use " + }, + { + "annotation": { + "tag": "UsePrefix" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "_", + "tag": "HashQualifier" + }, + "segment": "_" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TextLiteral" + }, + "segment": "\"Here's some different text\"" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.+", + "tag": "TermReference" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "2" + } + ], + "tag": "UserObject" + }, + "termDocs": [], + "termNames": [ + "term" + ] + }, + "oldBranchRef": "main", + "oldTerm": { + "bestTermName": "term", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseKeyword" + }, + "segment": "use " + }, + { + "annotation": { + "tag": "UsePrefix" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "_", + "tag": "HashQualifier" + }, + "segment": "_" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TextLiteral" + }, + "segment": "\"Here's some text\"" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.+", + "tag": "TermReference" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + } + ], + "tag": "UserObject" + }, + "termDocs": [], + "termNames": [ + "term" + ] + }, + "project": "diffs" + } +``` + +More complex diff + +``` api +GET /api/projects/diffs/diff/terms?oldBranchRef=main&newBranchRef=new&oldTerm=take&newTerm=take + { + "diff": { + "contents": [ + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "contents": "take", + "tag": "HashQualifier" + }, + "segment": "take" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelayForceChar" + }, + "segment": "'" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "t" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": null, + "segment": "," + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#b035k0tpdv9jbs80ig29hujmv9kpkubda6or4320o5g7aj7edsudislnp2uovntgu5b0e6a18p0p7j8r2hcpr20blls7am8nll6t2ro", + "tag": "TypeReference" + }, + "segment": "Stream" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg", + "tag": "TypeReference" + }, + "segment": "Optional" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "t" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "take", + "tag": "HashQualifier" + }, + "segment": "take" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "s" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseKeyword" + }, + "segment": "use " + }, + { + "annotation": { + "tag": "UsePrefix" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": "-" + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": ">" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "h", + "tag": "HashQualifier" + }, + "segment": "h" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "cases" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "{" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#b035k0tpdv9jbs80ig29hujmv9kpkubda6or4320o5g7aj7edsudislnp2uovntgu5b0e6a18p0p7j8r2hcpr20blls7am8nll6t2ro#a0", + "tag": "TermReference" + }, + "segment": "emit" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "k" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "old", + "elements": [ + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "if " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.>", + "tag": "TermReference" + }, + "segment": ">" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "0" + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": " then" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "contents": "#b035k0tpdv9jbs80ig29hujmv9kpkubda6or4320o5g7aj7edsudislnp2uovntgu5b0e6a18p0p7j8r2hcpr20blls7am8nll6t2ro#a0", + "tag": "TermReference" + }, + "segment": "emit" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "old", + "elements": [ + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "if" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.>", + "tag": "TermReference" + }, + "segment": ">" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "0" + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": " then" + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "handle" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "k" + }, + { + "annotation": { + "tag": "Unit" + }, + "segment": "()" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "with" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "h" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": "(" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.drop", + "tag": "TermReference" + }, + "segment": "-" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": ")" + } + ] + }, + { + "diffTag": "old", + "elements": [ + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "else" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg#d1", + "tag": "TermReference" + }, + "segment": "None" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "{" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "r" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg#d0", + "tag": "TermReference" + }, + "segment": "Some" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "r" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "if" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.>", + "tag": "TermReference" + }, + "segment": ">" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "0" + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": " then" + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "handle" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "s" + }, + { + "annotation": { + "tag": "Unit" + }, + "segment": "()" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "with" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "h" + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": "(" + } + ] + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.drop", + "tag": "TermReference" + }, + "segment": "-" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": ")" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "else" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg#d1", + "tag": "TermReference" + }, + "segment": "None" + } + ] + } + ], + "tag": "UserObject" + }, + "diffKind": "diff", + "newBranchRef": "new", + "newTerm": { + "bestTermName": "take", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelayForceChar" + }, + "segment": "'" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "t" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": null, + "segment": "," + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#b035k0tpdv9jbs80ig29hujmv9kpkubda6or4320o5g7aj7edsudislnp2uovntgu5b0e6a18p0p7j8r2hcpr20blls7am8nll6t2ro", + "tag": "TypeReference" + }, + "segment": "Stream" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg", + "tag": "TypeReference" + }, + "segment": "Optional" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "t" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "take", + "tag": "HashQualifier" + }, + "segment": "take" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelayForceChar" + }, + "segment": "'" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "t" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": null, + "segment": "," + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#b035k0tpdv9jbs80ig29hujmv9kpkubda6or4320o5g7aj7edsudislnp2uovntgu5b0e6a18p0p7j8r2hcpr20blls7am8nll6t2ro", + "tag": "TypeReference" + }, + "segment": "Stream" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg", + "tag": "TypeReference" + }, + "segment": "Optional" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "t" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "take", + "tag": "HashQualifier" + }, + "segment": "take" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "s" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseKeyword" + }, + "segment": "use " + }, + { + "annotation": { + "tag": "UsePrefix" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": "-" + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": ">" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "h", + "tag": "HashQualifier" + }, + "segment": "h" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "cases" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "{" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#b035k0tpdv9jbs80ig29hujmv9kpkubda6or4320o5g7aj7edsudislnp2uovntgu5b0e6a18p0p7j8r2hcpr20blls7am8nll6t2ro#a0", + "tag": "TermReference" + }, + "segment": "emit" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "k" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#b035k0tpdv9jbs80ig29hujmv9kpkubda6or4320o5g7aj7edsudislnp2uovntgu5b0e6a18p0p7j8r2hcpr20blls7am8nll6t2ro#a0", + "tag": "TermReference" + }, + "segment": "emit" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "if" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.>", + "tag": "TermReference" + }, + "segment": ">" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "0" + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": " then" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "handle" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "k" + }, + { + "annotation": { + "tag": "Unit" + }, + "segment": "()" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "with" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "h" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": "(" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.drop", + "tag": "TermReference" + }, + "segment": "-" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": ")" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "else" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg#d1", + "tag": "TermReference" + }, + "segment": "None" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "{" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "r" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg#d0", + "tag": "TermReference" + }, + "segment": "Some" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "r" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "if" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.>", + "tag": "TermReference" + }, + "segment": ">" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "0" + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": " then" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "handle" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "s" + }, + { + "annotation": { + "tag": "Unit" + }, + "segment": "()" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "with" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "h" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": "(" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.drop", + "tag": "TermReference" + }, + "segment": "-" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": ")" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "else" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg#d1", + "tag": "TermReference" + }, + "segment": "None" + } + ], + "tag": "UserObject" + }, + "termDocs": [], + "termNames": [ + "take" + ] + }, + "oldBranchRef": "main", + "oldTerm": { + "bestTermName": "take", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelayForceChar" + }, + "segment": "'" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "t" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": null, + "segment": "," + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#b035k0tpdv9jbs80ig29hujmv9kpkubda6or4320o5g7aj7edsudislnp2uovntgu5b0e6a18p0p7j8r2hcpr20blls7am8nll6t2ro", + "tag": "TypeReference" + }, + "segment": "Stream" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg", + "tag": "TypeReference" + }, + "segment": "Optional" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "t" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "take", + "tag": "HashQualifier" + }, + "segment": "take" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelayForceChar" + }, + "segment": "'" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "t" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": null, + "segment": "," + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#b035k0tpdv9jbs80ig29hujmv9kpkubda6or4320o5g7aj7edsudislnp2uovntgu5b0e6a18p0p7j8r2hcpr20blls7am8nll6t2ro", + "tag": "TypeReference" + }, + "segment": "Stream" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg", + "tag": "TypeReference" + }, + "segment": "Optional" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "t" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "take", + "tag": "HashQualifier" + }, + "segment": "take" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "s" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseKeyword" + }, + "segment": "use " + }, + { + "annotation": { + "tag": "UsePrefix" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": "-" + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": ">" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "h", + "tag": "HashQualifier" + }, + "segment": "h" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "cases" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "{" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#b035k0tpdv9jbs80ig29hujmv9kpkubda6or4320o5g7aj7edsudislnp2uovntgu5b0e6a18p0p7j8r2hcpr20blls7am8nll6t2ro#a0", + "tag": "TermReference" + }, + "segment": "emit" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "k" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "if " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.>", + "tag": "TermReference" + }, + "segment": ">" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "0" + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": " then" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#b035k0tpdv9jbs80ig29hujmv9kpkubda6or4320o5g7aj7edsudislnp2uovntgu5b0e6a18p0p7j8r2hcpr20blls7am8nll6t2ro#a0", + "tag": "TermReference" + }, + "segment": "emit" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "handle" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "k" + }, + { + "annotation": { + "tag": "Unit" + }, + "segment": "()" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "with" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "h" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": "(" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.drop", + "tag": "TermReference" + }, + "segment": "-" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": ")" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "else" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg#d1", + "tag": "TermReference" + }, + "segment": "None" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "{" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "r" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg#d0", + "tag": "TermReference" + }, + "segment": "Some" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "r" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "handle" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "s" + }, + { + "annotation": { + "tag": "Unit" + }, + "segment": "()" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": "with" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "h" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "n" + } + ], + "tag": "UserObject" + }, + "termDocs": [], + "termNames": [ + "take" + ] + }, + "project": "diffs" + } +``` + +Regression test for weird behavior w/r to unit and parens. + +``` api +GET /api/projects/diffs/diff/terms?oldBranchRef=main&newBranchRef=new&oldTerm=unitCase&newTerm=unitCase + { + "diff": { + "contents": [ + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "contents": "unitCase", + "tag": "HashQualifier" + }, + "segment": "unitCase" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "x" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": null, + "segment": "(" + } + ] + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": null, + "segment": "," + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": "(" + }, + { + "annotation": null, + "segment": ")" + }, + { + "annotation": null, + "segment": ")" + } + ] + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "unitCase", + "tag": "HashQualifier" + }, + "segment": "unitCase" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#ttjui80dbufvf3vgaddmcr065dpgl0rtp68i5cdht6tq4t2vk3i2vg60hi77rug368qijgijf8oui27te7o5oq0t0osm6dg65c080i0", + "tag": "TermReference" + }, + "segment": "id" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": "(" + }, + { + "annotation": null, + "segment": "x" + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": " ->" + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": { + "contents": "#2lg4ah6ir6t129m33d7gssnigacral39qdamo20mn6r2vefliubpeqnjhejai9ekjckv0qnu9mlu3k9nbpfhl2schec4dohn7rjhjt8", + "tag": "TypeReference" + }, + "segment": "(" + } + ] + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": { + "contents": "#2lg4ah6ir6t129m33d7gssnigacral39qdamo20mn6r2vefliubpeqnjhejai9ekjckv0qnu9mlu3k9nbpfhl2schec4dohn7rjhjt8", + "tag": "TypeReference" + }, + "segment": ", " + }, + { + "annotation": { + "contents": "#2lg4ah6ir6t129m33d7gssnigacral39qdamo20mn6r2vefliubpeqnjhejai9ekjckv0qnu9mlu3k9nbpfhl2schec4dohn7rjhjt8", + "tag": "TypeReference" + }, + "segment": "(" + } + ] + }, + { + "diffTag": "old", + "elements": [ + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": ")" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": { + "contents": "#2lg4ah6ir6t129m33d7gssnigacral39qdamo20mn6r2vefliubpeqnjhejai9ekjckv0qnu9mlu3k9nbpfhl2schec4dohn7rjhjt8", + "tag": "TypeReference" + }, + "segment": ")" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": { + "contents": "#2lg4ah6ir6t129m33d7gssnigacral39qdamo20mn6r2vefliubpeqnjhejai9ekjckv0qnu9mlu3k9nbpfhl2schec4dohn7rjhjt8", + "tag": "TypeReference" + }, + "segment": ")" + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": ")" + } + ] + } + ], + "tag": "UserObject" + }, + "diffKind": "diff", + "newBranchRef": "new", + "newTerm": { + "bestTermName": "unitCase", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "tag": "Var" + }, + "segment": "x" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": "(" + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "," + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": "(" + }, + { + "annotation": null, + "segment": ")" + }, + { + "annotation": null, + "segment": ")" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "unitCase", + "tag": "HashQualifier" + }, + "segment": "unitCase" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "x" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": "(" + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "," + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": null, + "segment": "(" + }, + { + "annotation": null, + "segment": ")" + }, + { + "annotation": null, + "segment": ")" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "unitCase", + "tag": "HashQualifier" + }, + "segment": "unitCase" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#ttjui80dbufvf3vgaddmcr065dpgl0rtp68i5cdht6tq4t2vk3i2vg60hi77rug368qijgijf8oui27te7o5oq0t0osm6dg65c080i0", + "tag": "TermReference" + }, + "segment": "id" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": "(" + }, + { + "annotation": null, + "segment": "x" + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": " ->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#2lg4ah6ir6t129m33d7gssnigacral39qdamo20mn6r2vefliubpeqnjhejai9ekjckv0qnu9mlu3k9nbpfhl2schec4dohn7rjhjt8", + "tag": "TypeReference" + }, + "segment": "(" + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": { + "contents": "#2lg4ah6ir6t129m33d7gssnigacral39qdamo20mn6r2vefliubpeqnjhejai9ekjckv0qnu9mlu3k9nbpfhl2schec4dohn7rjhjt8", + "tag": "TypeReference" + }, + "segment": ", " + }, + { + "annotation": { + "contents": "#2lg4ah6ir6t129m33d7gssnigacral39qdamo20mn6r2vefliubpeqnjhejai9ekjckv0qnu9mlu3k9nbpfhl2schec4dohn7rjhjt8", + "tag": "TypeReference" + }, + "segment": "(" + }, + { + "annotation": { + "contents": "#2lg4ah6ir6t129m33d7gssnigacral39qdamo20mn6r2vefliubpeqnjhejai9ekjckv0qnu9mlu3k9nbpfhl2schec4dohn7rjhjt8", + "tag": "TypeReference" + }, + "segment": ")" + }, + { + "annotation": { + "contents": "#2lg4ah6ir6t129m33d7gssnigacral39qdamo20mn6r2vefliubpeqnjhejai9ekjckv0qnu9mlu3k9nbpfhl2schec4dohn7rjhjt8", + "tag": "TypeReference" + }, + "segment": ")" + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": ")" + } + ], + "tag": "UserObject" + }, + "termDocs": [], + "termNames": [ + "unitCase" + ] + }, + "oldBranchRef": "main", + "oldTerm": { + "bestTermName": "unitCase", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "tag": "Var" + }, + "segment": "x" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "unitCase", + "tag": "HashQualifier" + }, + "segment": "unitCase" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "x" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "unitCase", + "tag": "HashQualifier" + }, + "segment": "unitCase" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#ttjui80dbufvf3vgaddmcr065dpgl0rtp68i5cdht6tq4t2vk3i2vg60hi77rug368qijgijf8oui27te7o5oq0t0osm6dg65c080i0", + "tag": "TermReference" + }, + "segment": "id" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": "(" + }, + { + "annotation": null, + "segment": "x" + }, + { + "annotation": { + "tag": "ControlKeyword" + }, + "segment": " ->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": { + "tag": "Parenthesis" + }, + "segment": ")" + } + ], + "tag": "UserObject" + }, + "termDocs": [], + "termNames": [ + "unitCase" + ] + }, + "project": "diffs" + } +``` + +Diff types + +``` api +GET /api/projects/diffs/diff/types?oldBranchRef=main&newBranchRef=new&oldType=Type&newType=Type + { + "diff": { + "contents": [ + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "tag": "DataTypeKeyword" + }, + "segment": "type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "Type", + "tag": "HashQualifier" + }, + "segment": "Type" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DataTypeParams" + }, + "segment": "a" + } + ] + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": " = " + } + ] + }, + { + "diffTag": "annotationChange", + "fromAnnotation": { + "contents": "#m5hlrmkn9a3kuqabta2e9qs934em1qmkotpsh9tjvta2u86nuesbjbk2k2sprbdiljq7uqibp49vku4gfpg2u60ceiv8net1f0bu2n8#d0", + "tag": "TermReference" + }, + "segment": "Type", + "toAnnotation": { + "contents": "#uik7pl3klg4u2obtf2fattdaeldui46ohmsi0knpp5hu8tn4d5o8vp570qgh7esgap0pmq9cfrh9dfg1r8qa7qh33g45a3tric24o20#d0", + "tag": "TermReference" + } + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "old", + "elements": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + } + ] + } + ], + "tag": "UserObject" + }, + "diffKind": "diff", + "newBranchRef": "new", + "newType": { + "bestTypeName": "Type", + "defnTypeTag": "Data", + "typeDefinition": { + "contents": [ + { + "annotation": { + "tag": "DataTypeKeyword" + }, + "segment": "type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "Type", + "tag": "HashQualifier" + }, + "segment": "Type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DataTypeParams" + }, + "segment": "a" + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": " = " + }, + { + "annotation": { + "contents": "#uik7pl3klg4u2obtf2fattdaeldui46ohmsi0knpp5hu8tn4d5o8vp570qgh7esgap0pmq9cfrh9dfg1r8qa7qh33g45a3tric24o20#d0", + "tag": "TermReference" + }, + "segment": "Type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + } + ], + "tag": "UserObject" + }, + "typeDocs": [], + "typeNames": [ + "Type" + ] + }, + "oldBranchRef": "main", + "oldType": { + "bestTypeName": "Type", + "defnTypeTag": "Data", + "typeDefinition": { + "contents": [ + { + "annotation": { + "tag": "DataTypeKeyword" + }, + "segment": "type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "Type", + "tag": "HashQualifier" + }, + "segment": "Type" + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": " = " + }, + { + "annotation": { + "contents": "#m5hlrmkn9a3kuqabta2e9qs934em1qmkotpsh9tjvta2u86nuesbjbk2k2sprbdiljq7uqibp49vku4gfpg2u60ceiv8net1f0bu2n8#d0", + "tag": "TermReference" + }, + "segment": "Type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "tag": "UserObject" + }, + "typeDocs": [], + "typeNames": [ + "Type" + ] + }, + "project": "diffs" + } +``` diff --git a/unison-src/transcripts/idempotent/delete-namespace-dependents-check.md b/unison-src/transcripts/idempotent/delete-namespace-dependents-check.md new file mode 100644 index 0000000000..0ded266003 --- /dev/null +++ b/unison-src/transcripts/idempotent/delete-namespace-dependents-check.md @@ -0,0 +1,64 @@ + + +# Delete namespace dependents check + +This is a regression test, previously `delete.namespace` allowed a delete as long as the deletions had a name *anywhere* in your codebase, it should only check the current project branch. + +``` ucm :hide +myproject/main> builtins.merge +``` + +``` unison +sub.dependency = 123 + +dependent = dependency + 99 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + dependent : Nat + sub.dependency : Nat +``` + +``` ucm :error +myproject/main> add + + ⍟ I've added these definitions: + + dependent : Nat + sub.dependency : Nat + +myproject/main> branch /new + + Done. I've created the new branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /new`. + +myproject/new> delete.namespace sub + + ⚠️ + + I didn't delete the namespace because the following + definitions are still in use. + + Dependency Referenced In + dependency 1. dependent + + If you want to proceed anyways and leave those definitions + without names, use delete.namespace.force + +myproject/new> view dependent + + dependent : Nat + dependent = + use Nat + + dependency + 99 +``` diff --git a/unison-src/transcripts/idempotent/delete-namespace.md b/unison-src/transcripts/idempotent/delete-namespace.md new file mode 100644 index 0000000000..c3afeb7cb8 --- /dev/null +++ b/unison-src/transcripts/idempotent/delete-namespace.md @@ -0,0 +1,129 @@ +# delete.namespace.force + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison :hide +no_dependencies.thing = "no dependents on this term" + +dependencies.term1 = 1 +dependencies.term2 = 2 + +dependents.usage1 = dependencies.term1 + dependencies.term2 +dependents.usage2 = dependencies.term1 * dependencies.term2 +``` + +``` ucm :hide +scratch/main> add +``` + +Deleting a namespace with no external dependencies should succeed. + +``` ucm +scratch/main> delete.namespace no_dependencies + + Done. +``` + +Deleting a namespace with external dependencies should fail and list all dependents. + +``` ucm :error +scratch/main> delete.namespace dependencies + + ⚠️ + + I didn't delete the namespace because the following + definitions are still in use. + + Dependency Referenced In + term2 1. dependents.usage1 + 2. dependents.usage2 + + term1 3. dependents.usage1 + 4. dependents.usage2 + + If you want to proceed anyways and leave those definitions + without names, use delete.namespace.force +``` + +Deleting a namespace with external dependencies should succeed when using `delete.namespace.force` + +``` ucm +scratch/main> delete.namespace.force dependencies + + Done. + + ⚠️ + + Of the things I deleted, the following are still used in the + following definitions. They now contain un-named references. + + Dependency Referenced In + term2 1. dependents.usage1 + 2. dependents.usage2 + + term1 3. dependents.usage1 + 4. dependents.usage2 +``` + +I should be able to view an affected dependency by number + +``` ucm +scratch/main> view 2 + + dependents.usage2 : Nat + dependents.usage2 = + use Nat * + #gjmq673r1v * #dcgdua2lj6 +``` + +Deleting the root namespace should require confirmation if not forced. + +``` ucm +scratch/main> delete.namespace . + + ⚠️ + + Are you sure you want to clear away everything? + You could use `project.create` to switch to a new project + instead, or delete the current branch with `delete.branch` + +scratch/main> delete.namespace . + + Okay, I deleted everything except the history. Use `undo` to + undo, or `builtins.merge` to restore the absolute basics to + the current path. + +-- Should have an empty history + +scratch/main> history . + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #sg60bvjo91 (start of history) +``` + +Deleting the root namespace shouldn't require confirmation if forced. + +``` ucm +scratch/main> delete.namespace.force . + + Okay, I deleted everything except the history. Use `undo` to + undo, or `builtins.merge` to restore the absolute basics to + the current path. + +-- Should have an empty history + +scratch/main> history . + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #sg60bvjo91 (start of history) +``` diff --git a/unison-src/transcripts/idempotent/delete-project-branch.md b/unison-src/transcripts/idempotent/delete-project-branch.md new file mode 100644 index 0000000000..62f93b38b0 --- /dev/null +++ b/unison-src/transcripts/idempotent/delete-project-branch.md @@ -0,0 +1,71 @@ +Deleting the branch you are on takes you to its parent (though this is impossible to see in a transcript, since we set +your working directory with each command). + +``` ucm +foo/main> branch topic + + Done. I've created the topic branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic`. + +foo/topic> delete.branch /topic +``` + +A branch need not be preceded by a forward slash. + +``` ucm +foo/main> branch topic + + Done. I've created the topic branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic`. + +foo/topic> delete.branch topic +``` + +You can precede the branch name by a project name. + +``` ucm +foo/main> branch topic + + Done. I've created the topic branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic`. + +scratch/main> delete.branch foo/topic +``` + +You can delete the only branch in a project. + +``` ucm +foo/main> delete.branch /main +``` + +You can delete the last branch in the project, a new one will be created. + +``` ucm +scratch/main> delete.branch scratch/main + +scratch/main> branches + + Branch Remote branch + 1. main + 2. main2 +``` + +If the the last branch isn't /main, then /main will be created. + +``` ucm +scratch/main2> delete.branch /main + +scratch/main2> delete.branch /main2 + +scratch/other> branches + + Branch Remote branch + 1. main + 2. other +``` diff --git a/unison-src/transcripts/idempotent/delete-project.md b/unison-src/transcripts/idempotent/delete-project.md new file mode 100644 index 0000000000..3a9a3b90c6 --- /dev/null +++ b/unison-src/transcripts/idempotent/delete-project.md @@ -0,0 +1,72 @@ +# delete.project + +``` ucm +scratch/main> project.create-empty foo + + 🎉 I've created the project foo. + + 🎨 Type `ui` to explore this project's code in your browser. + 🔭 Discover libraries at https://share.unison-lang.org + 📖 Use `help-topic projects` to learn more about projects. + + Write your first Unison code with UCM: + + 1. Open scratch.u. + 2. Write some Unison code and save the file. + 3. In UCM, type `add` to save it to your new project. + + 🎉 🥳 Happy coding! + +scratch/main> project.create-empty bar + + 🎉 I've created the project bar. + + 🎨 Type `ui` to explore this project's code in your browser. + 🔭 Discover libraries at https://share.unison-lang.org + 📖 Use `help-topic projects` to learn more about projects. + + Write your first Unison code with UCM: + + 1. Open scratch.u. + 2. Write some Unison code and save the file. + 3. In UCM, type `add` to save it to your new project. + + 🎉 🥳 Happy coding! + +-- I can delete the project I'm currently on + +scratch/main> delete.project scratch + +foo/main> projects + + 1. bar + 2. foo + +-- I can delete a different project + +foo/main> delete.project bar + +foo/main> projects + + 1. foo + +-- I can delete the last project, a new scratch project will be created + +foo/main> delete.project foo + +project/main> projects + + 1. project + 2. scratch + +-- If the last project is scratch, a scratch2 project will be created. + +scratch/main> delete.project project + +scratch/main> delete.project scratch + +project/main> projects + + 1. project + 2. scratch2 +``` diff --git a/unison-src/transcripts/idempotent/delete-silent.md b/unison-src/transcripts/idempotent/delete-silent.md new file mode 100644 index 0000000000..0afc953732 --- /dev/null +++ b/unison-src/transcripts/idempotent/delete-silent.md @@ -0,0 +1,34 @@ +``` ucm :error +scratch/main> delete foo + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + foo +``` + +``` unison :hide +foo = 1 +structural type Foo = Foo () +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type Foo + foo : ##Nat + +scratch/main> delete foo + + Done. + +scratch/main> delete.type Foo + + Done. + +scratch/main> delete.term Foo.Foo + + Done. +``` diff --git a/unison-src/transcripts/idempotent/delete.md b/unison-src/transcripts/idempotent/delete.md new file mode 100644 index 0000000000..45ed52aba8 --- /dev/null +++ b/unison-src/transcripts/idempotent/delete.md @@ -0,0 +1,433 @@ +# Delete + +``` ucm :hide +scratch/main> builtins.merge lib.builtins +``` + +The delete command can delete both terms and types. + +First, let's make sure it complains when we try to delete a name that doesn't +exist. + +``` ucm :error +scratch/main> delete.verbose foo + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + foo +``` + +Now for some easy cases. Deleting an unambiguous term, then deleting an +unambiguous type. + +``` unison :hide +foo = 1 +structural type Foo = Foo () +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type Foo + foo : Nat + +scratch/main> delete.verbose foo + + Removed definitions: + + 1. foo : Nat + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. + +scratch/main> delete.verbose Foo + + Removed definitions: + + 1. structural type Foo + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. + +scratch/main> delete.verbose Foo.Foo + + Removed definitions: + + 1. Foo.Foo : '#089vmor9c5 + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. +``` + +How about an ambiguous term? + +``` unison :hide +a.foo = 1 +a.bar = 2 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + a.bar : Nat + a.foo : Nat + +scratch/main> debug.alias.term.force a.bar a.foo + + Done. +``` + +A delete should remove both versions of the term. + +``` ucm +scratch/main> delete.verbose a.foo + + Removed definitions: + + 1. a.foo#gjmq673r1v : Nat + + Name changes: + + Original Changes + 2. a.bar ┐ 3. a.foo#dcgdua2lj6 (removed) + 4. a.foo#dcgdua2lj6 ┘ + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. + +scratch/main> ls a + + 1. bar (Nat) +``` + +Let's repeat all that on a type, for completeness. + +``` unison :hide +structural type a.Foo = Foo () +structural type a.Bar = Bar +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type a.Bar + (also named lib.builtins.Unit) + structural type a.Foo + +scratch/main> debug.alias.type.force a.Bar a.Foo + + Done. + +scratch/main> delete.verbose a.Foo + + Removed definitions: + + 1. structural type a.Foo#089vmor9c5 + + Name changes: + + Original Changes + 2. a.Bar ┐ 3. a.Foo#00nv2kob8f (removed) + 4. lib.builtins.Unit │ + 5. a.Foo#00nv2kob8f ┘ + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. + +scratch/main> delete.verbose a.Foo.Foo + + Removed definitions: + + 1. a.Foo.Foo : '#089vmor9c5 + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. +``` + +Finally, let's try to delete a term and a type with the same name. + +``` unison :hide +foo = 1 +structural type foo = Foo () +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type foo + foo : Nat + +scratch/main> delete.verbose foo + + Removed definitions: + + 1. structural type foo + 2. foo : Nat + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. +``` + +We want to be able to delete multiple terms at once + +``` unison :hide +a = "a" +b = "b" +c = "c" +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + a : Text + b : Text + c : Text + +scratch/main> delete.verbose a b c + + Removed definitions: + + 1. a : Text + 2. b : Text + 3. c : Text + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. +``` + +We can delete terms and types in the same invocation of delete + +``` unison :hide +structural type Foo = Foo () +a = "a" +b = "b" +c = "c" +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type Foo + a : Text + b : Text + c : Text + +scratch/main> delete.verbose a b c Foo + + Removed definitions: + + 1. structural type Foo + 2. a : Text + 3. b : Text + 4. c : Text + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. + +scratch/main> delete.verbose Foo.Foo + + Name changes: + + Original Changes + 1. Foo.Foo ┐ 2. Foo.Foo (removed) + 3. foo.Foo ┘ + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. +``` + +We can delete a type and its constructors + +``` unison :hide +structural type Foo = Foo () +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type Foo + +scratch/main> delete.verbose Foo Foo.Foo + + Removed definitions: + + 1. structural type Foo + + Name changes: + + Original Changes + 2. Foo.Foo ┐ 3. Foo.Foo (removed) + 4. foo.Foo ┘ + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. +``` + +You should not be able to delete terms which are referenced by other terms + +``` unison :hide +a = 1 +b = 2 +c = 3 +d = a + b + c +``` + +``` ucm :error +scratch/main> add + + ⍟ I've added these definitions: + + a : Nat + b : Nat + (also named a.bar) + c : Nat + d : Nat + +scratch/main> delete.verbose a b c + + ⚠️ + + I didn't delete the following definitions because they are + still in use: + + Dependency Referenced In + c 1. d + + a 2. d +``` + +But you should be able to delete all terms which reference each other in a single command + +``` unison :hide +e = 11 +f = 12 + e +g = 13 + f +h = e + f + g +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + e : Nat + f : Nat + g : Nat + h : Nat + +scratch/main> delete.verbose e f g h + + Removed definitions: + + 1. e : Nat + 2. f : Nat + 3. g : Nat + 4. h : Nat + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. +``` + +You should be able to delete a type and all the functions that reference it in a single command + +``` unison :hide +structural type Foo = Foo Nat + +incrementFoo : Foo -> Nat +incrementFoo = cases + (Foo.Foo n) -> n + 1 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type Foo + incrementFoo : Foo -> Nat + +scratch/main> delete.verbose Foo Foo.Foo incrementFoo + + Removed definitions: + + 1. structural type Foo + 2. Foo.Foo : Nat -> Foo + 3. incrementFoo : Foo -> Nat + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. +``` + +If you mess up on one of the names of your command, delete short circuits + +``` unison :hide +e = 11 +f = 12 + e +g = 13 + f +h = e + f + g +``` + +``` ucm :error +scratch/main> add + + ⍟ I've added these definitions: + + e : Nat + f : Nat + g : Nat + h : Nat + +scratch/main> delete.verbose e f gg + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + gg +``` + +Cyclical terms which are guarded by a lambda are allowed to be deleted + +``` unison :hide +ping _ = 1 Nat.+ !pong +pong _ = 4 Nat.+ !ping +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ping : 'Nat + pong : 'Nat + +scratch/main> delete.verbose ping + + Removed definitions: + + 1. ping : 'Nat + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. + +scratch/main> view pong + + pong : 'Nat + pong _ = + use Nat + + 4 + #l9uq1dpl5v.1() +``` diff --git a/unison-src/transcripts/idempotent/dependents-dependencies-debugfile.md b/unison-src/transcripts/idempotent/dependents-dependencies-debugfile.md new file mode 100644 index 0000000000..715aefd5b9 --- /dev/null +++ b/unison-src/transcripts/idempotent/dependents-dependencies-debugfile.md @@ -0,0 +1,120 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +### `debug.file` + +I can use `debug.file` to see the hashes of the last typechecked file. + +Given this .u file: + +``` unison :hide +structural type outside.A = A Nat outside.B +structural type outside.B = B Int +outside.c = 3 +outside.d = c < (p + 1) + +structural type inside.M = M outside.A +inside.p = c +inside.q x = x + p * p +inside.r = d +``` + +``` ucm +scratch/main> debug.file + + type inside.M#h37a56c5ep + type outside.A#6l6krl7n4l + type outside.B#eo6rj0lj1b + inside.p#htoo5rnb54 + inside.q#1mqcoh3tnk + inside.r#nkgohbke6n + outside.c#f3lgjvjqoo + outside.d#ukd7tu6kds +``` + +This will help me make progress in some situations when UCM is being deficient or broken. + +### `dependents` / `dependencies` + +But wait, there's more. I can check the dependencies and dependents of a definition: + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type inside.M + structural type outside.A + structural type outside.B + inside.p : Nat + inside.q : Nat -> Nat + inside.r : Boolean + outside.c : Nat + outside.d : Boolean + +scratch/main> dependents q + + q has no dependents. + +scratch/main> dependencies q + + Dependencies of: q + + Types: + + 1. Nat + + Terms: + + 2. Nat.* + 3. Nat.+ + 4. p + + Tip: Try `view 4` to see the source of any numbered item in + the above list. + +scratch/main> dependencies B + + Dependencies of: type B, B + + Types: + + 1. B + 2. Int + + Tip: Try `view 2` to see the source of any numbered item in + the above list. + +scratch/main> dependencies d + + Dependencies of: d + + Types: + + 1. Boolean + 2. Nat + + Terms: + + 3. < + 4. c + 5. Nat.+ + 6. p + + Tip: Try `view 6` to see the source of any numbered item in + the above list. + +scratch/main> dependents d + + Dependents of: d + + Terms: + + 1. r + + Tip: Try `view 1` to see the source of any numbered item in + the above list. +``` + +We don't have an index for dependents of constructors, but iirc if you ask for that, it will show you dependents of the structural type that provided the constructor. diff --git a/unison-src/transcripts/idempotent/destructuring-binds.md b/unison-src/transcripts/idempotent/destructuring-binds.md new file mode 100644 index 0000000000..e18e80649a --- /dev/null +++ b/unison-src/transcripts/idempotent/destructuring-binds.md @@ -0,0 +1,176 @@ +# Destructuring binds + +``` ucm :hide +scratch/main> builtins.merge +``` + +Here's a couple examples: + +``` unison +ex0 : Nat -> Nat +ex0 n = + (a, _, (c,d)) = ("uno", "dos", (n, 7)) + c + d + +ex1 : (a,b,(Nat,Nat)) -> Nat +ex1 tup = + (a, b, (c,d)) = tup + c + d +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex0 : Nat -> Nat + ex1 : (a, b, (Nat, Nat)) -> Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ex0 : Nat -> Nat + ex1 : (a, b, (Nat, Nat)) -> Nat + +scratch/main> view ex0 ex1 + + ex0 : Nat -> Nat + ex0 n = + use Nat + + (a, _, (c, d)) = ("uno", "dos", (n, 7)) + c + d + + ex1 : (a, b, (Nat, Nat)) -> Nat + ex1 = cases (a, b, (c, d)) -> c Nat.+ d +``` + +Notice that `ex0` is printed using the `cases` syntax (but `ex1` is not). The pretty-printer currently prefers the `cases` syntax if definition can be printed using either destructuring bind or `cases`. + +A destructuring bind is just syntax for a single branch pattern match. Notice that Unison detects this function as an alias of `ex1`: + +``` unison +ex2 : (a,b,(Nat,Nat)) -> Nat +ex2 tup = match tup with + (a, b, (c,d)) -> c + d +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex2 : (a, b, (Nat, Nat)) -> Nat + (also named ex1) +``` + +## Corner cases + +Destructuring binds can't be recursive: the left-hand side bound variables aren't available on the right hand side. For instance, this doesn't typecheck: + +``` unison :error +ex4 = + (a,b) = (a Nat.+ b, 19) + "Doesn't typecheck" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I couldn't figure out what a refers to here: + + 2 | (a,b) = (a Nat.+ b, 19) + + I think its type should be: + + Nat + + Some common causes of this error include: + * Your current namespace is too deep to contain the + definition in its subtree + * The definition is part of a library which hasn't been + added to this project + * You have a typo in the name +``` + +Even though the parser accepts any pattern on the LHS of a bind, it looks pretty weird to see things like `12 = x`, so we avoid showing a destructuring bind when the LHS is a "literal" pattern (like `42` or "hi"). Again these examples wouldn't compile with coverage checking. + +``` unison +ex5 : 'Text +ex5 _ = match 99 + 1 with + 12 -> "Hi" + _ -> "Bye" + +ex5a : 'Text +ex5a _ = match (99 + 1, "hi") with + (x, "hi") -> "Not printed as a destructuring bind." + _ -> "impossible" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex5 : 'Text + ex5a : 'Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ex5 : 'Text + ex5a : 'Text + +scratch/main> view ex5 ex5a + + ex5 : 'Text + ex5 _ = match 99 Nat.+ 1 with + 12 -> "Hi" + _ -> "Bye" + + ex5a : 'Text + ex5a _ = match (99 Nat.+ 1, "hi") with + (x, "hi") -> "Not printed as a destructuring bind." + _ -> "impossible" +``` + +Notice how it prints both an ordinary match. + +Also, for clarity, the pretty-printer shows a single-branch match if the match shadows free variables of the scrutinee, for example: + +``` unison :hide +ex6 x = match x with + (x, y) -> x Nat.+ y +``` + +For clarity, the pretty-printer leaves this alone, even though in theory it could be written `(x,y) = x; x + y`: + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ex6 : (Nat, Nat) -> Nat + +scratch/main> view ex6 + + ex6 : (Nat, Nat) -> Nat + ex6 = cases (x, y) -> x Nat.+ y +``` diff --git a/unison-src/transcripts/idempotent/diff-namespace.md b/unison-src/transcripts/idempotent/diff-namespace.md new file mode 100644 index 0000000000..64063922aa --- /dev/null +++ b/unison-src/transcripts/idempotent/diff-namespace.md @@ -0,0 +1,581 @@ +``` ucm :hide +scratch/b1> builtins.merge lib.builtins + +scratch/b2> builtins.merge lib.builtins + +scratch/nsx> builtins.merge lib.builtins + +scratch/main> builtins.merge lib.builtins + +scratch/ns1> builtins.merge lib.builtins +``` + +``` unison :hide +x = 23 +fslkdjflskdjflksjdf = 663 +``` + +``` ucm +scratch/b1> add + + ⍟ I've added these definitions: + + fslkdjflskdjflksjdf : Nat + x : Nat +``` + +``` unison :hide +x = 23 +fslkdjflskdjflksjdf = 23 +abc = 23 +``` + +``` ucm +scratch/b2> add + + ⍟ I've added these definitions: + + abc : Nat + fslkdjflskdjflksjdf : Nat + x : Nat + +scratch/b1> debug.alias.term.force .x .fslkdjflskdjflksjdf + + Done. +``` + +``` ucm +scratch/main> diff.namespace /b1: /b2: + + Resolved name conflicts: + + 1. ┌ fslkdjflskdjflksjdf#sekb3fdsvb : Nat + 2. └ fslkdjflskdjflksjdf#u520d1t9kc : Nat + ↓ + 3. fslkdjflskdjflksjdf#u520d1t9kc : Nat + + Name changes: + + Original Changes + 4. x ┐ 5. abc (added) + 6. fslkdjflskdjflksjdf#u520d1t9kc ┘ 7. fslkdjflskdjflksjdf (added) + 8. fslkdjflskdjflksjdf#u520d1t9kc (removed) +``` + +Things we want to test: + + - Diffing identical namespaces + - Adds, removes, updates + - Adds with multiple names + - Moved and copied definitions + - Moves that have more that 1 initial or final name + - ... terms and types + - New patches, modified patches, deleted patches, moved patches + - With and without propagated updates + +``` unison :hide +fromJust = 1 +b = 2 +bdependent = b +c = 3 +helloWorld = "Hello, world!" + +structural type A a = A () +structural ability X a1 a2 where x : () +``` + +``` ucm +scratch/ns1> add + + ⍟ I've added these definitions: + + structural type A a + structural ability X a1 a2 + b : Nat + bdependent : Nat + c : Nat + fromJust : Nat + helloWorld : Text + +scratch/ns1> alias.term fromJust fromJust' + + Done. + +scratch/ns1> alias.term helloWorld helloWorld2 + + Done. + +scratch/ns1> branch /ns2 + + Done. I've created the ns2 branch based off of ns1. + + Tip: To merge your work back into the ns1 branch, first + `switch /ns1` then `merge /ns2`. +``` + +Here's what we've done so far: + +``` ucm :error +scratch/main> diff.namespace .nothing /ns1: + + ⚠️ + + The namespace scratch/main:.nothing is empty. Was there a typo? +``` + +``` ucm :error +scratch/main> diff.namespace /ns1: /ns2: + + The namespaces are identical. +``` + +``` unison :hide +junk = "asldkfjasldkfj" +``` + +``` ucm +scratch/ns1> add + + ⍟ I've added these definitions: + + junk : Text + +scratch/ns1> debug.alias.term.force junk fromJust + + Done. + +scratch/ns1> delete.term junk + + Done. +``` + +``` unison :hide +fromJust = 99 +b = 999999999 +d = 4 +e = 5 +f = 6 +unique type Y a b = Y a b +``` + +``` ucm +scratch/ns2> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +scratch/main> diff.namespace /ns1: /ns2: + + Resolved name conflicts: + + 1. ┌ fromJust#gjmq673r1v : Nat + 2. └ fromJust#rnbo52q2sh : Text + ↓ + 3. fromJust#6gn1k53ie0 : Nat + + Updates: + + 4. b : Nat + ↓ + 5. b : Nat + + 6. bdependent : Nat + ↓ + 7. bdependent : Nat + + Added definitions: + + 8. type Y a b + 9. Y.Y : a -> b -> Y a b + 10. d : Nat + 11. e : Nat + 12. f : Nat + + Name changes: + + Original Changes + 13. fromJust' ┐ 14. fromJust#gjmq673r1v (removed) + 15. fromJust#gjmq673r1v ┘ + +scratch/ns2> alias.term d d' + + Done. + +scratch/ns2> alias.type A A' + + Done. + +scratch/ns2> alias.term A.A A'.A + + Done. + +scratch/ns2> alias.type X X' + + Done. + +scratch/ns2> alias.term X.x X'.x + + Done. + +scratch/main> diff.namespace /ns1: /ns2: + + Resolved name conflicts: + + 1. ┌ fromJust#gjmq673r1v : Nat + 2. └ fromJust#rnbo52q2sh : Text + ↓ + 3. fromJust#6gn1k53ie0 : Nat + + Updates: + + 4. b : Nat + ↓ + 5. b : Nat + + 6. bdependent : Nat + ↓ + 7. bdependent : Nat + + Added definitions: + + 8. type Y a b + 9. Y.Y : a -> b -> Y a b + 10. ┌ d : Nat + 11. └ d' : Nat + 12. e : Nat + 13. f : Nat + + Name changes: + + Original Changes + 14. A 15. A' (added) + + 16. X 17. X' (added) + + 18. A.A 19. A'.A (added) + + 20. fromJust' ┐ 21. fromJust#gjmq673r1v (removed) + 22. fromJust#gjmq673r1v ┘ + + 23. X.x 24. X'.x (added) + +scratch/ns1> alias.type X X2 + + Done. + +scratch/ns1> alias.term X.x X2.x + + Done. + +scratch/ns2> alias.type A' A'' + + Done. + +scratch/ns2> alias.term A'.A A''.A + + Done. + +scratch/ns2> branch /ns3 + + Done. I've created the ns3 branch based off of ns2. + + Tip: To merge your work back into the ns2 branch, first + `switch /ns2` then `merge /ns3`. + +scratch/ns2> alias.term fromJust' yoohoo + + Done. + +scratch/ns2> delete.term.verbose fromJust' + + Name changes: + + Original Changes + 1. fromJust' ┐ 2. fromJust' (removed) + 3. yoohoo ┘ + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. + +scratch/main> diff.namespace /ns3: /ns2: + + Name changes: + + Original Changes + 1. fromJust' 2. yoohoo (added) + 3. fromJust' (removed) +``` + +``` unison :hide +bdependent = "banana" +``` + +``` ucm +scratch/ns3> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> diff.namespace /ns2: /ns3: + + Updates: + + 1. bdependent : Nat + ↓ + 2. bdependent : Text + + Name changes: + + Original Changes + 3. yoohoo 4. fromJust' (added) + 5. yoohoo (removed) +``` + +## Two different auto-propagated changes creating a name conflict + +Currently, the auto-propagated name-conflicted definitions are not explicitly +shown, only their also-conflicted dependency is shown. + +``` unison :hide +a = 333 +b = a + 1 + +forconflicts = 777 +``` + +``` ucm +scratch/nsx> add + + ⍟ I've added these definitions: + + a : Nat + b : Nat + forconflicts : Nat + +scratch/nsx> branch /nsy + + Done. I've created the nsy branch based off of nsx. + + Tip: To merge your work back into the nsx branch, first + `switch /nsx` then `merge /nsy`. + +scratch/nsx> branch /nsz + + Done. I've created the nsz branch based off of nsx. + + Tip: To merge your work back into the nsx branch, first + `switch /nsx` then `merge /nsz`. +``` + +``` unison :hide +a = 444 +``` + +``` ucm +scratch/nsy> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. +``` + +``` unison :hide +a = 555 +``` + +``` ucm +scratch/nsz> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +scratch/nsy> branch /nsw + + Done. I've created the nsw branch based off of nsy. + + Tip: To merge your work back into the nsy branch, first + `switch /nsy` then `merge /nsw`. + +scratch/nsw> debug.alias.term.force .forconflicts .a + + Done. + +scratch/nsw> debug.alias.term.force .forconflicts .b + + Done. +``` + +``` ucm +scratch/main> diff.namespace /nsx: /nsw: + + New name conflicts: + + 1. a#uiiiv8a86s : Nat + ↓ + 2. ┌ a#mdl4vqtu00 : Nat + 3. └ a#r3msrbpp1v : Nat + + 4. b#lhigeb1let : Nat + ↓ + 5. ┌ b#r3msrbpp1v : Nat + 6. └ b#unkqhuu66p : Nat + + Name changes: + + Original Changes + 7. forconflicts 8. a#r3msrbpp1v (added) + 9. b#r3msrbpp1v (added) + +scratch/nsw> view a + + a#mdl4vqtu00 : Nat + a#mdl4vqtu00 = 444 + + a#r3msrbpp1v : Nat + a#r3msrbpp1v = 777 + +scratch/nsw> view b + + b#r3msrbpp1v : Nat + b#r3msrbpp1v = 777 + + b#unkqhuu66p : Nat + b#unkqhuu66p = + use Nat + + a#mdl4vqtu00 + 1 +``` + +## Should be able to diff a namespace hash from history. + +``` unison +x = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + x : Nat +``` + +``` ucm +scratch/hashdiff> add + + ⍟ I've added these definitions: + + x : ##Nat +``` + +``` unison +y = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + y : ##Nat +``` + +``` ucm +scratch/hashdiff> add + + ⍟ I've added these definitions: + + y : ##Nat + +scratch/hashdiff> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #ru1hnjofdj + + + Adds / updates: + + y + + □ 2. #i52j9fd57b (start of history) + +scratch/hashdiff> diff.namespace 2 1 + + Added definitions: + + 1. y : ##Nat +``` + +## + +Updates: -- 1 to 1 + +New name conflicts: -- updates where RHS has multiple hashes (excluding when RHS=LHS) + +1. foo\#jk19sm5bf8 : Nat - do we want to force a hashqualified? Arya thinks so + ↓ +2. ┌ foo\#0ja1qfpej6 : Nat +3. └ foo\#jk19sm5bf8 : Nat + +Resolved name conflicts: -- updates where LHS had multiple hashes and RHS has one + +4. ┌ bar\#0ja1qfpej6 : Nat +5. └ bar\#jk19sm5bf8 : Nat + ↓ +6. bar\#jk19sm5bf8 : Nat + +## Display issues to fixup + + - \[d\] Do we want to surface new edit conflicts in patches? + - \[t\] two different auto-propagated changes creating a name conflict should show + up somewhere besides the auto-propagate count + - \[t\] Things look screwy when the type signature doesn't fit and has to get broken + up into multiple lines. Maybe just disallow that? + - \[d\] Delete blank line in between copies / renames entries if all entries are 1 to 1 + see todo in the code + - \[x\] incorrectly calculated bracket alignment on hashqualified "Name changes" (delete.output.md) + - \[x\] just handle deletion of isPropagated in propagate function, leave HandleInput alone (assuming this does the trick) + - \[x\] might want unqualified names to be qualified sometimes: + - \[x\] if a name is updated to a not-yet-named reference, it's shown as both an update and an add + - \[x\] similarly, if a conflicted name is resolved by deleting the last name to + a reference, I (arya) suspect it will show up as a Remove + - \[d\] Maybe group and/or add headings to the types, constructors, terms + - \[x\] add tagging of propagated updates to test propagated updates output + - \[x\] missing old names in deletion ppe (delete.output.md) (superseded by \#1143) + - \[x\] delete.term has some bonkers output + - \[x\] Make a decision about how we want to show constructors in the diff + - \[x\] 12.patch patch needs a space + - \[x\] This looks like garbage + - \[x\] Extra 2 blank lines at the end of the add section + - \[x\] Fix alignment issues with buildTable, convert to column3M (to be written) + - \[x\] adding an alias is showing up as an Add and a Copy; should just show as Copy + - \[x\] removing one of multiple aliases appears in removes + moves + copies section + - \[x\] some overlapping cases between Moves and Copies^ + - \[x\] Maybe don't list the type signature twice for aliases? diff --git a/unison-src/transcripts/idempotent/doc-formatting.md b/unison-src/transcripts/idempotent/doc-formatting.md new file mode 100644 index 0000000000..079b3d5af8 --- /dev/null +++ b/unison-src/transcripts/idempotent/doc-formatting.md @@ -0,0 +1,578 @@ +This transcript explains a few minor details about doc parsing and pretty-printing, both from a user point of view and with some implementation notes. The later stuff is meant more as unit testing than for human consumption. (The ucm `add` commands and their output are hidden for brevity.) + +Docs can be used as inline code comments. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +foo : Nat -> Nat +foo n = + _ = [: do the thing :] + n + 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : Nat -> Nat +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view foo + + foo : Nat -> Nat + foo n = + use Nat + + _ = [: do the thing :] + n + 1 +``` + +Note that `@` and `:]` must be escaped within docs. + +``` unison +escaping = [: Docs look [: like \@this \:] :] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + escaping : Doc +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view escaping + + escaping : Doc + escaping = [: Docs look [: like \@this \:] :] +``` + +(Alas you can't have `\@` or `\:]` in your doc, as there's currently no way to 'unescape' them.) + +``` unison +-- Note that -- comments are preserved within doc literals. +commented = [: + example: + + -- a comment + f x = x + 1 +:] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + commented : Doc +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view commented + + commented : Doc + commented = + [: example: + + -- a comment f x = x + 1 + :] +``` + +### Indenting, and paragraph reflow + +Handling of indenting in docs between the parser and pretty-printer is a bit fiddly. + +``` unison +-- The leading and trailing spaces are stripped from the stored Doc by the +-- lexer, and one leading and trailing space is inserted again on view/edit +-- by the pretty-printer. +doc1 = [: hi :] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + doc1 : Doc +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view doc1 + + doc1 : Doc + doc1 = [: hi :] +``` + +``` unison +-- Lines (apart from the first line, i.e. the bit between the [: and the +-- first newline) are unindented until at least one of +-- them hits the left margin (by a post-processing step in the parser). +-- You may not notice this because the pretty-printer indents them again on +-- view/edit. +doc2 = [: hello + - foo + - bar + and the rest. :] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + doc2 : Doc +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view doc2 + + doc2 : Doc + doc2 = + [: hello + - foo + - bar + and the rest. :] +``` + +``` unison +doc3 = [: When Unison identifies a paragraph, it removes any newlines from it before storing it, and then reflows the paragraph text to fit the display window on display/view/edit. + +For these purposes, a paragraph is any sequence of non-empty lines that have zero indent (after the unindenting mentioned above.) + + - So this is not a paragraph, even + though you might want it to be. + + And this text | as a paragraph + is not treated | either. + +Note that because of the special treatment of the first line mentioned above, where its leading space is removed, it is always treated as a paragraph. + :] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + doc3 : Doc +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view doc3 + + doc3 : Doc + doc3 = + [: When Unison identifies a paragraph, it removes any + newlines from it before storing it, and then reflows the + paragraph text to fit the display window on + display/view/edit. + + For these purposes, a paragraph is any sequence of non-empty + lines that have zero indent (after the unindenting mentioned + above.) + + - So this is not a paragraph, even + though you might want it to be. + + And this text | as a paragraph + is not treated | either. + + Note that because of the special treatment of the first line + mentioned above, where its leading space is removed, it is + always treated as a paragraph. + :] +``` + +``` unison +doc4 = [: Here's another example of some paragraphs. + + All these lines have zero indent. + + - Apart from this one. :] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + doc4 : Doc +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view doc4 + + doc4 : Doc + doc4 = + [: Here's another example of some paragraphs. + + All these lines have zero indent. + + - Apart from this one. :] +``` + +``` unison +-- The special treatment of the first line does mean that the following +-- is pretty-printed not so prettily. To fix that we'd need to get the +-- lexer to help out with interpreting doc literal indentation (because +-- it knows what columns the `[:` was in.) +doc5 = [: - foo + - bar + and the rest. :] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + doc5 : Doc +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view doc5 + + doc5 : Doc + doc5 = + [: - foo + - bar + and the rest. :] +``` + +``` unison +-- You can do the following to avoid that problem. +doc6 = [: + - foo + - bar + and the rest. + :] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + doc6 : Doc +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view doc6 + + doc6 : Doc + doc6 = + [: - foo + - bar + and the rest. + :] +``` + +### More testing + +``` unison +-- Check empty doc works. +empty = [::] + +expr = foo 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + empty : Doc + expr : Nat +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view empty + + empty : Doc + empty = [: :] +``` + +``` unison +test1 = [: +The internal logic starts to get hairy when you use the \@ features, for example referencing a name like @List.take. Internally, the text between each such usage is its own blob (blob ends here --> @List.take), so paragraph reflow has to be aware of multiple blobs to do paragraph reflow (or, more accurately, to do the normalization step where newlines with a paragraph are removed.) + +Para to reflow: lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor ending in ref @List.take + +@List.take starting para lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor. + +Middle of para: lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor @List.take lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor. + + - non-para line (@List.take) with ref @List.take + Another non-para line + @List.take starting non-para line + + - non-para line with ref @List.take +before a para-line lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor. + + - non-para line followed by a para line starting with ref +@List.take lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor. + +a para-line ending with ref lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor @List.take + - non-para line + +para line lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor + @List.take followed by non-para line starting with ref. + +@[signature] List.take + +@[source] foo + +@[evaluate] expr + +@[include] doc1 + +-- note the leading space below + @[signature] List.take + +:] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + test1 : Doc +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view test1 + + test1 : Doc + test1 = + [: The internal logic starts to get hairy when you use the + \@ features, for example referencing a name like @List.take. + Internally, the text between each such usage is its own blob + (blob ends here --> @List.take), so paragraph reflow has to + be aware of multiple blobs to do paragraph reflow (or, more + accurately, to do the normalization step where newlines with + a paragraph are removed.) + + Para to reflow: lorem ipsum dolor lorem ipsum dolor lorem + ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum + dolor lorem ipsum dolor ending in ref @List.take + + @List.take starting para lorem ipsum dolor lorem ipsum dolor + lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem + ipsum dolor lorem ipsum dolor. + + Middle of para: lorem ipsum dolor lorem ipsum dolor lorem + ipsum dolor @List.take lorem ipsum dolor lorem ipsum dolor + lorem ipsum dolor lorem ipsum dolor. + + - non-para line (@List.take) with ref @List.take + Another non-para line + @List.take starting non-para line + + - non-para line with ref @List.take + before a para-line lorem ipsum dolor lorem ipsum dolor lorem + ipsum dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum + dolor lorem ipsum dolor lorem ipsum dolor. + + - non-para line followed by a para line starting with ref + @List.take lorem ipsum dolor lorem ipsum dolor lorem ipsum + dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor + lorem ipsum dolor lorem ipsum dolor. + + a para-line ending with ref lorem ipsum dolor lorem ipsum + dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor + lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor @List.take + - non-para line + + para line lorem ipsum dolor lorem ipsum dolor lorem ipsum + dolor lorem ipsum dolor lorem ipsum dolor lorem ipsum dolor + lorem ipsum dolor lorem ipsum dolor + @List.take followed by non-para line starting with ref. + + @[signature] List.take + + @[source] foo + + @[evaluate] expr + + @[include] doc1 + + -- note the leading space below + @[signature] List.take + + :] +``` + +``` unison +-- Regression test for #1363 - preservation of spaces after @ directives in first line when unindenting +reg1363 = [: `@List.take foo` bar + baz :] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + reg1363 : Doc +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view reg1363 + + reg1363 : Doc + reg1363 = [: `@List.take foo` bar baz :] +``` + +``` unison +-- Demonstrate doc display when whitespace follows a @[source] or @[evaluate] +-- whose output spans multiple lines. + +test2 = [: + Take a look at this: + @[source] foo ▶ bar +:] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + test2 : Doc +``` + +``` ucm :hide +scratch/main> add +``` + +View is fine. + +``` ucm +scratch/main> view test2 + + test2 : Doc + test2 = + [: Take a look at this: + @[source] foo ▶ bar + :] +``` + +But note it's not obvious how display should best be handling this. At the moment it just does the simplest thing: + +``` ucm +scratch/main> display test2 + + Take a look at this: + foo : Nat -> Nat + foo n = + use Nat + + _ = [: do the thing :] + n + 1 ▶ bar +``` diff --git a/unison-src/transcripts/idempotent/doc-type-link-keywords.md b/unison-src/transcripts/idempotent/doc-type-link-keywords.md new file mode 100644 index 0000000000..f44cb26737 --- /dev/null +++ b/unison-src/transcripts/idempotent/doc-type-link-keywords.md @@ -0,0 +1,52 @@ +Regression test to ensure that `type` and `ability` in embedded doc links are +lexed properly when they occur at the start of identifiers. + +That is, `{abilityPatterns}` should be a link to the **term** `abilityPatterns`, +not the ability `Patterns`; the lexer should see this as a single identifier. + +See https://github.com/unisonweb/unison/issues/2642 for an example. + +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison :hide +abilityPatterns : () +abilityPatterns = () + +structural ability Patterns where p : () + +typeLabels : Nat +typeLabels = 5 + +structural type Labels = Labels + +docs.example1 = {{A doc that links to the {abilityPatterns} term}} +docs.example2 = {{A doc that links to the {ability Patterns} ability}} +docs.example3 = {{A doc that links to the {typeLabels} term}} +docs.example4 = {{A doc that links to the {type Labels} type}} +``` + +``` ucm :hide +scratch/main> add +``` + +Now we check that each doc links to the object of the correct name: + +``` ucm +scratch/main> display docs.example1 + + A doc that links to the abilityPatterns term + +scratch/main> display docs.example2 + + A doc that links to the Patterns ability + +scratch/main> display docs.example3 + + A doc that links to the typeLabels term + +scratch/main> display docs.example4 + + A doc that links to the Labels type +``` diff --git a/unison-src/transcripts/idempotent/doc1.md b/unison-src/transcripts/idempotent/doc1.md new file mode 100644 index 0000000000..85e23d20f6 --- /dev/null +++ b/unison-src/transcripts/idempotent/doc1.md @@ -0,0 +1,158 @@ +# Documenting Unison code + +``` ucm :hide +scratch/main> builtins.merge lib.builtins +``` + +Unison documentation is written in Unison. Documentation is a value of the following type: + +``` ucm +scratch/main> view lib.builtins.Doc + + type lib.builtins.Doc + = Blob Text + | Link Link + | Source Link + | Signature Term + | Evaluate Term + | Join [lib.builtins.Doc] +``` + +You can create these `Doc` values with ordinary code, or you can use the special syntax. A value of structural type `Doc` can be created via syntax like: + +``` unison +doc1 = [: This is some documentation. + +It can span multiple lines. + +Can link to definitions like @List.drop or @List + +:] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + doc1 : Doc +``` + +Syntax: + +`[:` starts a documentation block; `:]` finishes it. Within the block: + + - Links to definitions are done with `@List`. `\@` (and `\:]`) if you want to escape. + - `@[signature] List.take` expands to the type signature of `List.take` + - `@[source] List.map` expands to the full source of `List.map` + - `@[include] someOtherDoc`, inserts a value `someOtherDoc : Doc` here. + - `@[evaluate] someDefinition` expands to the result of evaluating `someDefinition`, which must be a pre-existing definition in the codebase (can't be an arbitrary expression). + +### An example + +We are going to document `List.take` using some verbiage and a few examples. First we have to add the examples to the codebase: + +``` unison +List.take.ex1 = take 0 [1,2,3,4,5] +List.take.ex2 = take 2 [1,2,3,4,5] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + List.take.ex1 : [Nat] + List.take.ex2 : [Nat] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + List.take.ex1 : [Nat] + List.take.ex2 : [Nat] +``` + +And now let's write our docs and reference these examples: + +``` unison +List.take.doc = [: +`@List.take n xs` returns the first `n` elements of `xs`. (No need to add line breaks manually. The display command will do wrapping of text for you. Indent any lines where you don't want it to do this.) + +## Examples: + + @[source] List.take.ex1 + 🔽 + @List.take.ex1 = @[evaluate] List.take.ex1 + + + @[source] List.take.ex2 + 🔽 + @List.take.ex2 = @[evaluate] List.take.ex2 +:] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + List.take.doc : Doc +``` + +Let's add it to the codebase. + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + List.take.doc : Doc +``` + +We can view it with `docs`, which shows the `Doc` value that is associated with a definition. + +``` ucm +scratch/main> docs List.take + + `List.take n xs` returns the first `n` elements of `xs`. (No + need to add line breaks manually. The display command will do + wrapping of text for you. Indent any lines where you don't + want it to do this.) + + ## Examples: + + List.take.ex1 : [Nat] + List.take.ex1 = List.take 0 [1, 2, 3, 4, 5] + 🔽 + ex1 = [] + + + List.take.ex2 : [Nat] + List.take.ex2 = List.take 2 [1, 2, 3, 4, 5] + 🔽 + ex2 = [1, 2] +``` + +Note that if we view the source of the documentation, the various references are *not* expanded. + +``` ucm +scratch/main> view List.take + + builtin lib.builtins.List.take : + lib.builtins.Nat -> [a] -> [a] +``` diff --git a/unison-src/transcripts/idempotent/doc2.md b/unison-src/transcripts/idempotent/doc2.md new file mode 100644 index 0000000000..1e164c14ce --- /dev/null +++ b/unison-src/transcripts/idempotent/doc2.md @@ -0,0 +1,220 @@ +# Test parsing and round-trip of doc2 syntax elements + +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison :hide +otherDoc : a -> Doc2 +otherDoc _ = {{ yo }} + +otherTerm : Nat +otherTerm = 99 + +fulldoc : Doc2 +fulldoc = + use Nat + + {{ +Heres some text with a +soft line break + +hard line break + +Here's a cool **BOLD** __italic__ ~~strikethrough~~ thing with an inline code block `1 + 2` + +Should print with appropriate fences for the contents: + +`No fancy quotes` + +'' There are `backticks` in here '' + +''' There are `backticks` and ''quotes'' in here ''' + +# Heading + +## Heading 2 + +Term Link: {otherTerm} + +Type Link: {type Optional} + +Term source: + +@source{term} + +Term signature: + +@signature{term} + +* List item + +Inline code: + +`` 1 + 2 `` + +` "doesn't typecheck" + 1 ` + +[Link](https://unison-lang.org) + +![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) + +Horizontal rule + +--- + +Video + +{{ +Special + (Embed + (Any (Video [MediaSource "test.mp4" None] [("poster", "test.png")]))) +}} + +Transclusion/evaluation: + +{{ otherDoc (a -> Word a) }} + +--- + +The following markdown features aren't supported by the Doc format yet, but maybe will someday + + +> Block quote + + +Table + +| Header 1 | Header 2 | +| -------- | -------- | +| Cell 1 | Cell 2 | + + + Indented Code block + +''' + Exact whitespace should be preserved across multiple updates. Don't mess with the logo! + + _____ _ + | | |___|_|___ ___ ___ + | | | | |_ -| . | | + |_____|_|_|_|___|___|_|_| + + Line with no whitespace: + + Should have one full trailing newline below here: + +''' + +Inline '' text literal with 1 space of padding '' in the middle of a sentence. + + +}} +``` + +Format it to check that everything pretty-prints in a valid way. + +``` ucm +scratch/main> debug.format +``` + +``` unison :added-by-ucm scratch.u +otherDoc : a -> Doc2 +otherDoc _ = {{ yo }} + +otherTerm : Nat +otherTerm = 99 + +fulldoc : Doc2 +fulldoc = + use Nat + + {{ + Heres some text with a soft line break + + hard line break + + Here's a cool **BOLD** __italic__ ~~strikethrough~~ thing with an inline code + block `1 + 2` + + Should print with appropriate fences for the contents: + + `No fancy quotes` + + '' There are `backticks` in here '' + + ''' There are `backticks` and ''quotes'' in here ''' + + # Heading + + ## Heading 2 + + Term Link: {otherTerm} + + Type Link: {type Optional} + + Term source: + + @source{term} + + Term signature: + + @signature{term} + + * List item + + Inline code: + + `` 1 + 2 `` + + ` "doesn't typecheck" + 1 ` + + [Link](https://unison-lang.org) + + ![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) + + Horizontal rule + + --- + + Video + + {{ + Special + (Embed + (Any (Video [MediaSource "test.mp4" None] [("poster", "test.png")]))) + }} + + Transclusion/evaluation: + + {{ otherDoc (a -> Word a) }} + + --- + + The following markdown features aren't supported by the Doc format yet, + but maybe will someday + + > Block quote + + Table + + | Header 1 | Header 2 | | -------- | -------- | | Cell 1 | Cell 2 | + + Indented Code block + + ''' + Exact whitespace should be preserved across multiple updates. Don't mess with the logo! + + _____ _ + | | |___|_|___ ___ ___ + | | | | |_ -| . | | + |_____|_|_|_|___|___|_|_| + + Line with no whitespace: + + Should have one full trailing newline below here: + + ''' + + Inline ` text literal with 1 space of padding ` in the middle of a + sentence. + }} +``` diff --git a/unison-src/transcripts/idempotent/doc2markdown.md b/unison-src/transcripts/idempotent/doc2markdown.md new file mode 100644 index 0000000000..a27711ec6a --- /dev/null +++ b/unison-src/transcripts/idempotent/doc2markdown.md @@ -0,0 +1,202 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison :hide +otherDoc : a -> Doc2 +otherDoc _ = {{ yo }} + +otherTerm : Nat +otherTerm = 99 + +fulldoc : Doc2 +fulldoc = + use Nat + + {{ +Heres some text with a +soft line break + +hard line break + +Here's a cool **BOLD** __italic__ ~~strikethrough~~ thing with an inline code block ''1 + 2'' + +# Heading + +## Heading 2 + +Term Link: {otherTerm} + +Type Link: {type Optional} + +Term source: + +@source{term} + +Term signature: + +@signature{term} + +* List item + +Inline code: + +`` 1 + 2 `` + +` "doesn't typecheck" + 1 ` + +[Link](https://unison-lang.org) + +![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) + +Horizontal rule + +--- + +Video + +{{ +Special + (Embed + (Any (Video [MediaSource "test.mp4" None] [("poster", "test.png")]))) +}} + +Transclusion/evaluation: + +{{ otherDoc (a -> Word a) }} + +--- + +The following markdown features aren't supported by the Doc format yet, but maybe will someday + + +> Block quote + + +Table + +| Header 1 | Header 2 | +| -------- | -------- | +| Cell 1 | Cell 2 | + + + Indented Code block + + +}} +``` + +``` ucm :hide +scratch/main> add +``` + +```` ucm +scratch/main> debug.doc-to-markdown fulldoc + + Heres some text with a soft line break + + hard line break + + Here's a cool **BOLD** _italic_ ~~strikethrough~~ thing with an inline code block `1 + 2` + + # Heading + + ## Heading 2 + + Term Link: `otherTerm` + + Type Link: `Optional` + + Term source: + + ```unison + term : '{g} a -> Doc2.Term + term a = Term.Term (Any a) + ``` + + + + Term signature: + + ```unison + term : '{g} a -> Doc2.Term + ``` + + + + - List item + + Inline code: + + `1 Nat.+ 2` + + ` "doesn't typecheck" + 1 ` + + [Link](https://unison-lang.org) + + ![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png) + + Horizontal rule + + --- + + Video + + ![](test.mp4) + + Transclusion/evaluation: + + yo + + + + --- + + The following markdown features aren't supported by the Doc format yet, but maybe will someday + + > Block quote + + Table + + | Header 1 | Header 2 | | -------- | -------- | | Cell 1 | Cell 2 | + + Indented Code block + + +```` + +You can add docs to a term or type with a top-level doc literal above the binding: + +``` unison +{{ This is a term doc }} +myTerm = 10 + +-- Regression tests for https://github.com/unisonweb/unison/issues/4634 +{{ This is a type doc }} +type MyType = MyType + +{{ This is a unique type doc }} +unique type MyUniqueType = MyUniqueType + +{{ This is a structural type doc }} +structural type MyStructuralType = MyStructuralType +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type MyStructuralType + (also named builtin.Unit) + type MyType + type MyUniqueType + MyStructuralType.doc : Doc2 + MyType.doc : Doc2 + MyUniqueType.doc : Doc2 + myTerm : Nat + myTerm.doc : Doc2 +``` diff --git a/unison-src/transcripts/idempotent/dont-upgrade-refs-that-exist-in-old.md b/unison-src/transcripts/idempotent/dont-upgrade-refs-that-exist-in-old.md new file mode 100644 index 0000000000..69f9032168 --- /dev/null +++ b/unison-src/transcripts/idempotent/dont-upgrade-refs-that-exist-in-old.md @@ -0,0 +1,50 @@ +If `foo#old` exists in old, and `foo#new` exists in new, you might think `upgrade old new` would rewrite references to +`#old` with references to `#new`. And it will... \!\!unless\!\! `#old` still exists in new. + +``` ucm :hide +foo/main> builtins.merge lib.builtin +``` + +``` unison +lib.old.foo = 18 +lib.new.other = 18 +lib.new.foo = 19 +mything = lib.old.foo + lib.old.foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.new.foo : Nat + lib.new.other : Nat + lib.old.foo : Nat + mything : Nat +``` + +``` ucm +foo/main> add + + ⍟ I've added these definitions: + + lib.new.foo : Nat + lib.new.other : Nat + lib.old.foo : Nat + mything : Nat + +foo/main> upgrade old new + + I upgraded old to new, and removed old. + +foo/main> view mything + + mything : Nat + mything = + use Nat + + other + other +``` diff --git a/unison-src/transcripts/idempotent/duplicate-names.md b/unison-src/transcripts/idempotent/duplicate-names.md new file mode 100644 index 0000000000..9ce9da638a --- /dev/null +++ b/unison-src/transcripts/idempotent/duplicate-names.md @@ -0,0 +1,137 @@ +# Duplicate names in scratch file. + +``` ucm :hide +scratch/main> builtins.merge +``` + +Term and ability constructor collisions should cause a parse error. + +``` unison :error +structural ability Stream where + send : a -> () + +Stream.send : a -> () +Stream.send _ = () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ❗️ + + I found multiple bindings with the name Stream.send: + 2 | send : a -> () + 3 | + 4 | Stream.send : a -> () + 5 | Stream.send _ = () +``` + +Term and type constructor collisions should cause a parse error. + +``` unison :error +structural type X = x + +X.x : a -> () +X.x _ = () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ❗️ + + I found multiple bindings with the name X.x: + 1 | structural type X = x + 2 | + 3 | X.x : a -> () + 4 | X.x _ = () +``` + +Ability and type constructor collisions should cause a parse error. + +``` unison :error +structural type X = x +structural ability X where + x : () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found multiple types with the name X: + + 1 | structural type X = x + 2 | structural ability X where + 3 | x : () +``` + +Field accessors and terms with the same name should cause a parse error. + +``` unison :error +structural type X = {x : ()} +X.x.modify = () +X.x.set = () +X.x = () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ❗️ + + I found multiple bindings with the name X.x: + 1 | structural type X = {x : ()} + 2 | X.x.modify = () + 3 | X.x.set = () + 4 | X.x = () + + + I found multiple bindings with the name X.x.modify: + 1 | structural type X = {x : ()} + 2 | X.x.modify = () + + + I found multiple bindings with the name X.x.set: + 1 | structural type X = {x : ()} + 2 | X.x.modify = () + 3 | X.x.set = () +``` + +Types and terms with the same name are allowed. + +``` unison +structural type X = Z + +X = () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type X + (also named builtin.Unit) + X : () +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type X + (also named builtin.Unit) + X : () + +scratch/main> view X + + structural type X = Z + + X : () + X = () +``` diff --git a/unison-src/transcripts/idempotent/duplicate-term-detection.md b/unison-src/transcripts/idempotent/duplicate-term-detection.md new file mode 100644 index 0000000000..0115bf71a1 --- /dev/null +++ b/unison-src/transcripts/idempotent/duplicate-term-detection.md @@ -0,0 +1,101 @@ +# Duplicate Term Detection + +``` ucm :hide +scratch/main> builtins.merge +``` + +Trivial duplicate terms should be detected: + +``` unison :error +x = 1 +x = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ❗️ + + I found multiple bindings with the name x: + 1 | x = 1 + 2 | x = 2 +``` + +Equivalent duplicate terms should be detected: + +``` unison :error +x = 1 +x = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ❗️ + + I found multiple bindings with the name x: + 1 | x = 1 + 2 | x = 1 +``` + +Duplicates from record accessors/setters should be detected + +``` unison :error +structural type Record = {x: Nat, y: Nat} +Record.x = 1 +Record.x.set = 2 +Record.x.modify = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ❗️ + + I found multiple bindings with the name Record.x: + 1 | structural type Record = {x: Nat, y: Nat} + 2 | Record.x = 1 + + + I found multiple bindings with the name Record.x.modify: + 1 | structural type Record = {x: Nat, y: Nat} + 2 | Record.x = 1 + 3 | Record.x.set = 2 + 4 | Record.x.modify = 2 + + + I found multiple bindings with the name Record.x.set: + 1 | structural type Record = {x: Nat, y: Nat} + 2 | Record.x = 1 + 3 | Record.x.set = 2 +``` + +Duplicate terms and constructors should be detected: + +``` unison :error +structural type SumType = X + +SumType.X = 1 + +structural ability AnAbility where + thing : Nat -> () + +AnAbility.thing = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ❗️ + + I found multiple bindings with the name AnAbility.thing: + 6 | thing : Nat -> () + 7 | + 8 | AnAbility.thing = 2 + + + I found multiple bindings with the name SumType.X: + 1 | structural type SumType = X + 2 | + 3 | SumType.X = 1 +``` diff --git a/unison-src/transcripts/idempotent/ed25519.md b/unison-src/transcripts/idempotent/ed25519.md new file mode 100644 index 0000000000..31311d9132 --- /dev/null +++ b/unison-src/transcripts/idempotent/ed25519.md @@ -0,0 +1,55 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison + +up = 0xs0123456789abcdef +down = 0xsfedcba9876543210 + +secret = 0xs3885da624f4430c01326d96764da85647d403dae1fcdc9856c51037f9c647032 + +public = 0xsb14dbcf139c0e73d942a184b419e4f4fab726102bfe2b65c060b113bb379c77c + + +message = up ++ down ++ up ++ down ++ down ++ up ++ down ++ up + +signature = crypto.Ed25519.sign.impl secret public message + +sigOkay = match signature with + Left err -> Left err + Right sg -> crypto.Ed25519.verify.impl public message sg + +> signature +> sigOkay +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + down : Bytes + message : Bytes + public : Bytes + secret : Bytes + sigOkay : Either Failure Boolean + signature : Either Failure Bytes + up : Bytes + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 18 | > signature + ⧩ + Right + 0xs0b76988ce7e5147d36597d2a526ec7b8e178b3ae29083598c33c9fbcdf0f84b4ff2f8c5409123dd9a0c54447861c07e21296500a98540f5d5f15d927eaa6d30a + + 19 | > sigOkay + ⧩ + Right true +``` diff --git a/unison-src/transcripts/idempotent/edit-command.md b/unison-src/transcripts/idempotent/edit-command.md new file mode 100644 index 0000000000..1017033416 --- /dev/null +++ b/unison-src/transcripts/idempotent/edit-command.md @@ -0,0 +1,156 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +foo = 123 + +bar = 456 + +mytest = [Ok "ok"] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + foo : Nat + mytest : [Result] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat + mytest : [Result] + +scratch/main> edit.new foo bar + + ☝️ + + I added 2 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. + +scratch/main> edit.new mytest + + ☝️ + + I added 1 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. +``` + +``` unison :added-by-ucm scratch.u +bar : Nat +bar = 456 + +foo : Nat +foo = 123 +``` + +``` unison :added-by-ucm scratch.u +test> mytest = [Ok "ok"] +``` + +``` ucm :error +scratch/main> edit.new missing + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + missing +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + +# `edit` + +The `edit` command adds to the current fold, and takes care not to add definitions that are already in the file. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtin +``` + +This stanza does nothing for some reason (transcript runner bug?), so we repeat it twice. + +``` unison +foo = 17 +bar = 18 +baz = 19 +``` + +``` unison +foo = 17 +bar = 18 +baz = 19 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + baz : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + baz : Nat + foo : Nat +``` + +``` unison +foo = 17 +bar = 18 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked the definitions in scratch.u. This + file has been previously added to the codebase. +``` + +``` ucm +scratch/main> edit bar baz + + ☝️ + + I added 1 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. +``` + +``` unison :added-by-ucm scratch.u +baz : Nat +baz = 19 +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` diff --git a/unison-src/transcripts/idempotent/edit-dependents-command.md b/unison-src/transcripts/idempotent/edit-dependents-command.md new file mode 100644 index 0000000000..736197fb19 --- /dev/null +++ b/unison-src/transcripts/idempotent/edit-dependents-command.md @@ -0,0 +1,97 @@ +# `edit.dependents` + +The `edit.dependents` command is like `edit`, but it adds a definition and all of its transitive dependents to the file +(being careful not to add anything that's already there). + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtin +``` + +``` unison +type Foo = Foo Nat Nat +type Bar = { bar : Foo } + +baz : Bar -> Bar +baz x = x +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Bar + type Foo + Bar.bar : Bar -> Foo + Bar.bar.modify : (Foo ->{g} Foo) -> Bar ->{g} Bar + Bar.bar.set : Foo -> Bar -> Bar + baz : Bar -> Bar +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Bar + type Foo + Bar.bar : Bar -> Foo + Bar.bar.modify : (Foo ->{g} Foo) -> Bar ->{g} Bar + Bar.bar.set : Foo -> Bar -> Bar + baz : Bar -> Bar +``` + +Let's populate our scratch file with `Bar` (and its auto-generated accessors), then `edit.dependents` its dependency +`Foo`, which should add `Foo` and `baz`. + +``` unison +type Bar = { bar : Nat } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Bar + Bar.bar : Bar -> Nat + Bar.bar.modify : (Nat ->{g} Nat) -> Bar ->{g} Bar + Bar.bar.set : Nat -> Bar -> Bar +``` + +``` ucm +scratch/main> edit.dependents Foo + + Loading branch... + + Identifying dependents... + + Loading dependents... + + ☝️ + + I added 2 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. +``` + +``` unison :added-by-ucm scratch.u +type Foo = Foo Nat Nat + +baz : Bar -> Bar +baz x = x +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` diff --git a/unison-src/transcripts/idempotent/edit-namespace.md b/unison-src/transcripts/idempotent/edit-namespace.md new file mode 100644 index 0000000000..3e540bb147 --- /dev/null +++ b/unison-src/transcripts/idempotent/edit-namespace.md @@ -0,0 +1,149 @@ +``` ucm :hide +project/main> builtins.mergeio lib.builtin +``` + +``` unison +{{ ping doc }} +nested.cycle.ping n = n Nat.+ pong n + +{{ pong doc }} +nested.cycle.pong n = n Nat.+ ping n + +toplevel = "hi" + +simple.x = 10 +simple.y = 20 + +-- Shouldn't edit things in lib +lib.project.ignoreMe = 30 + +-- Shouldn't render record accessors +unique type Foo = { bar : Nat, baz : Nat } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + Foo.bar : Foo -> Nat + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.bar.set : Nat -> Foo -> Foo + Foo.baz : Foo -> Nat + Foo.baz.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.baz.set : Nat -> Foo -> Foo + lib.project.ignoreMe : Nat + nested.cycle.ping : Nat -> Nat + nested.cycle.ping.doc : Doc2 + nested.cycle.pong : Nat -> Nat + nested.cycle.pong.doc : Doc2 + simple.x : Nat + simple.y : Nat + toplevel : Text +``` + +``` ucm +project/main> add + + ⍟ I've added these definitions: + + type Foo + Foo.bar : Foo -> Nat + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.bar.set : Nat -> Foo -> Foo + Foo.baz : Foo -> Nat + Foo.baz.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.baz.set : Nat -> Foo -> Foo + lib.project.ignoreMe : Nat + nested.cycle.ping : Nat -> Nat + nested.cycle.ping.doc : Doc2 + nested.cycle.pong : Nat -> Nat + nested.cycle.pong.doc : Doc2 + simple.x : Nat + simple.y : Nat + toplevel : Text +``` + +`edit.namespace` edits the whole namespace (minus the top-level `lib`). + +``` ucm +project/main> edit.namespace + + ☝️ + + I added 8 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. +``` + +``` unison :added-by-ucm scratch.u +type Foo = { bar : Nat, baz : Nat } + +nested.cycle.ping : Nat -> Nat +nested.cycle.ping n = + use Nat + + n + nested.cycle.pong n + +nested.cycle.ping.doc : Doc2 +nested.cycle.ping.doc = {{ ping doc }} + +nested.cycle.pong : Nat -> Nat +nested.cycle.pong n = + use Nat + + n + nested.cycle.ping n + +nested.cycle.pong.doc : Doc2 +nested.cycle.pong.doc = {{ pong doc }} + +simple.x : Nat +simple.x = 10 + +simple.y : Nat +simple.y = 20 + +toplevel : Text +toplevel = "hi" +``` + +`edit.namespace` can also accept explicit paths + +``` ucm +project/main> edit.namespace nested simple + + ☝️ + + I added 6 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. +``` + +``` unison :added-by-ucm scratch.u +nested.cycle.ping : Nat -> Nat +nested.cycle.ping n = + use Nat + + n + nested.cycle.pong n + +nested.cycle.ping.doc : Doc2 +nested.cycle.ping.doc = {{ ping doc }} + +nested.cycle.pong : Nat -> Nat +nested.cycle.pong n = + use Nat + + n + nested.cycle.ping n + +nested.cycle.pong.doc : Doc2 +nested.cycle.pong.doc = {{ pong doc }} + +simple.x : Nat +simple.x = 10 + +simple.y : Nat +simple.y = 20 +``` diff --git a/unison-src/transcripts/idempotent/empty-namespaces.md b/unison-src/transcripts/idempotent/empty-namespaces.md new file mode 100644 index 0000000000..680629e332 --- /dev/null +++ b/unison-src/transcripts/idempotent/empty-namespaces.md @@ -0,0 +1,155 @@ +# Empty namespace behaviours + +``` unison :hide +mynamespace.x = 1 +``` + +``` ucm :hide +scratch/main> add + +scratch/main> delete.namespace mynamespace +``` + +The deleted namespace shouldn't appear in `ls` output. + +``` ucm :error +scratch/main> ls + + nothing to show +``` + +``` ucm :error +scratch/main> find.verbose + + ☝️ + + I couldn't find matches in this namespace, searching in + 'lib'... + + 😶 + + No results. Check your spelling, or try using tab completion + to supply command arguments. + + `debug.find.global` can be used to search outside the current + namespace. +``` + +``` ucm :error +scratch/main> find mynamespace + + ☝️ + + I couldn't find matches in this namespace, searching in + 'lib'... + + 😶 + + No results. Check your spelling, or try using tab completion + to supply command arguments. + + `debug.find.global` can be used to search outside the current + namespace. +``` + +## history + +The history of the namespace should be empty. + +``` ucm +scratch/main> history mynamespace + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #sg60bvjo91 (start of history) +``` + +Add and then delete a term to add some history to a deleted namespace. + +``` unison :hide +deleted.x = 1 +stuff.thing = 2 +``` + +``` ucm :hide +scratch/main> add + +scratch/main> delete.namespace deleted +``` + +## fork + +I should be allowed to fork over a deleted namespace + +``` ucm +scratch/main> fork stuff deleted + + Done. +``` + +The history from the `deleted` namespace should have been overwritten by the history from `stuff`. + +``` ucm +scratch/main> history stuff + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #q2dq4tsno1 (start of history) + +scratch/main> history deleted + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #q2dq4tsno1 (start of history) +``` + +## move.namespace + +``` unison :hide +moveoverme.x = 1 +moveme.y = 2 +``` + +``` ucm :hide +scratch/main> add +``` + +I should be able to move a namespace over-top of a deleted namespace. +The history should be that of the moved namespace. + +``` ucm +scratch/main> delete.namespace moveoverme + + Done. + +scratch/main> history moveme + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #c5uisu4kll (start of history) + +scratch/main> move.namespace moveme moveoverme + + Done. + +scratch/main> history moveoverme + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #c5uisu4kll (start of history) +``` diff --git a/unison-src/transcripts/idempotent/emptyCodebase.md b/unison-src/transcripts/idempotent/emptyCodebase.md new file mode 100644 index 0000000000..3b2c7090e1 --- /dev/null +++ b/unison-src/transcripts/idempotent/emptyCodebase.md @@ -0,0 +1,40 @@ +# The empty codebase + +The Unison codebase, when first initialized, contains no definitions in its namespace. + +Not even `Nat` or `+`\! + +BEHOLD\!\!\! + +``` ucm :error +scratch/main> ls + + nothing to show +``` + +Technically, the definitions all exist, but they have no names. `builtins.merge` brings them into existence, under the current namespace: + +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. + +scratch/main> ls lib + + 1. builtins/ (469 terms, 74 types) +``` + +And for a limited time, you can get even more builtin goodies: + +``` ucm +scratch/main> builtins.mergeio lib.builtinsio + + Done. + +scratch/main> ls lib + + 1. builtins/ (469 terms, 74 types) + 2. builtinsio/ (643 terms, 92 types) +``` + +More typically, you'd start out by pulling `base`. diff --git a/unison-src/transcripts/idempotent/error-messages.md b/unison-src/transcripts/idempotent/error-messages.md new file mode 100644 index 0000000000..27d45287c1 --- /dev/null +++ b/unison-src/transcripts/idempotent/error-messages.md @@ -0,0 +1,370 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +This file contains programs with parse errors and type errors, for visual inspection of error message quality and to check for regressions or changes to error reporting. + +## Parse errors + +Some basic errors of literals. + +### Floating point literals + +``` unison :error +x = 1. -- missing some digits after the decimal +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This number isn't valid syntax: + + 1 | x = 1. -- missing some digits after the decimal + + I was expecting some digits after the `.` , for example: `1.0` + or `1.1e37`. +``` + +``` unison :error +x = 1e -- missing an exponent +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This number isn't valid syntax: + + 1 | x = 1e -- missing an exponent + + I was expecting some digits for the exponent, for example: + `1e37`. +``` + +``` unison :error +x = 1e- -- missing an exponent +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This number isn't valid syntax: + + 1 | x = 1e- -- missing an exponent + + I was expecting some digits for the exponent, for example: + `1e-37`. +``` + +``` unison :error +x = 1E+ -- missing an exponent +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This number isn't valid syntax: + + 1 | x = 1E+ -- missing an exponent + + I was expecting some digits for the exponent, for example: + `1e+37`. +``` + +### Hex, octal, binary, and bytes literals + +``` unison :error +x = 0xoogabooga -- invalid hex chars +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This number isn't valid syntax: + + 1 | x = 0xoogabooga -- invalid hex chars + + I was expecting only hexidecimal characters (one of + 0123456789abcdefABCDEF) after the 0x. +``` + +``` unison :error +x = 0o987654321 -- 9 and 8 are not valid octal char +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This number isn't valid syntax: + + 1 | x = 0o987654321 -- 9 and 8 are not valid octal char + + I was expecting only octal characters (one of 01234567) after + the 0o. +``` + +``` unison :error +x = 0b3201 -- 3 and 2 are not valid binary chars +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This number isn't valid syntax: + + 1 | x = 0b3201 -- 3 and 2 are not valid binary chars + + I was expecting only binary characters (one of 01) after the + 0b. +``` + +``` unison :error +x = 0xsf -- odd number of hex chars in a bytes literal +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This bytes literal isn't valid syntax: 0xsf + + 1 | x = 0xsf -- odd number of hex chars in a bytes literal + + I was expecting an even number of hexidecimal characters (one + of 0123456789abcdefABCDEF) after the 0xs. +``` + +``` unison :error +x = 0xsnotvalidhexchars -- invalid hex chars in a bytes literal +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This bytes literal isn't valid syntax: 0xsnotvalidhexchars + + 1 | x = 0xsnotvalidhexchars -- invalid hex chars in a bytes literal + + I was expecting an even number of hexidecimal characters (one + of 0123456789abcdefABCDEF) after the 0xs. +``` + +### Layout errors + +``` unison :error +foo = else -- not matching if +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found a closing 'else' here without a matching 'then'. + + 1 | foo = else -- not matching if +``` + +``` unison :error +foo = then -- unclosed +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found a closing 'then' here without a matching 'if'. + + 1 | foo = then -- unclosed +``` + +``` unison :error +foo = with -- unclosed +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found a closing 'with' here without a matching 'handle' or 'match'. + + 1 | foo = with -- unclosed +``` + +### Matching + +``` unison :error +-- No cases +foo = match 1 with +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | foo = match 1 with + + + Patterns not matched: + * _ +``` + +``` unison :error +foo = match 1 with + 2 -- no right-hand-side +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 3 | + + I was surprised to find an end of section here. + I was expecting one of these instead: + + * "," + * case match + * pattern guard +``` + +``` unison :error +-- Mismatched arities +foo = cases + 1, 2 -> () + 3 -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + 😶 + + Not all the branches of this pattern matching have the same + number of arguments. I was assuming they'd all have 2 + arguments (based on the previous patterns) but this one has + 1 arguments: + 4 | 3 -> () + +``` + +``` unison :error +-- Missing a '->' +x = match Some a with + None -> + 1 + Some _ + 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 7 | + + I was surprised to find an end of section here. + I was expecting one of these instead: + + * "," + * blank + * case match + * false + * pattern guard + * true +``` + +``` unison :error +-- Missing patterns +x = match Some a with + None -> 1 + -> 2 + -> 3 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 4 | -> 2 + + + I was surprised to find a -> here. + I was expecting one of these instead: + + * end of input + * newline or semicolon +``` + +``` unison :error +-- Guards following an unguarded case +x = match Some a with + None -> 1 + | true -> 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 4 | | true -> 2 + + + I was surprised to find a '|' here. + I was expecting one of these instead: + + * end of input + * newline or semicolon +``` + +### Watches + +``` unison :error +-- Empty watch +> +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I expected a non-empty watch expression and not just ">" + + 2 | > +``` + +### Keywords + +``` unison :error +use.keyword.in.namespace = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + The identifier `namespace` used here is a reserved keyword: + + 1 | use.keyword.in.namespace = 1 + + You can avoid this problem either by renaming the identifier + or wrapping it in backticks (like `namespace` ). +``` + +``` unison :error +-- reserved operator +a ! b = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This looks like the start of an expression here + + 2 | a ! b = 1 + + but at the file top-level, I expect one of the following: + + - A binding, like a = 42 OR + a : Nat + a = 42 + - A watch expression, like > a + 1 + - An `ability` declaration, like unique ability Foo where ... + - A `type` declaration, like structural type Optional a = None | Some a +``` diff --git a/unison-src/transcripts/idempotent/escape-sequences.md b/unison-src/transcripts/idempotent/escape-sequences.md new file mode 100644 index 0000000000..463d97e117 --- /dev/null +++ b/unison-src/transcripts/idempotent/escape-sequences.md @@ -0,0 +1,28 @@ +``` unison +> "Rúnar" +> "῎Ανδρα μοι ἔννεπε, Μοῦσα, πολύτροπον" +> "古池や蛙飛びこむ水の音" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > "Rúnar" + ⧩ + "Rúnar" + + 2 | > "῎Ανδρα μοι ἔννεπε, Μοῦσα, πολύτροπον" + ⧩ + "῎Ανδρα μοι ἔννεπε, Μοῦσα, πολύτροπον" + + 3 | > "古池や蛙飛びこむ水の音" + ⧩ + "古池や蛙飛びこむ水の音" +``` diff --git a/unison-src/transcripts/idempotent/find-by-type.md b/unison-src/transcripts/idempotent/find-by-type.md new file mode 100644 index 0000000000..286b85c633 --- /dev/null +++ b/unison-src/transcripts/idempotent/find-by-type.md @@ -0,0 +1,54 @@ +``` ucm :hide +scratch/main> alias.type ##Text builtin.Text +``` + +``` unison :hide +unique type A = A Text + +foo : A +foo = A "foo!" + +bar : Text -> A +bar = A + +baz : A -> Text +baz = cases + A t -> t +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type A + bar : Text -> A + baz : A -> Text + foo : A + +scratch/main> find : Text -> A + + 1. bar : Text -> A + 2. A.A : Text -> A + +scratch/main> find : A -> Text + + 1. baz : A -> Text + +scratch/main> find : A + + 1. foo : A +``` + +``` ucm :error +scratch/main> find : Text + + ☝️ + + I couldn't find exact type matches, resorting to fuzzy + matching... + + 1. baz : A -> Text + 2. bar : Text -> A + 3. A.A : Text -> A +``` diff --git a/unison-src/transcripts/idempotent/find-command.md b/unison-src/transcripts/idempotent/find-command.md new file mode 100644 index 0000000000..efe319c58a --- /dev/null +++ b/unison-src/transcripts/idempotent/find-command.md @@ -0,0 +1,99 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison :hide +foo = 1 +lib.foo = 2 +lib.bar = 3 +cat.foo = 4 +cat.lib.foo = 5 +cat.lib.bar = 6 +somewhere.bar = 7 +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> find foo + + 1. cat.foo : Nat + 2. foo : Nat + +scratch/main> view 1 + + cat.foo : Nat + cat.foo = 4 + +scratch/main> find.all foo + + 1. cat.foo : Nat + 2. cat.lib.foo : Nat + 3. lib.foo : Nat + 4. foo : Nat + +scratch/main> view 1 + + cat.foo : Nat + cat.foo = 4 +``` + +``` ucm +scratch/main> find-in cat foo + + 1. foo : Nat + +scratch/main> view 1 + + cat.foo : Nat + cat.foo = 4 + +scratch/main> find-in.all cat foo + + 1. lib.foo : Nat + 2. foo : Nat + +scratch/main> view 1 + + cat.lib.foo : Nat + cat.lib.foo = 5 +``` + +Finding within a namespace + +``` ucm +scratch/main> find bar + + 1. somewhere.bar : Nat + +scratch/other> debug.find.global bar + + Found results in scratch/main + + 1. .cat.lib.bar : Nat + 2. .lib.bar : Nat + 3. .somewhere.bar : Nat + +scratch/main> find-in somewhere bar + + 1. bar : Nat +``` + +``` ucm :error +scratch/main> find baz + + ☝️ + + I couldn't find matches in this namespace, searching in + 'lib'... + + 😶 + + No results. Check your spelling, or try using tab completion + to supply command arguments. + + `debug.find.global` can be used to search outside the current + namespace. +``` diff --git a/unison-src/transcripts/idempotent/fix-1381-excess-propagate.md b/unison-src/transcripts/idempotent/fix-1381-excess-propagate.md new file mode 100644 index 0000000000..b724b01f05 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-1381-excess-propagate.md @@ -0,0 +1,55 @@ +We were seeing an issue where (it seemed) that every namespace that was visited during a propagate would get a new history node, even when it didn't contain any dependents. + +Example: + +``` unison :hide +a = "a term" +X.foo = "a namespace" +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + X.foo : ##Text + a : ##Text +``` + +Here is an update which should not affect `X`: + +``` unison :hide +a = "an update" +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +As of the time of this writing, the history for `X` should be a single node, `#4eeuo5bsfr`; + +``` ucm +scratch/main> history X + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #das1se4g2i (start of history) +``` + +however, as of release/M1i, we saw an extraneous node appear. If your `ucm` is fixed, you won't see it below: + +``` ucm :error +scratch/main> history #7nl6ppokhg + + 😶 + + I don't know of a namespace with that hash. +``` diff --git a/unison-src/transcripts/fix-2258-if-as-list-element.md b/unison-src/transcripts/idempotent/fix-2258-if-as-list-element.md similarity index 92% rename from unison-src/transcripts/fix-2258-if-as-list-element.md rename to unison-src/transcripts/idempotent/fix-2258-if-as-list-element.md index fbf9cc93dd..32224c32e3 100644 --- a/unison-src/transcripts/fix-2258-if-as-list-element.md +++ b/unison-src/transcripts/idempotent/fix-2258-if-as-list-element.md @@ -1,10 +1,10 @@ Tests that `if` statements can appear as list and tuple elements. -```ucm:hide -.> builtins.merge +``` ucm :hide +scratch/main> builtins.merge ``` -```unison:hide +``` unison :hide > [ if true then 1 else 0 ] > [ if true then 1 else 0, 1] @@ -63,4 +63,3 @@ fst = cases (x,_) -> x cases x, y -> x Nat.+ y ] ``` - diff --git a/unison-src/transcripts/idempotent/fix-5267.md b/unison-src/transcripts/idempotent/fix-5267.md new file mode 100644 index 0000000000..22cfd2bd71 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5267.md @@ -0,0 +1,82 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +lib.direct.foo = 17 +lib.direct.lib.indirect.foo = 18 + +bar : Nat +bar = direct.foo + direct.foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + lib.direct.foo : Nat + lib.direct.lib.indirect.foo : Nat +``` + +Here, `bar` renders as `foo + foo`, even though there are two names with suffix `foo` in scope, because one is an +indirect dependency. It used to render as `direct.foo + direct.foo`. + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + lib.direct.foo : Nat + lib.direct.lib.indirect.foo : Nat + +scratch/main> view bar + + bar : Nat + bar = + use Nat + + foo + foo +``` + +Same test, but for types. + +``` unison +type lib.direct.Foo = MkFoo +type lib.direct.lib.indirect.Foo = MkFoo + +type Bar = MkBar direct.Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Bar + type lib.direct.Foo + type lib.direct.lib.indirect.Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Bar + type lib.direct.Foo + type lib.direct.lib.indirect.Foo + +scratch/main> view Bar + + type Bar = MkBar Foo +``` diff --git a/unison-src/transcripts/idempotent/fix-5301.md b/unison-src/transcripts/idempotent/fix-5301.md new file mode 100644 index 0000000000..4e6621cb46 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5301.md @@ -0,0 +1,59 @@ +This transcripts demonstrates that pattern matching on a "constructor" (defined as a variable that begins with a capital +letter) that is either not found or ambiguouus fails. Previously, it would be treated as a variable binding. + +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison :error +type Foo = Bar Nat + +foo : Foo -> Nat +foo = cases + Bar X -> 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + ❓ + + I couldn't resolve any of these symbols: + + 5 | Bar X -> 5 + + + Symbol Suggestions + + X No matches +``` + +``` unison :error +type Foo = Bar A +type A = X +type B = X + +foo : Foo -> Nat +foo = cases + Bar X -> 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + ❓ + + I couldn't resolve any of these symbols: + + 7 | Bar X -> 5 + + + Symbol Suggestions + + X A.X + B.X +``` diff --git a/unison-src/transcripts/idempotent/fix-5312.md b/unison-src/transcripts/idempotent/fix-5312.md new file mode 100644 index 0000000000..870083dcad --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5312.md @@ -0,0 +1,73 @@ +This transcript demonstrates that dependents of an update are suffixified properly. Previously, `c = b.y + 1` would +render as `c = y + 1` (ambiguous). + +``` ucm +scratch/main> builtins.merge lib.builtin + + Done. +``` + +``` unison +x = 17 + +a.y = 18 +b.y = x + 1 + +c = b.y + 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + a.y : Nat + b.y : Nat + c : Nat + x : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + a.y : Nat + b.y : Nat + c : Nat + x : Nat +``` + +``` unison +x = 100 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + x : Nat +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. +``` diff --git a/unison-src/transcripts/idempotent/fix-5320.md b/unison-src/transcripts/idempotent/fix-5320.md new file mode 100644 index 0000000000..229cab0c43 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5320.md @@ -0,0 +1,26 @@ +``` ucm +scratch/main> builtins.merge lib.builtin + + Done. +``` + +``` unison :error +foo = cases + bar.Baz -> 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + ❓ + + I couldn't resolve any of these symbols: + + 2 | bar.Baz -> 5 + + + Symbol Suggestions + + bar.Baz No matches +``` diff --git a/unison-src/transcripts/idempotent/fix-5323.md b/unison-src/transcripts/idempotent/fix-5323.md new file mode 100644 index 0000000000..7c658afc5a --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5323.md @@ -0,0 +1,52 @@ +This transcript demonstrates that dependents of an upgrade are suffixified properly. Previously, `c = b.y + 1` would +render as `c = y + 1` (ambiguous). + +``` ucm +scratch/main> builtins.merge lib.builtin + + Done. +``` + +``` unison +lib.old.x = 17 +lib.new.x = 100 + +a.y = 18 +b.y = lib.old.x + 1 + +c = b.y + 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + a.y : Nat + b.y : Nat + c : Nat + lib.new.x : Nat + lib.old.x : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + a.y : Nat + b.y : Nat + c : Nat + lib.new.x : Nat + lib.old.x : Nat +``` + +``` ucm +scratch/main> upgrade old new + + I upgraded old to new, and removed old. +``` diff --git a/unison-src/transcripts/idempotent/fix-5326.md b/unison-src/transcripts/idempotent/fix-5326.md new file mode 100644 index 0000000000..267648cb4c --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5326.md @@ -0,0 +1,242 @@ +``` ucm +scratch/main> builtins.merge lib.builtin + + Done. +``` + +``` unison +x = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + x : Nat +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> branch foo + + Done. I've created the foo branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /foo`. +``` + +``` +main, foo +| +A +``` + +``` unison +x = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + x : Nat +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> branch bar + + Done. I've created the bar branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /bar`. +``` + +``` +main, bar +| +| foo +| | +B - A +``` + +``` unison +x = 3 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + x : Nat +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +``` +main +| +| bar foo +| | | +C - B - A +``` + +``` unison +x = 4 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + x : Nat +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +``` +main +| +| bar foo +| | | +D - C - B - A +``` + +``` unison +y = 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + y : Nat +``` + +``` ucm +scratch/foo> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +``` +main +| +| bar +| | +D - C - B - A + / + E + | + foo +``` + +``` ucm +scratch/main> merge /foo + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I merged scratch/foo into scratch/main. +``` + +``` +main +| +| bar +| | +F - D - C - B - A + \ / + ----------- E + | + foo +``` + +``` ucm +scratch/main> merge /bar + + 😶 + + scratch/main was already up-to-date with scratch/bar. +``` + +This should be a fast-forward, but we used to get this shape instead (which fails due to conflicts), because we +incorrectly computed `LCA(main, bar)` as `A`, not `B`. + +``` +main +| +| ------------ bar +| / \| +G - F - D - C - B - A + \ / + ----------- E + | + foo +``` diff --git a/unison-src/transcripts/idempotent/fix-5340.md b/unison-src/transcripts/idempotent/fix-5340.md new file mode 100644 index 0000000000..1e13d6c1c0 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5340.md @@ -0,0 +1,78 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +type my.Foo = MkFoo +type lib.dep.lib.dep.Foo = MkFoo + +my.foo = 17 +lib.dep.lib.dep.foo = 18 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type lib.dep.lib.dep.Foo + type my.Foo + lib.dep.lib.dep.foo : Nat + my.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type lib.dep.lib.dep.Foo + type my.Foo + lib.dep.lib.dep.foo : Nat + my.foo : Nat +``` + +These references to type `Foo` and term `foo` are unambiguous (resolving to the `my.Foo` and `my.foo` in the +file), even though indirect dependencies `lib.dep.lib.dep.Foo` and `lib.dep.lib.dep.foo` match by suffix. + +``` unison +type my.Foo = MkFoo +type Bar = MkBar Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⊡ Previously added definitions will be ignored: my.Foo + + ⍟ These new definitions are ok to `add`: + + type Bar +``` + +``` unison +my.foo = 17 +bar = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⊡ Previously added definitions will be ignored: my.foo + + ⍟ These new definitions are ok to `add`: + + bar : Nat +``` diff --git a/unison-src/transcripts/idempotent/fix-5354.md b/unison-src/transcripts/idempotent/fix-5354.md new file mode 100644 index 0000000000..84de08b65f --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5354.md @@ -0,0 +1,45 @@ +``` ucm +scratch/main> builtins.mergeio + + Done. +``` + +``` unison :error +> todo "" + +foo = 42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 💔💥 + + I've encountered a call to builtin.todo with the following + value: + + "" + + Stack trace: + todo + #0k89ebstt4 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : Nat +``` diff --git a/unison-src/transcripts/idempotent/fix-5357.md b/unison-src/transcripts/idempotent/fix-5357.md new file mode 100644 index 0000000000..08bbb58500 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5357.md @@ -0,0 +1,85 @@ +``` unison +util.ignore : a -> () +util.ignore _ = () + +foo : () +foo = + ignore 3 + ignore 4 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : () + util.ignore : a -> () +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : () + util.ignore : a -> () +``` + +``` unison +lib.base.ignore : a -> () +lib.base.ignore _ = () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.base.ignore : a -> () + (also named util.ignore) +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lib.base.ignore : a -> () + (also named util.ignore) + +scratch/main> edit.namespace + + ☝️ + + I added 2 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. + +scratch/main> load + + Loading changes detected in scratch.u. + + I found and typechecked the definitions in scratch.u. This + file has been previously added to the codebase. +``` + +``` unison :added-by-ucm scratch.u +foo : () +foo = + use util ignore + ignore 3 + ignore 4 + +util.ignore : a -> () +util.ignore _ = () +``` diff --git a/unison-src/transcripts/idempotent/fix-5369.md b/unison-src/transcripts/idempotent/fix-5369.md new file mode 100644 index 0000000000..d947810f51 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5369.md @@ -0,0 +1,60 @@ +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +one.foo : Nat +one.foo = 17 + +two.foo : Text +two.foo = "blah" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + one.foo : Nat + two.foo : Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + one.foo : Nat + two.foo : Text +``` + +``` unison +one.foo : Nat +one.foo = 18 + +bar : Nat +bar = foo + foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + one.foo : Nat +``` diff --git a/unison-src/transcripts/idempotent/fix-5374.md b/unison-src/transcripts/idempotent/fix-5374.md new file mode 100644 index 0000000000..6cd2957351 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5374.md @@ -0,0 +1,59 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +lib.direct.foo = 17 +lib.direct.lib.indirect.foo = 18 + +thing = indirect.foo + indirect.foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.direct.foo : Nat + lib.direct.lib.indirect.foo : Nat + thing : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lib.direct.foo : Nat + lib.direct.lib.indirect.foo : Nat + thing : Nat + +scratch/main> view thing + + thing : Nat + thing = + use Nat + + use indirect foo + foo + foo + +scratch/main> edit.new thing + + ☝️ + + I added 1 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. +``` + +``` unison :added-by-ucm scratch.u +thing : Nat +thing = + use Nat + + use indirect foo + foo + foo +``` diff --git a/unison-src/transcripts/idempotent/fix-5380.md b/unison-src/transcripts/idempotent/fix-5380.md new file mode 100644 index 0000000000..b9d1329db3 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5380.md @@ -0,0 +1,51 @@ +``` ucm +scratch/main> builtins.merge lib.builtin + + Done. +``` + +``` unison +foo : Nat +foo = 17 + +bar : Nat +bar = + qux : Nat + qux = 18 + foo + qux +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat + +scratch/main> move.term foo qux + + Done. + +scratch/main> view bar + + bar : Nat + bar = + use Nat + + qux : Nat + qux = 18 + .qux + qux +``` diff --git a/unison-src/transcripts/idempotent/fix-5402.md b/unison-src/transcripts/idempotent/fix-5402.md new file mode 100644 index 0000000000..a52e697869 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5402.md @@ -0,0 +1,37 @@ +`namespace` + top level `use` should work. Previously, they didn't. + +``` unison +namespace foo +use bar baz +x = 10 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo.x : ##Nat +``` + +``` unison +use bar baz +namespace foo +x = 10 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo.x : ##Nat +``` diff --git a/unison-src/transcripts/idempotent/fix-5427.md b/unison-src/transcripts/idempotent/fix-5427.md new file mode 100644 index 0000000000..f403f10d04 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5427.md @@ -0,0 +1,145 @@ +# Issue 1 + +``` ucm +scratch/main> builtins.merge lib.builtin + + Done. +``` + +``` unison +foo : Nat +foo = 17 + +bar : Nat +bar = + foo _ = + _ = foo + .foo + foo() +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat + +scratch/main> view bar + + bar : Nat + bar = + foo _ = + _ = foo + .foo + foo() +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +# Issue 2 + +``` ucm +scratch/main> builtins.merge lib.builtin + + Done. +``` + +``` unison +foo : Nat +foo = 17 + +bar : Nat +bar = + foo = .foo + foo + +baz : Nat +baz = foo + foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + baz : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + baz : Nat + foo : Nat +``` + +``` unison +foo : Nat +foo = 18 + +bar : Nat +bar = + foo = .foo + foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + bar : Nat + foo : Nat +``` + +Previously, `bar` would incorrectly print with a `foo = foo` line. Now, it works. + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +scratch/main> view bar + + bar : Nat + bar = + foo = .foo + foo +``` diff --git a/unison-src/transcripts/idempotent/fix-5433.md b/unison-src/transcripts/idempotent/fix-5433.md new file mode 100644 index 0000000000..0151405618 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5433.md @@ -0,0 +1,57 @@ +This used to cause a "duplicate effects" error because we weren't de-duping ability lists after binding names. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +ability foo.Bar where + baz : () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ability foo.Bar +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ability foo.Bar +``` + +``` unison +ability foo.Bar where + baz : '{Bar} () + +hello : Request {foo.Bar} a -> () +hello = cases + { baz _ -> _ } -> () + { _ } -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + hello : Request {Bar} a -> () + + ⍟ These names already exist. You can `update` them to your + new definition: + + ability foo.Bar +``` diff --git a/unison-src/transcripts/idempotent/fix-5446.md b/unison-src/transcripts/idempotent/fix-5446.md new file mode 100644 index 0000000000..a25a26aaa4 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5446.md @@ -0,0 +1,38 @@ +Previously `delete.namespace` would refuse to delete a namespace if it would leave any nameless references in `lib`. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +lib.one.foo = 17 +lib.two.bar = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.one.foo : Nat + lib.two.bar : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lib.one.foo : Nat + lib.two.bar : Nat +``` + +``` ucm +scratch/main> delete.namespace lib.one + + Done. +``` diff --git a/unison-src/transcripts/idempotent/fix-5464.md b/unison-src/transcripts/idempotent/fix-5464.md new file mode 100644 index 0000000000..387a3184ac --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5464.md @@ -0,0 +1,83 @@ +``` ucm +scratch/main> builtins.merge lib.builtin + + Done. +``` + +``` unison +foo : Nat +foo = + baz = bar.baz + bar.baz + 19 + +bar.baz : Nat +bar.baz = 20 + +qux : Nat +qux = foo + foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar.baz : Nat + foo : Nat + qux : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar.baz : Nat + foo : Nat + qux : Nat +``` + +``` unison +foo : Nat +foo = + baz = bar.baz + bar.baz + 20 + +bar.baz : Nat +bar.baz = 20 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⊡ Previously added definitions will be ignored: bar.baz + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : Nat +``` + +This update used to fail because `foo` would incorrectly print with a `use bar baz` statement, which caused references +to `bar.baz` to be captured by its locally-bound `baz`. + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. +``` diff --git a/unison-src/transcripts/idempotent/fix-5489.md b/unison-src/transcripts/idempotent/fix-5489.md new file mode 100644 index 0000000000..d02355ebb7 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5489.md @@ -0,0 +1,36 @@ +``` unison +namespace foo +type Foo = Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type foo.Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type foo.Foo +``` + +``` unison +namespace foo +type Foo = Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked the definitions in scratch.u. This + file has been previously added to the codebase. +``` diff --git a/unison-src/transcripts/idempotent/fix-5525.md b/unison-src/transcripts/idempotent/fix-5525.md new file mode 100644 index 0000000000..0988cacb1f --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5525.md @@ -0,0 +1,106 @@ +The original bug report identified the mishandling of this simple case involving shadowing, in which we previously +erroneously rendered "bar" with a leading dot. + +``` ucm +scratch/main> builtins.merge lib.builtin + + Done. +``` + +``` unison +foo = + bar = + match 5 with + 1 -> 2 + bar -> bar + bar +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : Nat + +scratch/main> view foo + + foo : Nat + foo = + bar = match 5 with + 1 -> 2 + bar -> bar + bar +``` + +``` ucm +scratch/main> project.delete scratch +``` + +There's a more complicated case that was also previously mishandled, though, which involves a top-level binding to which +for which we do need to add a leading dot in order to refer to. + +``` ucm +scratch/main> builtins.merge lib.builtin + + Done. +``` + +``` unison +foo = + bar = + match 5 with + 1 -> 2 + bar -> bar + .bar + bar + +bar = 17 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat + +scratch/main> view foo + + foo : Nat + foo = + use Nat + + bar = match 5 with + 1 -> 2 + bar -> bar + .bar + bar +``` + +``` ucm +scratch/main> project.delete scratch +``` diff --git a/unison-src/transcripts/fix-big-list-crash.md b/unison-src/transcripts/idempotent/fix-big-list-crash.md similarity index 87% rename from unison-src/transcripts/fix-big-list-crash.md rename to unison-src/transcripts/idempotent/fix-big-list-crash.md index 22be8f0cb1..2f0134bd47 100644 --- a/unison-src/transcripts/fix-big-list-crash.md +++ b/unison-src/transcripts/idempotent/fix-big-list-crash.md @@ -1,13 +1,26 @@ #### Big list crash -```ucm:hide -.> builtins.merge +``` ucm :hide +scratch/main> builtins.merge ``` Big lists have been observed to crash, while in the garbage collection step. -```unison +``` unison unique type Direction = U | D | L | R x = [(R,1005),(U,563),(R,417),(U,509),(L,237),(U,555),(R,397),(U,414),(L,490),(U,336),(L,697),(D,682),(L,180),(U,951),(L,189),(D,547),(R,697),(U,583),(L,172),(D,859),(L,370),(D,114),(L,519),(U,829),(R,389),(U,608),(R,66),(D,634),(L,320),(D,49),(L,931),(U,137),(L,349),(D,689),(L,351),(D,829),(R,819),(D,138),(L,118),(D,849),(R,230),(U,858),(L,509),(D,311),(R,815),(U,217),(R,359),(U,840),(R,77),(U,230),(R,361),(U,322),(R,300),(D,646),(R,348),(U,815),(R,793),(D,752),(R,967),(U,128),(R,948),(D,499),(R,359),(U,572),(L,566),(U,815),(R,630),(D,290),(L,829),(D,736),(R,358),(U,778),(R,891),(U,941),(R,544),(U,889),(L,920),(U,913),(L,447),(D,604),(R,538),(U,818),(L,215),(D,437),(R,447),(U,576),(R,452),(D,794),(R,864),(U,269),(L,325),(D,35),(L,268),(D,639),(L,101),(U,777),(L,776),(U,958),(R,105),(U,517),(R,667),(D,423),(R,603),(U,469),(L,125),(D,919),(R,879),(U,994),(R,665),(D,377),(R,456),(D,570),(L,685),(U,291),(R,261),(U,846),(R,840),(U,418),(L,974),(D,270),(L,312),(D,426),(R,621),(D,334),(L,855),(D,378),(R,694),(U,845),(R,481),(U,895),(L,362),(D,840),(L,712),(U,57),(R,276),(D,643),(R,566),(U,348),(R,361),(D,144),(L,287),(D,864),(L,556),(U,610),(L,927),(U,322),(R,271),(D,90),(L,741),(U,446),(R,181),(D,527),(R,56),(U,805),(L,907),(D,406),(L,286),(U,873),(L,79),(D,280),(L,153),(D,377),(R,253),(D,61),(R,475),(D,804),(R,788),(U,393),(L,660),(U,314),(R,489),(D,491),(L,234),(D,712),(L,253),(U,651),(L,777),(D,726),(R,146),(U,47),(R,630),(U,517),(R,226),(U,624),(L,834),(D,153),(L,513),(U,799),(R,287),(D,868),(R,982),(U,390),(L,296),(D,373),(R,9),(U,994),(R,105),(D,673),(L,657),(D,868),(R,738),(D,277),(R,374),(U,828),(R,860),(U,247),(R,484),(U,986),(L,723),(D,847),(L,578),(U,487),(L,51),(D,865),(L,328),(D,199),(R,812),(D,726),(R,355),(D,463),(R,761),(U,69),(R,508),(D,753),(L,81),(D,50),(L,345),(D,66),(L,764),(D,466),(L,975),(U,619),(R,59),(D,788),(L,737),(D,360),(R,14),(D,253),(L,512),(D,417),(R,828),(D,188),(L,394),(U,212),(R,658),(U,369),(R,920),(U,927),(L,339),(U,552),(R,856),(D,458),(R,407),(U,41),(L,930),(D,460),(R,809),(U,467),(L,410),(D,800),(L,135),(D,596),(R,678),(D,4),(L,771),(D,637),(L,876),(U,192),(L,406),(D,136),(R,666),(U,730),(R,711),(D,291),(L,586),(U,845),(R,606),(U,2),(L,228),(D,759),(R,244),(U,946),(R,948),(U,160),(R,397),(U,134),(R,188),(U,850),(R,623),(D,315),(L,219),(D,450),(R,489),(U,374),(R,299),(D,474),(L,767),(D,679),(L,160),(D,403),(L,708)] ``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Direction + x : [(Direction, Nat)] +``` diff --git a/unison-src/transcripts/idempotent/fix-ls.md b/unison-src/transcripts/idempotent/fix-ls.md new file mode 100644 index 0000000000..e1ccc5862f --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-ls.md @@ -0,0 +1,42 @@ +``` ucm +test-ls/main> builtins.merge + + Done. +``` + +``` unison +foo.bar.add x y = x Int.+ y + +foo.bar.subtract x y = x Int.- y +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo.bar.add : Int -> Int -> Int + foo.bar.subtract : Int -> Int -> Int +``` + +``` ucm +test-ls/main> add + + ⍟ I've added these definitions: + + foo.bar.add : Int -> Int -> Int + foo.bar.subtract : Int -> Int -> Int + +test-ls/main> ls foo + + 1. bar/ (2 terms) + +test-ls/main> ls 1 + + 1. add (Int -> Int -> Int) + 2. subtract (Int -> Int -> Int) +``` diff --git a/unison-src/transcripts/idempotent/fix1063.md b/unison-src/transcripts/idempotent/fix1063.md new file mode 100644 index 0000000000..1ac4910678 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix1063.md @@ -0,0 +1,42 @@ +Tests that functions named `.` are rendered correctly. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +(`.`) f g x = f (g x) + +use Boolean not + +noop = not `.` not +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + `.` : (i1 ->{g1} o) -> (i ->{g} i1) -> i ->{g1, g} o + noop : Boolean -> Boolean +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + `.` : (i1 ->{g1} o) -> (i ->{g} i1) -> i ->{g1, g} o + noop : Boolean -> Boolean + +scratch/main> view noop + + noop : Boolean -> Boolean + noop = + use Boolean not + not `.` not +``` diff --git a/unison-src/transcripts/idempotent/fix1327.md b/unison-src/transcripts/idempotent/fix1327.md new file mode 100644 index 0000000000..a6f700bc83 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix1327.md @@ -0,0 +1,48 @@ +``` unison +foo = 4 + +bar = 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : ##Nat + foo : ##Nat +``` + +`alias.many` should be able to consume the numbered args produced by `ls`. Previously, `ls` would produce absolute paths, but `alias.many` required relative ones. + +Now `ls` returns a pair of the absolute search directory and the result relative to that search directory, so it can be used in both absolute and relative contexts. + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : ##Nat + foo : ##Nat + +scratch/main> ls + + 1. bar (##Nat) + 2. foo (##Nat) + +scratch/main> alias.many 1-2 .ns1_nohistory + + Here's what changed in .ns1_nohistory : + + Added definitions: + + 1. bar : ##Nat + 2. foo : ##Nat + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. +``` diff --git a/unison-src/transcripts/idempotent/fix1334.md b/unison-src/transcripts/idempotent/fix1334.md new file mode 100644 index 0000000000..7d8a03e930 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix1334.md @@ -0,0 +1,15 @@ +Previously, the `alias.term` and `alias.type` would fail if the source argument was hash-only, and there was no way to create an alias for a definition that didn't already have a name. Also, the `replace.term` and `replace.type` *only* worked on hashes, and they had to be *full* hashes. + +With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual. + +Let's make some hash-only aliases, now that we can. :mad-with-power-emoji: + +``` ucm +scratch/main> alias.type ##Nat Cat + + Done. + +scratch/main> alias.term ##Nat.+ please_fix_763.+ + + Done. +``` diff --git a/unison-src/transcripts/idempotent/fix1390.md b/unison-src/transcripts/idempotent/fix1390.md new file mode 100644 index 0000000000..f597292177 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix1390.md @@ -0,0 +1,65 @@ +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +-- List.map : (a -> b) -> [a] -> [b] +List.map f = + go acc = cases + [] -> acc + h +: t -> go (acc :+ f h) t + go [] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + List.map : (i ->{g} o) -> [i] ->{g} [o] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + List.map : (i ->{g} o) -> [i] ->{g} [o] + +scratch/main> view List.map + + List.map : (i ->{g} o) -> [i] ->{g} [o] + List.map f = + go acc = cases + [] -> acc + h +: t -> go (acc :+ f h) t + go [] +``` + +``` unison +List.map2 : (g -> g2) -> [g] -> [g2] +List.map2 f = + unused = "just to give this a different hash" + go acc = cases + [] -> acc + h +: t -> go (acc :+ f h) t + go [] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + List.map2 : (g ->{h} g2) -> [g] ->{h} [g2] +``` diff --git a/unison-src/transcripts/idempotent/fix1421.md b/unison-src/transcripts/idempotent/fix1421.md new file mode 100644 index 0000000000..56b592a2db --- /dev/null +++ b/unison-src/transcripts/idempotent/fix1421.md @@ -0,0 +1,27 @@ +``` ucm +scratch/main> alias.type ##Nat Nat + + Done. + +scratch/main> alias.term ##Nat.+ Nat.+ + + Done. +``` + +``` unison +unique type A = A Nat +unique type B = B Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type A + type B +``` diff --git a/unison-src/transcripts/idempotent/fix1532.md b/unison-src/transcripts/idempotent/fix1532.md new file mode 100644 index 0000000000..8a7f4dd1e8 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix1532.md @@ -0,0 +1,87 @@ +``` ucm +scratch/main> builtins.merge + + Done. +``` + +First, lets create two namespaces. `foo` and `bar`, and add some definitions. + +``` unison +foo.x = 42 +foo.y = 100 +bar.z = x + y +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar.z : Nat + foo.x : Nat + foo.y : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar.z : Nat + foo.x : Nat + foo.y : Nat +``` + +Let's see what we have created... + +``` ucm +scratch/main> ls + + 1. bar/ (1 term) + 2. builtin/ (469 terms, 74 types) + 3. foo/ (2 terms) +``` + +Now, if we try deleting the namespace `foo`, we get an error, as expected. + +``` ucm :error +scratch/main> delete.namespace foo + + ⚠️ + + I didn't delete the namespace because the following + definitions are still in use. + + Dependency Referenced In + x 1. bar.z + + y 2. bar.z + + If you want to proceed anyways and leave those definitions + without names, use delete.namespace.force +``` + +Any numbered arguments should refer to `bar.z`. + +``` ucm +scratch/main> debug.numberedArgs + + 1. bar.z + 2. bar.z +``` + +We can then delete the dependent term, and then delete `foo`. + +``` ucm +scratch/main> delete.term 1 + + Done. + +scratch/main> delete.namespace foo + + Done. +``` diff --git a/unison-src/transcripts/idempotent/fix1696.md b/unison-src/transcripts/idempotent/fix1696.md new file mode 100644 index 0000000000..44c796315f --- /dev/null +++ b/unison-src/transcripts/idempotent/fix1696.md @@ -0,0 +1,29 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison :error +structural ability Ask where ask : Nat + +ability Zoot where + zoot : Nat + +Ask.provide : '{Zoot} Nat -> '{Ask} r -> r +Ask.provide answer asker = + h = cases + {r} -> r + {Ask.ask -> resume} -> handle resume !answer with h + handle !asker with h + +dialog = Ask.provide 'zoot '("Awesome number: " ++ Nat.toText Ask.ask ++ "!") + +> dialog +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + The expression in red needs the {Zoot} ability, but this location does not have access to any abilities. + + 13 | dialog = Ask.provide 'zoot '("Awesome number: " ++ Nat.toText Ask.ask ++ "!") +``` diff --git a/unison-src/transcripts/idempotent/fix1709.md b/unison-src/transcripts/idempotent/fix1709.md new file mode 100644 index 0000000000..324e2564c5 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix1709.md @@ -0,0 +1,48 @@ +``` unison +id x = x + +id2 x = + z = 384849 + id x +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + id : x -> x + id2 : x -> x +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + id : x -> x + id2 : x -> x +``` + +``` unison +> id2 "hi" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > id2 "hi" + ⧩ + "hi" +``` diff --git a/unison-src/transcripts/idempotent/fix1731.md b/unison-src/transcripts/idempotent/fix1731.md new file mode 100644 index 0000000000..b64f221eeb --- /dev/null +++ b/unison-src/transcripts/idempotent/fix1731.md @@ -0,0 +1,33 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison :hide +structural ability CLI where + print : Text ->{CLI} () + input : {CLI} Text +``` + +``` ucm :hide +scratch/main> add +``` + +The `input` here should parse as a wildcard, not as `CLI.input`. + +``` unison +repro : Text -> () +repro = cases + input -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + repro : Text -> () +``` diff --git a/unison-src/transcripts/idempotent/fix1800.md b/unison-src/transcripts/idempotent/fix1800.md new file mode 100644 index 0000000000..f47a148448 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix1800.md @@ -0,0 +1,116 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison :hide +printLine : Text ->{IO} () +printLine msg = + _ = putBytes.impl (stdHandle StdOut) (Text.toUtf8 (msg ++ "\n")) + () + +-- An unannotated main function +main1 = '(printLine "\nhello world!") + +-- Another variation +main2 _ = printLine "🌹" + +-- An annotated main function +main3 : '{IO} () +main3 _ = printLine "🦄 ☁️ 🌈" +``` + +Testing a few variations here: + + - Should be able to run annotated and unannotated main functions in the current file. + - Should be able to run annotated and unannotated main functions from the codebase. + +``` ucm +scratch/main> run main1 + + () + +scratch/main> run main2 + + () + +scratch/main> run main3 + + () + +scratch/main> add + + ⍟ I've added these definitions: + + main1 : '{IO} () + main2 : ∀ _. _ ->{IO} () + main3 : '{IO} () + printLine : Text ->{IO} () + +scratch/main> rename.term main1 code.main1 + + Done. + +scratch/main> rename.term main2 code.main2 + + Done. + +scratch/main> rename.term main3 code.main3 + + Done. +``` + +The renaming just ensures that when running `code.main1`, it has to get that main from the codebase rather than the scratch file: + +``` ucm +scratch/main> run code.main1 + + () + +scratch/main> run code.main2 + + () + +scratch/main> run code.main3 + + () +``` + +Now testing a few variations that should NOT typecheck. + +``` unison :hide +main4 : Nat ->{IO} Nat +main4 n = n + +main5 : Nat ->{IO} () +main5 _ = () +``` + +This shouldn't work since `main4` and `main5` don't have the right type. + +``` ucm :error +scratch/main> run main4 + + 😶 + + I found this function: + + main4 : Nat ->{IO} Nat + + but in order for me to `run` it needs to be a subtype of: + + main4 : '{IO, Exception} result +``` + +``` ucm :error +scratch/main> run main5 + + 😶 + + I found this function: + + main5 : Nat ->{IO} () + + but in order for me to `run` it needs to be a subtype of: + + main5 : '{IO, Exception} result +``` diff --git a/unison-src/transcripts/idempotent/fix1844.md b/unison-src/transcripts/idempotent/fix1844.md new file mode 100644 index 0000000000..0188dd0c8a --- /dev/null +++ b/unison-src/transcripts/idempotent/fix1844.md @@ -0,0 +1,32 @@ +``` unison +structural type One a = One a +unique type Woot a b c = Woot a b c +unique type Z = Z + +snoc k aN = match k with + One a0 -> Woot (One a0) (One aN) 99 + +> snoc (One 1) 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type One a + type Woot a b c + type Z + snoc : One a -> aN -> Woot (One a) (One aN) ##Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 8 | > snoc (One 1) 2 + ⧩ + Woot (One 1) (One 2) 99 +``` diff --git a/unison-src/transcripts/idempotent/fix1926.md b/unison-src/transcripts/idempotent/fix1926.md new file mode 100644 index 0000000000..001e7f7ba7 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix1926.md @@ -0,0 +1,55 @@ +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +> 'sq + +sq = 2934892384 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + sq : Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > 'sq + ⧩ + do sq +``` + +``` unison +> 'sq + +sq = 2934892384 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + sq : Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > 'sq + ⧩ + do sq +``` diff --git a/unison-src/transcripts/idempotent/fix2026.md b/unison-src/transcripts/idempotent/fix2026.md new file mode 100644 index 0000000000..5aa3edabf4 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2026.md @@ -0,0 +1,73 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison +structural ability Exception where raise : Failure -> x + +ex = unsafeRun! '(printLine "hello world") + +printLine : Text ->{IO, Exception} () +printLine t = + putText stdOut t + putText stdOut "\n" + +stdOut : Handle +stdOut = stdHandle StdOut + +compose2 : (c ->{𝕖1} d) -> (a ->{𝕖2} b ->{𝕖3} c) -> a -> b ->{𝕖1,𝕖2,𝕖3} d +compose2 f g x y = f (g x y) + +putBytes : Handle -> Bytes ->{IO, Exception} () +putBytes = compose2 toException putBytes.impl + +toException : Either Failure a ->{Exception} a +toException = cases + Left e -> raise e + Right a -> a + +putText : Handle -> Text ->{IO, Exception} () +putText h t = putBytes h (toUtf8 t) + +Exception.unsafeRun! : '{Exception, g} a -> '{g} a +Exception.unsafeRun! e _ = + h : Request {Exception} a -> a + h = cases + {Exception.raise fail -> _ } -> + bug fail + {a} -> a + handle !e with h +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Exception + (also named builtin.Exception) + Exception.unsafeRun! : '{g, Exception} a -> '{g} a + compose2 : (c ->{𝕖1} d) + -> (a ->{𝕖2} b ->{𝕖3} c) + -> a + -> b + ->{𝕖1, 𝕖2, 𝕖3} d + ex : '{IO} () + printLine : Text ->{IO, Exception} () + putBytes : Handle + -> Bytes + ->{IO, Exception} () + putText : Handle -> Text ->{IO, Exception} () + stdOut : Handle + toException : Either Failure a ->{Exception} a +``` + +``` ucm +scratch/main> run ex + + () +``` diff --git a/unison-src/transcripts/idempotent/fix2027.md b/unison-src/transcripts/idempotent/fix2027.md new file mode 100644 index 0000000000..3a4088f2a0 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2027.md @@ -0,0 +1,96 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +structural ability Exception where raise : Failure -> x + +reraise = cases + Left e -> raise e + Right a -> a + +structural type Either a b = Left a | Right b + +putBytes h bs = reraise (putBytes.impl h bs) + +toException : Either Failure a ->{Exception} a +toException = cases + Left e -> raise e + Right a -> a + +putText : Handle -> Text ->{IO, Exception} () +putText h t = putBytes h (toUtf8 t) + +bugFail = cases + Failure typ _ _ -> bug (Failure typ "problem" (Any ())) + +Exception.unsafeRun! : '{Exception, g} a -> '{g} a +Exception.unsafeRun! e _ = + h : Request {Exception} a -> a + h = cases + {Exception.raise fail -> _ } -> + bugFail fail + {a} -> a + handle !e with h + +socketSend s bytes = reraise (socketSend.impl s bytes) +closeSocket s = reraise (closeSocket.impl s) +serverSocket host port = reraise (IO.serverSocket.impl host port) + +hello : Text -> Text -> {IO, Exception} () +hello host port = + socket = serverSocket (Some host) port + msg = toUtf8 "Hello there" + socketSend socket msg + closeSocket socket + +myServer = unsafeRun! '(hello "127.0.0.1" "0") + +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type Either a b + (also named builtin.Either) + structural ability Exception + (also named builtin.Exception) + Exception.unsafeRun! : '{g, Exception} a -> '{g} a + bugFail : Failure -> r + closeSocket : Socket ->{IO, Exception} () + hello : Text -> Text ->{IO, Exception} () + myServer : '{IO} () + putBytes : Handle + -> Bytes + ->{IO, Exception} () + putText : Handle -> Text ->{IO, Exception} () + reraise : Either Failure b ->{Exception} b + serverSocket : Optional Text + -> Text + ->{IO, Exception} Socket + socketSend : Socket + -> Bytes + ->{IO, Exception} () + toException : Either Failure a ->{Exception} a +``` + +``` ucm :error +scratch/main> run myServer + + 💔💥 + + I've encountered a call to builtin.bug with the following + value: + + Failure (typeLink IOFailure) "problem" (Any ()) + + Stack trace: + bug + #8ppr1tt4q2 +``` diff --git a/unison-src/transcripts/idempotent/fix2049.md b/unison-src/transcripts/idempotent/fix2049.md new file mode 100644 index 0000000000..4c13479448 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2049.md @@ -0,0 +1,144 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +id x = x + +structural ability Stream a where + emit : a -> () + +Stream.foldl : (x ->{g} a ->{g} x) -> x -> '{g, Stream a} r -> '{g} x +Stream.foldl f z str _ = + h acc = cases + { emit x -> k } -> handle !k with h (f acc x) + { _ } -> acc + handle !str with h z + +Stream.range : Nat -> Nat -> '{Stream Nat} () +Stream.range m n = do + f : Nat ->{Stream Nat} () + f k = if k < n then emit k ; f (k+1) else () + f m + +unique type Fold' g a b x = Fold' (x -> {g} a -> {g} x) x (x -> {g} b) + +unique type Fold g a b = Fold (∀ g2 r. (∀ x. Fold' g a b x -> {g2} r) -> {g2} r) + +Fold.fromFold' : Fold' g a b x -> Fold g a b +Fold.fromFold' fold = Fold.Fold (f -> f fold) + +Fold.mkFold : (t -> {g} a -> {g} t) -> t -> (t -> {g} b) -> Fold g a b +Fold.mkFold step init extract = + Fold.fromFold' (Fold'.Fold' step init extract) + +folds.all : (a -> {g} Boolean) -> Fold g a Boolean +folds.all predicate = + Fold.mkFold (b -> a -> b && (predicate a)) true id + +Fold.Stream.fold : Fold g a b -> '{g, Stream a} r -> '{g} b +Fold.Stream.fold = + run: Fold' g a b x -> '{g, Stream a} r -> '{g} b + run = + cases Fold'.Fold' step init extract -> + stream -> _ -> extract !(foldl step init stream) + cases + Fold f -> stream -> f (f' -> run f' stream) + +> folds.all.tests.stream = + pred = n -> (Nat.gt n 2) + res : 'Boolean + res = Fold.Stream.fold (folds.all pred) (Stream.range 1 5) + !res Universal.== false +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Fold g a b + type Fold' g a b x + structural ability Stream a + Fold.Stream.fold : Fold g a b + -> '{g, Stream a} r + -> '{g} b + Fold.fromFold' : Fold' g a b x -> Fold g a b + Fold.mkFold : (t ->{g} a ->{g} t) + -> t + -> (t ->{g} b) + -> Fold g a b + Stream.foldl : (x ->{g} a ->{g} x) + -> x + -> '{g, Stream a} r + -> '{g} x + Stream.range : Nat -> Nat -> '{Stream Nat} () + folds.all : (a ->{g} Boolean) -> Fold g a Boolean + id : x -> x + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 44 | pred = n -> (Nat.gt n 2) + ⧩ + true +``` + +Tests some capabilities for catching runtime exceptions. + +``` unison +catcher : '{IO} () ->{IO} Result +catcher act = + handle tryEval act with cases + { raise _ -> _ } -> Ok "caught" + { _ } -> Fail "nothing to catch" + +tests _ = + [ catcher do + _ = 1/0 + () + , catcher '(bug "testing") + , handle tryEval (do 1+1) with cases + { raise _ -> _ } -> Fail "1+1 failed" + { 2 } -> Ok "got the right answer" + { _ } -> Fail "got the wrong answer" + ] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + catcher : '{IO} () ->{IO} Result + tests : ∀ _. _ ->{IO} [Result] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + catcher : '{IO} () ->{IO} Result + tests : ∀ _. _ ->{IO} [Result] + +scratch/main> io.test tests + + New test results: + + 1. tests ◉ caught + ◉ caught + ◉ got the right answer + + ✅ 3 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` diff --git a/unison-src/transcripts/idempotent/fix2053.md b/unison-src/transcripts/idempotent/fix2053.md new file mode 100644 index 0000000000..2d5f1ce62e --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2053.md @@ -0,0 +1,15 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` ucm +scratch/main> display List.map + + f a -> + let + use Nat + + go i as acc = match List.at i as with + None -> acc + Some a -> go (i + 1) as (acc :+ f a) + go 0 a [] +``` diff --git a/unison-src/transcripts/idempotent/fix2156.md b/unison-src/transcripts/idempotent/fix2156.md new file mode 100644 index 0000000000..b90eebc481 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2156.md @@ -0,0 +1,32 @@ +Tests for a case where bad eta reduction was causing erroneous watch +output/caching. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +sqr : Nat -> Nat +sqr n = n * n + +> sqr +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + sqr : Nat -> Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 4 | > sqr + ⧩ + n -> n Nat.* n +``` diff --git a/unison-src/transcripts/idempotent/fix2167.md b/unison-src/transcripts/idempotent/fix2167.md new file mode 100644 index 0000000000..04b01deb66 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2167.md @@ -0,0 +1,42 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +This is just a simple transcript to regression check an ability +inference/checking issue. + +``` unison +structural ability R t where + die : () -> x + near.impl : Nat -> Either () [Nat] + +R.near n = match near.impl n with + Left e -> die () + Right a -> a + +R.near1 region loc = match R.near 42 with + [loc] -> loc + ls -> R.die () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability R t + R.near : Nat ->{R t} [Nat] + R.near1 : region -> loc ->{R t} Nat +``` + +The issue was that abilities with parameters like this were sometimes +causing failures like this because the variable in the parameter would +escape to a scope where it no longer made sense. Then solving would +fail because the type was invalid. + +The fix was to avoid dropping certain existential variables out of +scope. diff --git a/unison-src/transcripts/idempotent/fix2187.md b/unison-src/transcripts/idempotent/fix2187.md new file mode 100644 index 0000000000..16d3275dc5 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2187.md @@ -0,0 +1,31 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison + +lexicalScopeEx: [Text] +lexicalScopeEx = + parent = "outer" + inner1 = let + child1 = "child1" + inner2 : [Text] + inner2 = let + child2 = "child2" + [parent, child1, child2] + inner2 + inner1 + +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lexicalScopeEx : [Text] +``` diff --git a/unison-src/transcripts/idempotent/fix2231.md b/unison-src/transcripts/idempotent/fix2231.md new file mode 100644 index 0000000000..871f5e2b89 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2231.md @@ -0,0 +1,51 @@ +This transcript contains some cases that were problematic with the new +type checker. They were likely not discovered earlier because they +involve combining types inferred with the older strategy with the new +inference algorithm. Some code can be given multiple possible types, +and while they are all valid and some may be equivalently general, +the choices may not work equally well with the type checking +strategies. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +(<<) : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c +(<<) f g x = f (g x) + +f = atan << tan + +foldl : (b ->{e} a ->{e} b) -> b -> [a] ->{e} b +foldl f a = cases + [] -> a + x +: xs -> foldl f (f a x) xs + +txt = foldl (Text.++) "" ["a", "b", "c"] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + << : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c + f : Float -> Float + foldl : (b ->{e} a ->{e} b) -> b -> [a] ->{e} b + txt : Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + << : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c + f : Float -> Float + foldl : (b ->{e} a ->{e} b) -> b -> [a] ->{e} b + txt : Text +``` diff --git a/unison-src/transcripts/idempotent/fix2238.md b/unison-src/transcripts/idempotent/fix2238.md new file mode 100644 index 0000000000..623cbdf3f2 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2238.md @@ -0,0 +1,40 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +This should not typecheck - the inline `@eval` expression uses abilities. + +``` unison :error +structural ability Abort where abort : x + +ex = {{ @eval{abort} }} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + The expression in red needs the {Abort} ability, but this location does not have access to any abilities. + + 3 | ex = {{ @eval{abort} }} +``` + +This file should also not typecheck - it has a triple backticks block that uses abilities. + +```` unison :error +structural ability Abort where abort : x + +ex = {{ + +``` +abort + 1 +``` +}} +```` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + The expression in red needs the {Abort} ability, but this location does not have access to any abilities. + + 6 | abort + 1 +``` diff --git a/unison-src/transcripts/idempotent/fix2244.md b/unison-src/transcripts/idempotent/fix2244.md new file mode 100644 index 0000000000..ba3c1077fc --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2244.md @@ -0,0 +1,34 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +Ensure closing token is emitted by closing brace in doc eval block. + +```` unison +x = {{ + +``` +let + x = 1 + y = 2 + x + y +``` + +}} +```` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + x : Doc2 +``` + +``` ucm :hide +scratch/main> add +``` diff --git a/unison-src/transcripts/idempotent/fix2254.md b/unison-src/transcripts/idempotent/fix2254.md new file mode 100644 index 0000000000..6079ba210a --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2254.md @@ -0,0 +1,224 @@ +``` ucm :hide +scratch/a> builtins.merge lib.builtins +``` + +This transcript checks that updates to data types propagate successfully to dependent types and dependent terms that do pattern matching. First let's create some types and terms: + +``` unison :hide +unique type A a b c d + = A a + | B b + | C c + | D d + +structural type NeedsA a b = NeedsA (A a b Nat Nat) + | Zoink Text + +f : A Nat Nat Nat Nat -> Nat +f = cases + A n -> n + _ -> 42 + +f2 a = + n = f a + n + 1 + +f3 : NeedsA Nat Nat -> Nat +f3 = cases + NeedsA a -> f a + 20 + _ -> 0 + +g : A Nat Nat Nat Nat -> Nat +g = cases + D n -> n + _ -> 43 +``` + +We'll make our edits in a new branch. + +``` ucm +scratch/a> add + + ⍟ I've added these definitions: + + type A a b c d + structural type NeedsA a b + f : A Nat Nat Nat Nat -> Nat + f2 : A Nat Nat Nat Nat -> Nat + f3 : NeedsA Nat Nat -> Nat + g : A Nat Nat Nat Nat -> Nat + +scratch/a> branch /a2 + + Done. I've created the a2 branch based off of a. + + Tip: To merge your work back into the a branch, first + `switch /a` then `merge /a2`. +``` + +First let's edit the `A` type, adding another constructor `E`. Note that the functions written against the old type have a wildcard in their pattern match, so they should work fine after the update. + +``` unison :hide +unique type A a b c d + = A a + | B b + | C c + | D d + | E a d +``` + +Let's do the update now, and verify that the definitions all look good and there's nothing `todo`: + +``` ucm +scratch/a2> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +scratch/a2> view A NeedsA f f2 f3 g + + type A a b c d + = E a d + | B b + | A a + | D d + | C c + + structural type NeedsA a b + = Zoink Text + | NeedsA (A a b Nat Nat) + + f : A Nat Nat Nat Nat -> Nat + f = cases + A n -> n + _ -> 42 + + f2 : A Nat Nat Nat Nat -> Nat + f2 a = + use Nat + + n = f a + n + 1 + + f3 : NeedsA Nat Nat -> Nat + f3 = cases + NeedsA a -> f a Nat.+ 20 + _ -> 0 + + g : A Nat Nat Nat Nat -> Nat + g = cases + D n -> n + _ -> 43 + +scratch/a2> todo + + You have no pending todo items. Good work! ✅ +``` + +## Record updates + +Here's a test of updating a record: + +``` ucm :hide +scratch/r1> builtins.merge lib.builtins +``` + +``` unison +structural type Rec = { uno : Nat, dos : Nat } + +combine r = uno r + dos r +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type Rec + Rec.dos : Rec -> Nat + Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec + Rec.dos.set : Nat -> Rec -> Rec + Rec.uno : Rec -> Nat + Rec.uno.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec + Rec.uno.set : Nat -> Rec -> Rec + combine : Rec -> Nat +``` + +``` ucm +scratch/r1> add + + ⍟ I've added these definitions: + + structural type Rec + Rec.dos : Rec -> Nat + Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec + Rec.dos.set : Nat -> Rec -> Rec + Rec.uno : Rec -> Nat + Rec.uno.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec + Rec.uno.set : Nat -> Rec -> Rec + combine : Rec -> Nat + +scratch/r1> branch r2 + + Done. I've created the r2 branch based off of r1. + + Tip: To merge your work back into the r1 branch, first + `switch /r1` then `merge /r2`. +``` + +``` unison +structural type Rec = { uno : Nat, dos : Nat, tres : Text } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Rec.tres : Rec -> Text + Rec.tres.modify : (Text ->{g} Text) -> Rec ->{g} Rec + Rec.tres.set : Text -> Rec -> Rec + + ⍟ These names already exist. You can `update` them to your + new definition: + + structural type Rec + Rec.dos : Rec -> Nat + Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec + Rec.dos.set : Nat -> Rec -> Rec + Rec.uno : Rec -> Nat + Rec.uno.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec + Rec.uno.set : Nat -> Rec -> Rec +``` + +And checking that after updating this record, there's nothing `todo`: + +``` ucm +scratch/r2> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +scratch/r2> todo + + You have no pending todo items. Good work! ✅ +``` diff --git a/unison-src/transcripts/idempotent/fix2268.md b/unison-src/transcripts/idempotent/fix2268.md new file mode 100644 index 0000000000..afe51a4072 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2268.md @@ -0,0 +1,34 @@ +Tests for a TDNR case that wasn't working. The code wasn't 'relaxing' +inferred types that didn't contain arrows, so effects that just yield +a value weren't getting disambiguated. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +unique ability A where + a : Nat + +unique ability B where + a : Char + +test : () -> Nat +test _ = + x = a + toNat x +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ability A + ability B + test : '{B} Nat +``` diff --git a/unison-src/transcripts/idempotent/fix2334.md b/unison-src/transcripts/idempotent/fix2334.md new file mode 100644 index 0000000000..c5e126d113 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2334.md @@ -0,0 +1,50 @@ +Tests an issue where pattern matching matrices involving built-in +types was discarding default cases in some branches. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +f = cases + 0, 0 -> 0 + _, 1 -> 2 + 1, _ -> 3 + _, _ -> 1 + +> f 0 0 +> f 1 0 +> f 0 1 +> f 1 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + f : Nat -> Nat -> Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 7 | > f 0 0 + ⧩ + 0 + + 8 | > f 1 0 + ⧩ + 3 + + 9 | > f 0 1 + ⧩ + 2 + + 10 | > f 1 1 + ⧩ + 2 +``` diff --git a/unison-src/transcripts/idempotent/fix2344.md b/unison-src/transcripts/idempotent/fix2344.md new file mode 100644 index 0000000000..47c0c09d67 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2344.md @@ -0,0 +1,34 @@ +Checks a corner case with type checking involving destructuring binds. + +The binds were causing some sequences of lets to be unnecessarily +recursive. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +unique ability Nate where + nate: (Boolean, Nat) + antiNate: () + + +sneezy: (Nat -> {d} a) -> '{Nate,d} a +sneezy dee _ = + (_,_) = nate + antiNate + dee 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ability Nate + sneezy : (Nat ->{d} a) -> '{d, Nate} a +``` diff --git a/unison-src/transcripts/idempotent/fix2350.md b/unison-src/transcripts/idempotent/fix2350.md new file mode 100644 index 0000000000..8a741ff4bf --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2350.md @@ -0,0 +1,42 @@ +This tests an issue where ability variables were being defaulted over +eagerly. In general, we want to avoid collecting up variables from the +use of definitions with types like: + +``` +T ->{e} U +``` + +Since this type works for every `e`, it is, 'pure;' and we might as +well have `e = {}`, since `{}` is a subrow of every other row. +However, if `e` isn't just a quantified variable, but one involved in +ongoing inference, it's undesirable to default it. Previously there +was a check to see if `e` occurred in the context. However, the wanted +abilities being collected aren't in the context, so types like: + +``` +T ->{S e} U ->{e} V +``` + +were a corner case. We would add `S e` to the wanted abilities, then +not realize that `e` shouldn't be defaulted. + +``` unison +unique ability Storage d g where + save.impl : a ->{Storage d g} ('{g} (d a)) + +save : a ->{Storage d g, g} (d a) +save a = !(save.impl a) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ability Storage d g + save : a ->{g, Storage d g} d a +``` diff --git a/unison-src/transcripts/idempotent/fix2353.md b/unison-src/transcripts/idempotent/fix2353.md new file mode 100644 index 0000000000..2c68391d65 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2353.md @@ -0,0 +1,30 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +use builtin Scope +unique ability Async t g where async : {g} Nat +unique ability Exception where raise : Nat -> x + +pure.run : a -> (forall t . '{Async t g} a) ->{Exception, g} a +pure.run a0 a = + a' : forall s . '{Scope s, Exception, g} a + a' = 'a0 -- typechecks + -- make sure this builtin can still be referenced + Scope.run a' +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ability Async t g + ability Exception + pure.run : a -> (∀ t. '{Async t g} a) ->{g, Exception} a +``` diff --git a/unison-src/transcripts/idempotent/fix2354.md b/unison-src/transcripts/idempotent/fix2354.md new file mode 100644 index 0000000000..abdbbbde67 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2354.md @@ -0,0 +1,29 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Tests that delaying an un-annotated higher-rank type gives a normal +type error, rather than an internal compiler error. + +``` unison :error +f : (forall a . a -> a) -> Nat +f id = id 0 + +x = 'f +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found a value of type: (a1 ->{𝕖} a1) ->{𝕖} Nat + where I expected to find: (a -> 𝕣1) -> 𝕣 + + 1 | f : (forall a . a -> a) -> Nat + 2 | f id = id 0 + 3 | + 4 | x = 'f + + from right here: + + 1 | f : (forall a . a -> a) -> Nat +``` diff --git a/unison-src/transcripts/idempotent/fix2355.md b/unison-src/transcripts/idempotent/fix2355.md new file mode 100644 index 0000000000..c0d7eb8cbf --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2355.md @@ -0,0 +1,42 @@ +Tests for a loop that was previously occurring in the type checker. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison :error +structural ability A t g where + fork : '{g, A t g} a -> t a + await : t a -> a + empty! : t a + put : a -> t a -> () + +example : '{A t {}} Nat +example = 'let + r = A.empty! + go u = + t = A.fork '(go (u + 1)) + A.await t + + go 0 + t2 = A.fork '(A.put 10 r) + A.await r +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I tried to infer a cyclic ability. + + The expression in red was inferred to require the ability: + + {A t25 {𝕖36, 𝕖18}} + + where `𝕖18` is its overall abilities. + + I need a type signature to help figure this out. + + 10 | go u = + 11 | t = A.fork '(go (u + 1)) + 12 | A.await t +``` diff --git a/unison-src/transcripts/idempotent/fix2378.md b/unison-src/transcripts/idempotent/fix2378.md new file mode 100644 index 0000000000..b9e8b28575 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2378.md @@ -0,0 +1,62 @@ +Tests for an ability failure that was caused by order dependence of +checking wanted vs. provided abilities. It was necessary to re-check +rows until a fixed point is reached. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +unique ability C c where + new : c a + receive : c a -> a + send : a -> c a -> () + +unique ability A t g where + fork : '{A t g, g, Exception} a -> t a + await : t a -> a + +unique ability Ex where raise : () -> x + +Ex.catch : '{Ex, g} a ->{g} Either () a +Ex.catch _ = todo "Exception.catch" + +C.pure.run : (forall c . '{C c, g} r) ->{Ex, g} r +C.pure.run _ = todo "C.pure.run" + +A.pure.run : (forall t . '{A t g, g} a) ->{Ex,g} a +A.pure.run _ = todo "A.pure.run" + +ex : '{C c, A t {C c}} Nat +ex _ = + c = C.new + x = A.fork 'let + a = receive c + a + 10 + y = A.fork 'let + send 0 c + () + A.await x + +x : '{} (Either () Nat) +x _ = Ex.catch '(C.pure.run '(A.pure.run ex)) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ability A t g + ability C c + ability Ex + A.pure.run : (∀ t. '{g, A t g} a) ->{g, Ex} a + C.pure.run : (∀ c. '{g, C c} r) ->{g, Ex} r + Ex.catch : '{g, Ex} a ->{g} Either () a + ex : '{C c, A t {C c}} Nat + x : 'Either () Nat +``` diff --git a/unison-src/transcripts/idempotent/fix2423.md b/unison-src/transcripts/idempotent/fix2423.md new file mode 100644 index 0000000000..6dd068d1f2 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2423.md @@ -0,0 +1,50 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +structural ability Split where + skip! : x + both : a -> a -> a + +Split.append : '{Split, g} a -> '{Split, g} a -> '{Split, g} a +Split.append s1 s2 _ = force (both s1 s2) + +force a = !a + +Split.zipSame : '{Split, g} a -> '{Split, g} b -> '{Split, g} (a, b) +Split.zipSame sa sb _ = + go : '{Split,g2} y -> Request {Split} x ->{Split,g2} (x,y) + go sb = cases + { a } -> (a, !sb) + { skip! -> _ } -> skip! + { both la ra -> k } -> + handle !sb with cases + { _ } -> skip! + { skip! -> k } -> skip! + { both lb rb -> k2 } -> + force (Split.append + (zipSame '(k la) '(k2 lb)) + (zipSame '(k ra) '(k2 rb))) + + handle !sa with go sb +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Split + Split.append : '{g, Split} a + -> '{g, Split} a + -> '{g, Split} a + Split.zipSame : '{g, Split} a + -> '{g, Split} b + -> '{g, Split} (a, b) + force : '{g} o ->{g} o +``` diff --git a/unison-src/transcripts/idempotent/fix2474.md b/unison-src/transcripts/idempotent/fix2474.md new file mode 100644 index 0000000000..b2c4ba25c4 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2474.md @@ -0,0 +1,52 @@ +Tests an issue with a lack of generality of handlers. + +In general, a set of cases: + +``` +{ e ... -> k } +``` + +should be typed in the following way: + +1. The scrutinee has type `Request {E, g} r -> s` where `E` is all + the abilities being handled. `g` is a slack variable, because all + abilities that are used in the handled expression pass through + the handler. Previously this was being inferred as merely + `Request {E} r -> s` +2. The continuation variable `k` should have type `o ->{E, g} r`, + matching the above types (`o` is the result type of `e`). + Previously this was being checked as `o ->{E0} r`, where `E0` is + the ability that contains `e`. + +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +structural ability Stream a where + emit : a -> () + +Stream.uncons : '{Stream a, g} r ->{g} Either r (a, '{Stream a, g} r) +Stream.uncons s = + go : Request {Stream a,g} r -> Either r (a, '{Stream a,g} r) + go = cases + { r } -> Left r + { Stream.emit a -> tl } -> Right (a, tl : '{Stream a,g} r) + handle !s with go +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Stream a + Stream.uncons : '{g, Stream a} r + ->{g} Either r (a, '{g, Stream a} r) +``` diff --git a/unison-src/transcripts/idempotent/fix2628.md b/unison-src/transcripts/idempotent/fix2628.md new file mode 100644 index 0000000000..f7c62a4826 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2628.md @@ -0,0 +1,28 @@ +``` ucm :hide +scratch/main> alias.type ##Nat lib.base.Nat +``` + +``` unison :hide +unique type foo.bar.baz.MyRecord = { + value : Nat +} +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type foo.bar.baz.MyRecord + foo.bar.baz.MyRecord.value : MyRecord -> Nat + foo.bar.baz.MyRecord.value.modify : (Nat ->{g} Nat) + -> MyRecord + ->{g} MyRecord + foo.bar.baz.MyRecord.value.set : Nat + -> MyRecord + -> MyRecord + +scratch/main> find : Nat -> MyRecord + + 1. foo.bar.baz.MyRecord.MyRecord : Nat -> MyRecord +``` diff --git a/unison-src/transcripts/idempotent/fix2663.md b/unison-src/transcripts/idempotent/fix2663.md new file mode 100644 index 0000000000..7412c7a8ca --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2663.md @@ -0,0 +1,45 @@ +Tests a variable capture problem. + +After pattern compilation, the match would end up: + +``` +T p1 p3 p3 +``` + +and z would end up referring to the first p3 rather than the second. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +structural type Trip = T Nat Nat Nat + +bad : Nat -> (Nat, Nat) +bad x = match Some (Some x) with + Some (Some x) -> match T 3 4 5 with + T _ _ z -> (x, z) + _ -> (0,0) + +> bad 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type Trip + bad : Nat -> (Nat, Nat) + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 9 | > bad 2 + ⧩ + (2, 5) +``` diff --git a/unison-src/transcripts/idempotent/fix2693.md b/unison-src/transcripts/idempotent/fix2693.md new file mode 100644 index 0000000000..c095fe7447 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2693.md @@ -0,0 +1,4075 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +loop : List Nat -> Nat -> List Nat +loop l = cases + 0 -> l + n -> loop (n +: l) (drop n 1) + +range : Nat -> List Nat +range = loop [] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + loop : [Nat] -> Nat -> [Nat] + range : Nat -> [Nat] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + loop : [Nat] -> Nat -> [Nat] + range : Nat -> [Nat] +``` + +``` unison +> range 2000 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > range 2000 + ⧩ + [ 1 + , 2 + , 3 + , 4 + , 5 + , 6 + , 7 + , 8 + , 9 + , 10 + , 11 + , 12 + , 13 + , 14 + , 15 + , 16 + , 17 + , 18 + , 19 + , 20 + , 21 + , 22 + , 23 + , 24 + , 25 + , 26 + , 27 + , 28 + , 29 + , 30 + , 31 + , 32 + , 33 + , 34 + , 35 + , 36 + , 37 + , 38 + , 39 + , 40 + , 41 + , 42 + , 43 + , 44 + , 45 + , 46 + , 47 + , 48 + , 49 + , 50 + , 51 + , 52 + , 53 + , 54 + , 55 + , 56 + , 57 + , 58 + , 59 + , 60 + , 61 + , 62 + , 63 + , 64 + , 65 + , 66 + , 67 + , 68 + , 69 + , 70 + , 71 + , 72 + , 73 + , 74 + , 75 + , 76 + , 77 + , 78 + , 79 + , 80 + , 81 + , 82 + , 83 + , 84 + , 85 + , 86 + , 87 + , 88 + , 89 + , 90 + , 91 + , 92 + , 93 + , 94 + , 95 + , 96 + , 97 + , 98 + , 99 + , 100 + , 101 + , 102 + , 103 + , 104 + , 105 + , 106 + , 107 + , 108 + , 109 + , 110 + , 111 + , 112 + , 113 + , 114 + , 115 + , 116 + , 117 + , 118 + , 119 + , 120 + , 121 + , 122 + , 123 + , 124 + , 125 + , 126 + , 127 + , 128 + , 129 + , 130 + , 131 + , 132 + , 133 + , 134 + , 135 + , 136 + , 137 + , 138 + , 139 + , 140 + , 141 + , 142 + , 143 + , 144 + , 145 + , 146 + , 147 + , 148 + , 149 + , 150 + , 151 + , 152 + , 153 + , 154 + , 155 + , 156 + , 157 + , 158 + , 159 + , 160 + , 161 + , 162 + , 163 + , 164 + , 165 + , 166 + , 167 + , 168 + , 169 + , 170 + , 171 + , 172 + , 173 + , 174 + , 175 + , 176 + , 177 + , 178 + , 179 + , 180 + , 181 + , 182 + , 183 + , 184 + , 185 + , 186 + , 187 + , 188 + , 189 + , 190 + , 191 + , 192 + , 193 + , 194 + , 195 + , 196 + , 197 + , 198 + , 199 + , 200 + , 201 + , 202 + , 203 + , 204 + , 205 + , 206 + , 207 + , 208 + , 209 + , 210 + , 211 + , 212 + , 213 + , 214 + , 215 + , 216 + , 217 + , 218 + , 219 + , 220 + , 221 + , 222 + , 223 + , 224 + , 225 + , 226 + , 227 + , 228 + , 229 + , 230 + , 231 + , 232 + , 233 + , 234 + , 235 + , 236 + , 237 + , 238 + , 239 + , 240 + , 241 + , 242 + , 243 + , 244 + , 245 + , 246 + , 247 + , 248 + , 249 + , 250 + , 251 + , 252 + , 253 + , 254 + , 255 + , 256 + , 257 + , 258 + , 259 + , 260 + , 261 + , 262 + , 263 + , 264 + , 265 + , 266 + , 267 + , 268 + , 269 + , 270 + , 271 + , 272 + , 273 + , 274 + , 275 + , 276 + , 277 + , 278 + , 279 + , 280 + , 281 + , 282 + , 283 + , 284 + , 285 + , 286 + , 287 + , 288 + , 289 + , 290 + , 291 + , 292 + , 293 + , 294 + , 295 + , 296 + , 297 + , 298 + , 299 + , 300 + , 301 + , 302 + , 303 + , 304 + , 305 + , 306 + , 307 + , 308 + , 309 + , 310 + , 311 + , 312 + , 313 + , 314 + , 315 + , 316 + , 317 + , 318 + , 319 + , 320 + , 321 + , 322 + , 323 + , 324 + , 325 + , 326 + , 327 + , 328 + , 329 + , 330 + , 331 + , 332 + , 333 + , 334 + , 335 + , 336 + , 337 + , 338 + , 339 + , 340 + , 341 + , 342 + , 343 + , 344 + , 345 + , 346 + , 347 + , 348 + , 349 + , 350 + , 351 + , 352 + , 353 + , 354 + , 355 + , 356 + , 357 + , 358 + , 359 + , 360 + , 361 + , 362 + , 363 + , 364 + , 365 + , 366 + , 367 + , 368 + , 369 + , 370 + , 371 + , 372 + , 373 + , 374 + , 375 + , 376 + , 377 + , 378 + , 379 + , 380 + , 381 + , 382 + , 383 + , 384 + , 385 + , 386 + , 387 + , 388 + , 389 + , 390 + , 391 + , 392 + , 393 + , 394 + , 395 + , 396 + , 397 + , 398 + , 399 + , 400 + , 401 + , 402 + , 403 + , 404 + , 405 + , 406 + , 407 + , 408 + , 409 + , 410 + , 411 + , 412 + , 413 + , 414 + , 415 + , 416 + , 417 + , 418 + , 419 + , 420 + , 421 + , 422 + , 423 + , 424 + , 425 + , 426 + , 427 + , 428 + , 429 + , 430 + , 431 + , 432 + , 433 + , 434 + , 435 + , 436 + , 437 + , 438 + , 439 + , 440 + , 441 + , 442 + , 443 + , 444 + , 445 + , 446 + , 447 + , 448 + , 449 + , 450 + , 451 + , 452 + , 453 + , 454 + , 455 + , 456 + , 457 + , 458 + , 459 + , 460 + , 461 + , 462 + , 463 + , 464 + , 465 + , 466 + , 467 + , 468 + , 469 + , 470 + , 471 + , 472 + , 473 + , 474 + , 475 + , 476 + , 477 + , 478 + , 479 + , 480 + , 481 + , 482 + , 483 + , 484 + , 485 + , 486 + , 487 + , 488 + , 489 + , 490 + , 491 + , 492 + , 493 + , 494 + , 495 + , 496 + , 497 + , 498 + , 499 + , 500 + , 501 + , 502 + , 503 + , 504 + , 505 + , 506 + , 507 + , 508 + , 509 + , 510 + , 511 + , 512 + , 513 + , 514 + , 515 + , 516 + , 517 + , 518 + , 519 + , 520 + , 521 + , 522 + , 523 + , 524 + , 525 + , 526 + , 527 + , 528 + , 529 + , 530 + , 531 + , 532 + , 533 + , 534 + , 535 + , 536 + , 537 + , 538 + , 539 + , 540 + , 541 + , 542 + , 543 + , 544 + , 545 + , 546 + , 547 + , 548 + , 549 + , 550 + , 551 + , 552 + , 553 + , 554 + , 555 + , 556 + , 557 + , 558 + , 559 + , 560 + , 561 + , 562 + , 563 + , 564 + , 565 + , 566 + , 567 + , 568 + , 569 + , 570 + , 571 + , 572 + , 573 + , 574 + , 575 + , 576 + , 577 + , 578 + , 579 + , 580 + , 581 + , 582 + , 583 + , 584 + , 585 + , 586 + , 587 + , 588 + , 589 + , 590 + , 591 + , 592 + , 593 + , 594 + , 595 + , 596 + , 597 + , 598 + , 599 + , 600 + , 601 + , 602 + , 603 + , 604 + , 605 + , 606 + , 607 + , 608 + , 609 + , 610 + , 611 + , 612 + , 613 + , 614 + , 615 + , 616 + , 617 + , 618 + , 619 + , 620 + , 621 + , 622 + , 623 + , 624 + , 625 + , 626 + , 627 + , 628 + , 629 + , 630 + , 631 + , 632 + , 633 + , 634 + , 635 + , 636 + , 637 + , 638 + , 639 + , 640 + , 641 + , 642 + , 643 + , 644 + , 645 + , 646 + , 647 + , 648 + , 649 + , 650 + , 651 + , 652 + , 653 + , 654 + , 655 + , 656 + , 657 + , 658 + , 659 + , 660 + , 661 + , 662 + , 663 + , 664 + , 665 + , 666 + , 667 + , 668 + , 669 + , 670 + , 671 + , 672 + , 673 + , 674 + , 675 + , 676 + , 677 + , 678 + , 679 + , 680 + , 681 + , 682 + , 683 + , 684 + , 685 + , 686 + , 687 + , 688 + , 689 + , 690 + , 691 + , 692 + , 693 + , 694 + , 695 + , 696 + , 697 + , 698 + , 699 + , 700 + , 701 + , 702 + , 703 + , 704 + , 705 + , 706 + , 707 + , 708 + , 709 + , 710 + , 711 + , 712 + , 713 + , 714 + , 715 + , 716 + , 717 + , 718 + , 719 + , 720 + , 721 + , 722 + , 723 + , 724 + , 725 + , 726 + , 727 + , 728 + , 729 + , 730 + , 731 + , 732 + , 733 + , 734 + , 735 + , 736 + , 737 + , 738 + , 739 + , 740 + , 741 + , 742 + , 743 + , 744 + , 745 + , 746 + , 747 + , 748 + , 749 + , 750 + , 751 + , 752 + , 753 + , 754 + , 755 + , 756 + , 757 + , 758 + , 759 + , 760 + , 761 + , 762 + , 763 + , 764 + , 765 + , 766 + , 767 + , 768 + , 769 + , 770 + , 771 + , 772 + , 773 + , 774 + , 775 + , 776 + , 777 + , 778 + , 779 + , 780 + , 781 + , 782 + , 783 + , 784 + , 785 + , 786 + , 787 + , 788 + , 789 + , 790 + , 791 + , 792 + , 793 + , 794 + , 795 + , 796 + , 797 + , 798 + , 799 + , 800 + , 801 + , 802 + , 803 + , 804 + , 805 + , 806 + , 807 + , 808 + , 809 + , 810 + , 811 + , 812 + , 813 + , 814 + , 815 + , 816 + , 817 + , 818 + , 819 + , 820 + , 821 + , 822 + , 823 + , 824 + , 825 + , 826 + , 827 + , 828 + , 829 + , 830 + , 831 + , 832 + , 833 + , 834 + , 835 + , 836 + , 837 + , 838 + , 839 + , 840 + , 841 + , 842 + , 843 + , 844 + , 845 + , 846 + , 847 + , 848 + , 849 + , 850 + , 851 + , 852 + , 853 + , 854 + , 855 + , 856 + , 857 + , 858 + , 859 + , 860 + , 861 + , 862 + , 863 + , 864 + , 865 + , 866 + , 867 + , 868 + , 869 + , 870 + , 871 + , 872 + , 873 + , 874 + , 875 + , 876 + , 877 + , 878 + , 879 + , 880 + , 881 + , 882 + , 883 + , 884 + , 885 + , 886 + , 887 + , 888 + , 889 + , 890 + , 891 + , 892 + , 893 + , 894 + , 895 + , 896 + , 897 + , 898 + , 899 + , 900 + , 901 + , 902 + , 903 + , 904 + , 905 + , 906 + , 907 + , 908 + , 909 + , 910 + , 911 + , 912 + , 913 + , 914 + , 915 + , 916 + , 917 + , 918 + , 919 + , 920 + , 921 + , 922 + , 923 + , 924 + , 925 + , 926 + , 927 + , 928 + , 929 + , 930 + , 931 + , 932 + , 933 + , 934 + , 935 + , 936 + , 937 + , 938 + , 939 + , 940 + , 941 + , 942 + , 943 + , 944 + , 945 + , 946 + , 947 + , 948 + , 949 + , 950 + , 951 + , 952 + , 953 + , 954 + , 955 + , 956 + , 957 + , 958 + , 959 + , 960 + , 961 + , 962 + , 963 + , 964 + , 965 + , 966 + , 967 + , 968 + , 969 + , 970 + , 971 + , 972 + , 973 + , 974 + , 975 + , 976 + , 977 + , 978 + , 979 + , 980 + , 981 + , 982 + , 983 + , 984 + , 985 + , 986 + , 987 + , 988 + , 989 + , 990 + , 991 + , 992 + , 993 + , 994 + , 995 + , 996 + , 997 + , 998 + , 999 + , 1000 + , 1001 + , 1002 + , 1003 + , 1004 + , 1005 + , 1006 + , 1007 + , 1008 + , 1009 + , 1010 + , 1011 + , 1012 + , 1013 + , 1014 + , 1015 + , 1016 + , 1017 + , 1018 + , 1019 + , 1020 + , 1021 + , 1022 + , 1023 + , 1024 + , 1025 + , 1026 + , 1027 + , 1028 + , 1029 + , 1030 + , 1031 + , 1032 + , 1033 + , 1034 + , 1035 + , 1036 + , 1037 + , 1038 + , 1039 + , 1040 + , 1041 + , 1042 + , 1043 + , 1044 + , 1045 + , 1046 + , 1047 + , 1048 + , 1049 + , 1050 + , 1051 + , 1052 + , 1053 + , 1054 + , 1055 + , 1056 + , 1057 + , 1058 + , 1059 + , 1060 + , 1061 + , 1062 + , 1063 + , 1064 + , 1065 + , 1066 + , 1067 + , 1068 + , 1069 + , 1070 + , 1071 + , 1072 + , 1073 + , 1074 + , 1075 + , 1076 + , 1077 + , 1078 + , 1079 + , 1080 + , 1081 + , 1082 + , 1083 + , 1084 + , 1085 + , 1086 + , 1087 + , 1088 + , 1089 + , 1090 + , 1091 + , 1092 + , 1093 + , 1094 + , 1095 + , 1096 + , 1097 + , 1098 + , 1099 + , 1100 + , 1101 + , 1102 + , 1103 + , 1104 + , 1105 + , 1106 + , 1107 + , 1108 + , 1109 + , 1110 + , 1111 + , 1112 + , 1113 + , 1114 + , 1115 + , 1116 + , 1117 + , 1118 + , 1119 + , 1120 + , 1121 + , 1122 + , 1123 + , 1124 + , 1125 + , 1126 + , 1127 + , 1128 + , 1129 + , 1130 + , 1131 + , 1132 + , 1133 + , 1134 + , 1135 + , 1136 + , 1137 + , 1138 + , 1139 + , 1140 + , 1141 + , 1142 + , 1143 + , 1144 + , 1145 + , 1146 + , 1147 + , 1148 + , 1149 + , 1150 + , 1151 + , 1152 + , 1153 + , 1154 + , 1155 + , 1156 + , 1157 + , 1158 + , 1159 + , 1160 + , 1161 + , 1162 + , 1163 + , 1164 + , 1165 + , 1166 + , 1167 + , 1168 + , 1169 + , 1170 + , 1171 + , 1172 + , 1173 + , 1174 + , 1175 + , 1176 + , 1177 + , 1178 + , 1179 + , 1180 + , 1181 + , 1182 + , 1183 + , 1184 + , 1185 + , 1186 + , 1187 + , 1188 + , 1189 + , 1190 + , 1191 + , 1192 + , 1193 + , 1194 + , 1195 + , 1196 + , 1197 + , 1198 + , 1199 + , 1200 + , 1201 + , 1202 + , 1203 + , 1204 + , 1205 + , 1206 + , 1207 + , 1208 + , 1209 + , 1210 + , 1211 + , 1212 + , 1213 + , 1214 + , 1215 + , 1216 + , 1217 + , 1218 + , 1219 + , 1220 + , 1221 + , 1222 + , 1223 + , 1224 + , 1225 + , 1226 + , 1227 + , 1228 + , 1229 + , 1230 + , 1231 + , 1232 + , 1233 + , 1234 + , 1235 + , 1236 + , 1237 + , 1238 + , 1239 + , 1240 + , 1241 + , 1242 + , 1243 + , 1244 + , 1245 + , 1246 + , 1247 + , 1248 + , 1249 + , 1250 + , 1251 + , 1252 + , 1253 + , 1254 + , 1255 + , 1256 + , 1257 + , 1258 + , 1259 + , 1260 + , 1261 + , 1262 + , 1263 + , 1264 + , 1265 + , 1266 + , 1267 + , 1268 + , 1269 + , 1270 + , 1271 + , 1272 + , 1273 + , 1274 + , 1275 + , 1276 + , 1277 + , 1278 + , 1279 + , 1280 + , 1281 + , 1282 + , 1283 + , 1284 + , 1285 + , 1286 + , 1287 + , 1288 + , 1289 + , 1290 + , 1291 + , 1292 + , 1293 + , 1294 + , 1295 + , 1296 + , 1297 + , 1298 + , 1299 + , 1300 + , 1301 + , 1302 + , 1303 + , 1304 + , 1305 + , 1306 + , 1307 + , 1308 + , 1309 + , 1310 + , 1311 + , 1312 + , 1313 + , 1314 + , 1315 + , 1316 + , 1317 + , 1318 + , 1319 + , 1320 + , 1321 + , 1322 + , 1323 + , 1324 + , 1325 + , 1326 + , 1327 + , 1328 + , 1329 + , 1330 + , 1331 + , 1332 + , 1333 + , 1334 + , 1335 + , 1336 + , 1337 + , 1338 + , 1339 + , 1340 + , 1341 + , 1342 + , 1343 + , 1344 + , 1345 + , 1346 + , 1347 + , 1348 + , 1349 + , 1350 + , 1351 + , 1352 + , 1353 + , 1354 + , 1355 + , 1356 + , 1357 + , 1358 + , 1359 + , 1360 + , 1361 + , 1362 + , 1363 + , 1364 + , 1365 + , 1366 + , 1367 + , 1368 + , 1369 + , 1370 + , 1371 + , 1372 + , 1373 + , 1374 + , 1375 + , 1376 + , 1377 + , 1378 + , 1379 + , 1380 + , 1381 + , 1382 + , 1383 + , 1384 + , 1385 + , 1386 + , 1387 + , 1388 + , 1389 + , 1390 + , 1391 + , 1392 + , 1393 + , 1394 + , 1395 + , 1396 + , 1397 + , 1398 + , 1399 + , 1400 + , 1401 + , 1402 + , 1403 + , 1404 + , 1405 + , 1406 + , 1407 + , 1408 + , 1409 + , 1410 + , 1411 + , 1412 + , 1413 + , 1414 + , 1415 + , 1416 + , 1417 + , 1418 + , 1419 + , 1420 + , 1421 + , 1422 + , 1423 + , 1424 + , 1425 + , 1426 + , 1427 + , 1428 + , 1429 + , 1430 + , 1431 + , 1432 + , 1433 + , 1434 + , 1435 + , 1436 + , 1437 + , 1438 + , 1439 + , 1440 + , 1441 + , 1442 + , 1443 + , 1444 + , 1445 + , 1446 + , 1447 + , 1448 + , 1449 + , 1450 + , 1451 + , 1452 + , 1453 + , 1454 + , 1455 + , 1456 + , 1457 + , 1458 + , 1459 + , 1460 + , 1461 + , 1462 + , 1463 + , 1464 + , 1465 + , 1466 + , 1467 + , 1468 + , 1469 + , 1470 + , 1471 + , 1472 + , 1473 + , 1474 + , 1475 + , 1476 + , 1477 + , 1478 + , 1479 + , 1480 + , 1481 + , 1482 + , 1483 + , 1484 + , 1485 + , 1486 + , 1487 + , 1488 + , 1489 + , 1490 + , 1491 + , 1492 + , 1493 + , 1494 + , 1495 + , 1496 + , 1497 + , 1498 + , 1499 + , 1500 + , 1501 + , 1502 + , 1503 + , 1504 + , 1505 + , 1506 + , 1507 + , 1508 + , 1509 + , 1510 + , 1511 + , 1512 + , 1513 + , 1514 + , 1515 + , 1516 + , 1517 + , 1518 + , 1519 + , 1520 + , 1521 + , 1522 + , 1523 + , 1524 + , 1525 + , 1526 + , 1527 + , 1528 + , 1529 + , 1530 + , 1531 + , 1532 + , 1533 + , 1534 + , 1535 + , 1536 + , 1537 + , 1538 + , 1539 + , 1540 + , 1541 + , 1542 + , 1543 + , 1544 + , 1545 + , 1546 + , 1547 + , 1548 + , 1549 + , 1550 + , 1551 + , 1552 + , 1553 + , 1554 + , 1555 + , 1556 + , 1557 + , 1558 + , 1559 + , 1560 + , 1561 + , 1562 + , 1563 + , 1564 + , 1565 + , 1566 + , 1567 + , 1568 + , 1569 + , 1570 + , 1571 + , 1572 + , 1573 + , 1574 + , 1575 + , 1576 + , 1577 + , 1578 + , 1579 + , 1580 + , 1581 + , 1582 + , 1583 + , 1584 + , 1585 + , 1586 + , 1587 + , 1588 + , 1589 + , 1590 + , 1591 + , 1592 + , 1593 + , 1594 + , 1595 + , 1596 + , 1597 + , 1598 + , 1599 + , 1600 + , 1601 + , 1602 + , 1603 + , 1604 + , 1605 + , 1606 + , 1607 + , 1608 + , 1609 + , 1610 + , 1611 + , 1612 + , 1613 + , 1614 + , 1615 + , 1616 + , 1617 + , 1618 + , 1619 + , 1620 + , 1621 + , 1622 + , 1623 + , 1624 + , 1625 + , 1626 + , 1627 + , 1628 + , 1629 + , 1630 + , 1631 + , 1632 + , 1633 + , 1634 + , 1635 + , 1636 + , 1637 + , 1638 + , 1639 + , 1640 + , 1641 + , 1642 + , 1643 + , 1644 + , 1645 + , 1646 + , 1647 + , 1648 + , 1649 + , 1650 + , 1651 + , 1652 + , 1653 + , 1654 + , 1655 + , 1656 + , 1657 + , 1658 + , 1659 + , 1660 + , 1661 + , 1662 + , 1663 + , 1664 + , 1665 + , 1666 + , 1667 + , 1668 + , 1669 + , 1670 + , 1671 + , 1672 + , 1673 + , 1674 + , 1675 + , 1676 + , 1677 + , 1678 + , 1679 + , 1680 + , 1681 + , 1682 + , 1683 + , 1684 + , 1685 + , 1686 + , 1687 + , 1688 + , 1689 + , 1690 + , 1691 + , 1692 + , 1693 + , 1694 + , 1695 + , 1696 + , 1697 + , 1698 + , 1699 + , 1700 + , 1701 + , 1702 + , 1703 + , 1704 + , 1705 + , 1706 + , 1707 + , 1708 + , 1709 + , 1710 + , 1711 + , 1712 + , 1713 + , 1714 + , 1715 + , 1716 + , 1717 + , 1718 + , 1719 + , 1720 + , 1721 + , 1722 + , 1723 + , 1724 + , 1725 + , 1726 + , 1727 + , 1728 + , 1729 + , 1730 + , 1731 + , 1732 + , 1733 + , 1734 + , 1735 + , 1736 + , 1737 + , 1738 + , 1739 + , 1740 + , 1741 + , 1742 + , 1743 + , 1744 + , 1745 + , 1746 + , 1747 + , 1748 + , 1749 + , 1750 + , 1751 + , 1752 + , 1753 + , 1754 + , 1755 + , 1756 + , 1757 + , 1758 + , 1759 + , 1760 + , 1761 + , 1762 + , 1763 + , 1764 + , 1765 + , 1766 + , 1767 + , 1768 + , 1769 + , 1770 + , 1771 + , 1772 + , 1773 + , 1774 + , 1775 + , 1776 + , 1777 + , 1778 + , 1779 + , 1780 + , 1781 + , 1782 + , 1783 + , 1784 + , 1785 + , 1786 + , 1787 + , 1788 + , 1789 + , 1790 + , 1791 + , 1792 + , 1793 + , 1794 + , 1795 + , 1796 + , 1797 + , 1798 + , 1799 + , 1800 + , 1801 + , 1802 + , 1803 + , 1804 + , 1805 + , 1806 + , 1807 + , 1808 + , 1809 + , 1810 + , 1811 + , 1812 + , 1813 + , 1814 + , 1815 + , 1816 + , 1817 + , 1818 + , 1819 + , 1820 + , 1821 + , 1822 + , 1823 + , 1824 + , 1825 + , 1826 + , 1827 + , 1828 + , 1829 + , 1830 + , 1831 + , 1832 + , 1833 + , 1834 + , 1835 + , 1836 + , 1837 + , 1838 + , 1839 + , 1840 + , 1841 + , 1842 + , 1843 + , 1844 + , 1845 + , 1846 + , 1847 + , 1848 + , 1849 + , 1850 + , 1851 + , 1852 + , 1853 + , 1854 + , 1855 + , 1856 + , 1857 + , 1858 + , 1859 + , 1860 + , 1861 + , 1862 + , 1863 + , 1864 + , 1865 + , 1866 + , 1867 + , 1868 + , 1869 + , 1870 + , 1871 + , 1872 + , 1873 + , 1874 + , 1875 + , 1876 + , 1877 + , 1878 + , 1879 + , 1880 + , 1881 + , 1882 + , 1883 + , 1884 + , 1885 + , 1886 + , 1887 + , 1888 + , 1889 + , 1890 + , 1891 + , 1892 + , 1893 + , 1894 + , 1895 + , 1896 + , 1897 + , 1898 + , 1899 + , 1900 + , 1901 + , 1902 + , 1903 + , 1904 + , 1905 + , 1906 + , 1907 + , 1908 + , 1909 + , 1910 + , 1911 + , 1912 + , 1913 + , 1914 + , 1915 + , 1916 + , 1917 + , 1918 + , 1919 + , 1920 + , 1921 + , 1922 + , 1923 + , 1924 + , 1925 + , 1926 + , 1927 + , 1928 + , 1929 + , 1930 + , 1931 + , 1932 + , 1933 + , 1934 + , 1935 + , 1936 + , 1937 + , 1938 + , 1939 + , 1940 + , 1941 + , 1942 + , 1943 + , 1944 + , 1945 + , 1946 + , 1947 + , 1948 + , 1949 + , 1950 + , 1951 + , 1952 + , 1953 + , 1954 + , 1955 + , 1956 + , 1957 + , 1958 + , 1959 + , 1960 + , 1961 + , 1962 + , 1963 + , 1964 + , 1965 + , 1966 + , 1967 + , 1968 + , 1969 + , 1970 + , 1971 + , 1972 + , 1973 + , 1974 + , 1975 + , 1976 + , 1977 + , 1978 + , 1979 + , 1980 + , 1981 + , 1982 + , 1983 + , 1984 + , 1985 + , 1986 + , 1987 + , 1988 + , 1989 + , 1990 + , 1991 + , 1992 + , 1993 + , 1994 + , 1995 + , 1996 + , 1997 + , 1998 + , 1999 + , 2000 + ] +``` + +Should be cached: + +``` unison +> range 2000 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > range 2000 + ⧩ + [ 1 + , 2 + , 3 + , 4 + , 5 + , 6 + , 7 + , 8 + , 9 + , 10 + , 11 + , 12 + , 13 + , 14 + , 15 + , 16 + , 17 + , 18 + , 19 + , 20 + , 21 + , 22 + , 23 + , 24 + , 25 + , 26 + , 27 + , 28 + , 29 + , 30 + , 31 + , 32 + , 33 + , 34 + , 35 + , 36 + , 37 + , 38 + , 39 + , 40 + , 41 + , 42 + , 43 + , 44 + , 45 + , 46 + , 47 + , 48 + , 49 + , 50 + , 51 + , 52 + , 53 + , 54 + , 55 + , 56 + , 57 + , 58 + , 59 + , 60 + , 61 + , 62 + , 63 + , 64 + , 65 + , 66 + , 67 + , 68 + , 69 + , 70 + , 71 + , 72 + , 73 + , 74 + , 75 + , 76 + , 77 + , 78 + , 79 + , 80 + , 81 + , 82 + , 83 + , 84 + , 85 + , 86 + , 87 + , 88 + , 89 + , 90 + , 91 + , 92 + , 93 + , 94 + , 95 + , 96 + , 97 + , 98 + , 99 + , 100 + , 101 + , 102 + , 103 + , 104 + , 105 + , 106 + , 107 + , 108 + , 109 + , 110 + , 111 + , 112 + , 113 + , 114 + , 115 + , 116 + , 117 + , 118 + , 119 + , 120 + , 121 + , 122 + , 123 + , 124 + , 125 + , 126 + , 127 + , 128 + , 129 + , 130 + , 131 + , 132 + , 133 + , 134 + , 135 + , 136 + , 137 + , 138 + , 139 + , 140 + , 141 + , 142 + , 143 + , 144 + , 145 + , 146 + , 147 + , 148 + , 149 + , 150 + , 151 + , 152 + , 153 + , 154 + , 155 + , 156 + , 157 + , 158 + , 159 + , 160 + , 161 + , 162 + , 163 + , 164 + , 165 + , 166 + , 167 + , 168 + , 169 + , 170 + , 171 + , 172 + , 173 + , 174 + , 175 + , 176 + , 177 + , 178 + , 179 + , 180 + , 181 + , 182 + , 183 + , 184 + , 185 + , 186 + , 187 + , 188 + , 189 + , 190 + , 191 + , 192 + , 193 + , 194 + , 195 + , 196 + , 197 + , 198 + , 199 + , 200 + , 201 + , 202 + , 203 + , 204 + , 205 + , 206 + , 207 + , 208 + , 209 + , 210 + , 211 + , 212 + , 213 + , 214 + , 215 + , 216 + , 217 + , 218 + , 219 + , 220 + , 221 + , 222 + , 223 + , 224 + , 225 + , 226 + , 227 + , 228 + , 229 + , 230 + , 231 + , 232 + , 233 + , 234 + , 235 + , 236 + , 237 + , 238 + , 239 + , 240 + , 241 + , 242 + , 243 + , 244 + , 245 + , 246 + , 247 + , 248 + , 249 + , 250 + , 251 + , 252 + , 253 + , 254 + , 255 + , 256 + , 257 + , 258 + , 259 + , 260 + , 261 + , 262 + , 263 + , 264 + , 265 + , 266 + , 267 + , 268 + , 269 + , 270 + , 271 + , 272 + , 273 + , 274 + , 275 + , 276 + , 277 + , 278 + , 279 + , 280 + , 281 + , 282 + , 283 + , 284 + , 285 + , 286 + , 287 + , 288 + , 289 + , 290 + , 291 + , 292 + , 293 + , 294 + , 295 + , 296 + , 297 + , 298 + , 299 + , 300 + , 301 + , 302 + , 303 + , 304 + , 305 + , 306 + , 307 + , 308 + , 309 + , 310 + , 311 + , 312 + , 313 + , 314 + , 315 + , 316 + , 317 + , 318 + , 319 + , 320 + , 321 + , 322 + , 323 + , 324 + , 325 + , 326 + , 327 + , 328 + , 329 + , 330 + , 331 + , 332 + , 333 + , 334 + , 335 + , 336 + , 337 + , 338 + , 339 + , 340 + , 341 + , 342 + , 343 + , 344 + , 345 + , 346 + , 347 + , 348 + , 349 + , 350 + , 351 + , 352 + , 353 + , 354 + , 355 + , 356 + , 357 + , 358 + , 359 + , 360 + , 361 + , 362 + , 363 + , 364 + , 365 + , 366 + , 367 + , 368 + , 369 + , 370 + , 371 + , 372 + , 373 + , 374 + , 375 + , 376 + , 377 + , 378 + , 379 + , 380 + , 381 + , 382 + , 383 + , 384 + , 385 + , 386 + , 387 + , 388 + , 389 + , 390 + , 391 + , 392 + , 393 + , 394 + , 395 + , 396 + , 397 + , 398 + , 399 + , 400 + , 401 + , 402 + , 403 + , 404 + , 405 + , 406 + , 407 + , 408 + , 409 + , 410 + , 411 + , 412 + , 413 + , 414 + , 415 + , 416 + , 417 + , 418 + , 419 + , 420 + , 421 + , 422 + , 423 + , 424 + , 425 + , 426 + , 427 + , 428 + , 429 + , 430 + , 431 + , 432 + , 433 + , 434 + , 435 + , 436 + , 437 + , 438 + , 439 + , 440 + , 441 + , 442 + , 443 + , 444 + , 445 + , 446 + , 447 + , 448 + , 449 + , 450 + , 451 + , 452 + , 453 + , 454 + , 455 + , 456 + , 457 + , 458 + , 459 + , 460 + , 461 + , 462 + , 463 + , 464 + , 465 + , 466 + , 467 + , 468 + , 469 + , 470 + , 471 + , 472 + , 473 + , 474 + , 475 + , 476 + , 477 + , 478 + , 479 + , 480 + , 481 + , 482 + , 483 + , 484 + , 485 + , 486 + , 487 + , 488 + , 489 + , 490 + , 491 + , 492 + , 493 + , 494 + , 495 + , 496 + , 497 + , 498 + , 499 + , 500 + , 501 + , 502 + , 503 + , 504 + , 505 + , 506 + , 507 + , 508 + , 509 + , 510 + , 511 + , 512 + , 513 + , 514 + , 515 + , 516 + , 517 + , 518 + , 519 + , 520 + , 521 + , 522 + , 523 + , 524 + , 525 + , 526 + , 527 + , 528 + , 529 + , 530 + , 531 + , 532 + , 533 + , 534 + , 535 + , 536 + , 537 + , 538 + , 539 + , 540 + , 541 + , 542 + , 543 + , 544 + , 545 + , 546 + , 547 + , 548 + , 549 + , 550 + , 551 + , 552 + , 553 + , 554 + , 555 + , 556 + , 557 + , 558 + , 559 + , 560 + , 561 + , 562 + , 563 + , 564 + , 565 + , 566 + , 567 + , 568 + , 569 + , 570 + , 571 + , 572 + , 573 + , 574 + , 575 + , 576 + , 577 + , 578 + , 579 + , 580 + , 581 + , 582 + , 583 + , 584 + , 585 + , 586 + , 587 + , 588 + , 589 + , 590 + , 591 + , 592 + , 593 + , 594 + , 595 + , 596 + , 597 + , 598 + , 599 + , 600 + , 601 + , 602 + , 603 + , 604 + , 605 + , 606 + , 607 + , 608 + , 609 + , 610 + , 611 + , 612 + , 613 + , 614 + , 615 + , 616 + , 617 + , 618 + , 619 + , 620 + , 621 + , 622 + , 623 + , 624 + , 625 + , 626 + , 627 + , 628 + , 629 + , 630 + , 631 + , 632 + , 633 + , 634 + , 635 + , 636 + , 637 + , 638 + , 639 + , 640 + , 641 + , 642 + , 643 + , 644 + , 645 + , 646 + , 647 + , 648 + , 649 + , 650 + , 651 + , 652 + , 653 + , 654 + , 655 + , 656 + , 657 + , 658 + , 659 + , 660 + , 661 + , 662 + , 663 + , 664 + , 665 + , 666 + , 667 + , 668 + , 669 + , 670 + , 671 + , 672 + , 673 + , 674 + , 675 + , 676 + , 677 + , 678 + , 679 + , 680 + , 681 + , 682 + , 683 + , 684 + , 685 + , 686 + , 687 + , 688 + , 689 + , 690 + , 691 + , 692 + , 693 + , 694 + , 695 + , 696 + , 697 + , 698 + , 699 + , 700 + , 701 + , 702 + , 703 + , 704 + , 705 + , 706 + , 707 + , 708 + , 709 + , 710 + , 711 + , 712 + , 713 + , 714 + , 715 + , 716 + , 717 + , 718 + , 719 + , 720 + , 721 + , 722 + , 723 + , 724 + , 725 + , 726 + , 727 + , 728 + , 729 + , 730 + , 731 + , 732 + , 733 + , 734 + , 735 + , 736 + , 737 + , 738 + , 739 + , 740 + , 741 + , 742 + , 743 + , 744 + , 745 + , 746 + , 747 + , 748 + , 749 + , 750 + , 751 + , 752 + , 753 + , 754 + , 755 + , 756 + , 757 + , 758 + , 759 + , 760 + , 761 + , 762 + , 763 + , 764 + , 765 + , 766 + , 767 + , 768 + , 769 + , 770 + , 771 + , 772 + , 773 + , 774 + , 775 + , 776 + , 777 + , 778 + , 779 + , 780 + , 781 + , 782 + , 783 + , 784 + , 785 + , 786 + , 787 + , 788 + , 789 + , 790 + , 791 + , 792 + , 793 + , 794 + , 795 + , 796 + , 797 + , 798 + , 799 + , 800 + , 801 + , 802 + , 803 + , 804 + , 805 + , 806 + , 807 + , 808 + , 809 + , 810 + , 811 + , 812 + , 813 + , 814 + , 815 + , 816 + , 817 + , 818 + , 819 + , 820 + , 821 + , 822 + , 823 + , 824 + , 825 + , 826 + , 827 + , 828 + , 829 + , 830 + , 831 + , 832 + , 833 + , 834 + , 835 + , 836 + , 837 + , 838 + , 839 + , 840 + , 841 + , 842 + , 843 + , 844 + , 845 + , 846 + , 847 + , 848 + , 849 + , 850 + , 851 + , 852 + , 853 + , 854 + , 855 + , 856 + , 857 + , 858 + , 859 + , 860 + , 861 + , 862 + , 863 + , 864 + , 865 + , 866 + , 867 + , 868 + , 869 + , 870 + , 871 + , 872 + , 873 + , 874 + , 875 + , 876 + , 877 + , 878 + , 879 + , 880 + , 881 + , 882 + , 883 + , 884 + , 885 + , 886 + , 887 + , 888 + , 889 + , 890 + , 891 + , 892 + , 893 + , 894 + , 895 + , 896 + , 897 + , 898 + , 899 + , 900 + , 901 + , 902 + , 903 + , 904 + , 905 + , 906 + , 907 + , 908 + , 909 + , 910 + , 911 + , 912 + , 913 + , 914 + , 915 + , 916 + , 917 + , 918 + , 919 + , 920 + , 921 + , 922 + , 923 + , 924 + , 925 + , 926 + , 927 + , 928 + , 929 + , 930 + , 931 + , 932 + , 933 + , 934 + , 935 + , 936 + , 937 + , 938 + , 939 + , 940 + , 941 + , 942 + , 943 + , 944 + , 945 + , 946 + , 947 + , 948 + , 949 + , 950 + , 951 + , 952 + , 953 + , 954 + , 955 + , 956 + , 957 + , 958 + , 959 + , 960 + , 961 + , 962 + , 963 + , 964 + , 965 + , 966 + , 967 + , 968 + , 969 + , 970 + , 971 + , 972 + , 973 + , 974 + , 975 + , 976 + , 977 + , 978 + , 979 + , 980 + , 981 + , 982 + , 983 + , 984 + , 985 + , 986 + , 987 + , 988 + , 989 + , 990 + , 991 + , 992 + , 993 + , 994 + , 995 + , 996 + , 997 + , 998 + , 999 + , 1000 + , 1001 + , 1002 + , 1003 + , 1004 + , 1005 + , 1006 + , 1007 + , 1008 + , 1009 + , 1010 + , 1011 + , 1012 + , 1013 + , 1014 + , 1015 + , 1016 + , 1017 + , 1018 + , 1019 + , 1020 + , 1021 + , 1022 + , 1023 + , 1024 + , 1025 + , 1026 + , 1027 + , 1028 + , 1029 + , 1030 + , 1031 + , 1032 + , 1033 + , 1034 + , 1035 + , 1036 + , 1037 + , 1038 + , 1039 + , 1040 + , 1041 + , 1042 + , 1043 + , 1044 + , 1045 + , 1046 + , 1047 + , 1048 + , 1049 + , 1050 + , 1051 + , 1052 + , 1053 + , 1054 + , 1055 + , 1056 + , 1057 + , 1058 + , 1059 + , 1060 + , 1061 + , 1062 + , 1063 + , 1064 + , 1065 + , 1066 + , 1067 + , 1068 + , 1069 + , 1070 + , 1071 + , 1072 + , 1073 + , 1074 + , 1075 + , 1076 + , 1077 + , 1078 + , 1079 + , 1080 + , 1081 + , 1082 + , 1083 + , 1084 + , 1085 + , 1086 + , 1087 + , 1088 + , 1089 + , 1090 + , 1091 + , 1092 + , 1093 + , 1094 + , 1095 + , 1096 + , 1097 + , 1098 + , 1099 + , 1100 + , 1101 + , 1102 + , 1103 + , 1104 + , 1105 + , 1106 + , 1107 + , 1108 + , 1109 + , 1110 + , 1111 + , 1112 + , 1113 + , 1114 + , 1115 + , 1116 + , 1117 + , 1118 + , 1119 + , 1120 + , 1121 + , 1122 + , 1123 + , 1124 + , 1125 + , 1126 + , 1127 + , 1128 + , 1129 + , 1130 + , 1131 + , 1132 + , 1133 + , 1134 + , 1135 + , 1136 + , 1137 + , 1138 + , 1139 + , 1140 + , 1141 + , 1142 + , 1143 + , 1144 + , 1145 + , 1146 + , 1147 + , 1148 + , 1149 + , 1150 + , 1151 + , 1152 + , 1153 + , 1154 + , 1155 + , 1156 + , 1157 + , 1158 + , 1159 + , 1160 + , 1161 + , 1162 + , 1163 + , 1164 + , 1165 + , 1166 + , 1167 + , 1168 + , 1169 + , 1170 + , 1171 + , 1172 + , 1173 + , 1174 + , 1175 + , 1176 + , 1177 + , 1178 + , 1179 + , 1180 + , 1181 + , 1182 + , 1183 + , 1184 + , 1185 + , 1186 + , 1187 + , 1188 + , 1189 + , 1190 + , 1191 + , 1192 + , 1193 + , 1194 + , 1195 + , 1196 + , 1197 + , 1198 + , 1199 + , 1200 + , 1201 + , 1202 + , 1203 + , 1204 + , 1205 + , 1206 + , 1207 + , 1208 + , 1209 + , 1210 + , 1211 + , 1212 + , 1213 + , 1214 + , 1215 + , 1216 + , 1217 + , 1218 + , 1219 + , 1220 + , 1221 + , 1222 + , 1223 + , 1224 + , 1225 + , 1226 + , 1227 + , 1228 + , 1229 + , 1230 + , 1231 + , 1232 + , 1233 + , 1234 + , 1235 + , 1236 + , 1237 + , 1238 + , 1239 + , 1240 + , 1241 + , 1242 + , 1243 + , 1244 + , 1245 + , 1246 + , 1247 + , 1248 + , 1249 + , 1250 + , 1251 + , 1252 + , 1253 + , 1254 + , 1255 + , 1256 + , 1257 + , 1258 + , 1259 + , 1260 + , 1261 + , 1262 + , 1263 + , 1264 + , 1265 + , 1266 + , 1267 + , 1268 + , 1269 + , 1270 + , 1271 + , 1272 + , 1273 + , 1274 + , 1275 + , 1276 + , 1277 + , 1278 + , 1279 + , 1280 + , 1281 + , 1282 + , 1283 + , 1284 + , 1285 + , 1286 + , 1287 + , 1288 + , 1289 + , 1290 + , 1291 + , 1292 + , 1293 + , 1294 + , 1295 + , 1296 + , 1297 + , 1298 + , 1299 + , 1300 + , 1301 + , 1302 + , 1303 + , 1304 + , 1305 + , 1306 + , 1307 + , 1308 + , 1309 + , 1310 + , 1311 + , 1312 + , 1313 + , 1314 + , 1315 + , 1316 + , 1317 + , 1318 + , 1319 + , 1320 + , 1321 + , 1322 + , 1323 + , 1324 + , 1325 + , 1326 + , 1327 + , 1328 + , 1329 + , 1330 + , 1331 + , 1332 + , 1333 + , 1334 + , 1335 + , 1336 + , 1337 + , 1338 + , 1339 + , 1340 + , 1341 + , 1342 + , 1343 + , 1344 + , 1345 + , 1346 + , 1347 + , 1348 + , 1349 + , 1350 + , 1351 + , 1352 + , 1353 + , 1354 + , 1355 + , 1356 + , 1357 + , 1358 + , 1359 + , 1360 + , 1361 + , 1362 + , 1363 + , 1364 + , 1365 + , 1366 + , 1367 + , 1368 + , 1369 + , 1370 + , 1371 + , 1372 + , 1373 + , 1374 + , 1375 + , 1376 + , 1377 + , 1378 + , 1379 + , 1380 + , 1381 + , 1382 + , 1383 + , 1384 + , 1385 + , 1386 + , 1387 + , 1388 + , 1389 + , 1390 + , 1391 + , 1392 + , 1393 + , 1394 + , 1395 + , 1396 + , 1397 + , 1398 + , 1399 + , 1400 + , 1401 + , 1402 + , 1403 + , 1404 + , 1405 + , 1406 + , 1407 + , 1408 + , 1409 + , 1410 + , 1411 + , 1412 + , 1413 + , 1414 + , 1415 + , 1416 + , 1417 + , 1418 + , 1419 + , 1420 + , 1421 + , 1422 + , 1423 + , 1424 + , 1425 + , 1426 + , 1427 + , 1428 + , 1429 + , 1430 + , 1431 + , 1432 + , 1433 + , 1434 + , 1435 + , 1436 + , 1437 + , 1438 + , 1439 + , 1440 + , 1441 + , 1442 + , 1443 + , 1444 + , 1445 + , 1446 + , 1447 + , 1448 + , 1449 + , 1450 + , 1451 + , 1452 + , 1453 + , 1454 + , 1455 + , 1456 + , 1457 + , 1458 + , 1459 + , 1460 + , 1461 + , 1462 + , 1463 + , 1464 + , 1465 + , 1466 + , 1467 + , 1468 + , 1469 + , 1470 + , 1471 + , 1472 + , 1473 + , 1474 + , 1475 + , 1476 + , 1477 + , 1478 + , 1479 + , 1480 + , 1481 + , 1482 + , 1483 + , 1484 + , 1485 + , 1486 + , 1487 + , 1488 + , 1489 + , 1490 + , 1491 + , 1492 + , 1493 + , 1494 + , 1495 + , 1496 + , 1497 + , 1498 + , 1499 + , 1500 + , 1501 + , 1502 + , 1503 + , 1504 + , 1505 + , 1506 + , 1507 + , 1508 + , 1509 + , 1510 + , 1511 + , 1512 + , 1513 + , 1514 + , 1515 + , 1516 + , 1517 + , 1518 + , 1519 + , 1520 + , 1521 + , 1522 + , 1523 + , 1524 + , 1525 + , 1526 + , 1527 + , 1528 + , 1529 + , 1530 + , 1531 + , 1532 + , 1533 + , 1534 + , 1535 + , 1536 + , 1537 + , 1538 + , 1539 + , 1540 + , 1541 + , 1542 + , 1543 + , 1544 + , 1545 + , 1546 + , 1547 + , 1548 + , 1549 + , 1550 + , 1551 + , 1552 + , 1553 + , 1554 + , 1555 + , 1556 + , 1557 + , 1558 + , 1559 + , 1560 + , 1561 + , 1562 + , 1563 + , 1564 + , 1565 + , 1566 + , 1567 + , 1568 + , 1569 + , 1570 + , 1571 + , 1572 + , 1573 + , 1574 + , 1575 + , 1576 + , 1577 + , 1578 + , 1579 + , 1580 + , 1581 + , 1582 + , 1583 + , 1584 + , 1585 + , 1586 + , 1587 + , 1588 + , 1589 + , 1590 + , 1591 + , 1592 + , 1593 + , 1594 + , 1595 + , 1596 + , 1597 + , 1598 + , 1599 + , 1600 + , 1601 + , 1602 + , 1603 + , 1604 + , 1605 + , 1606 + , 1607 + , 1608 + , 1609 + , 1610 + , 1611 + , 1612 + , 1613 + , 1614 + , 1615 + , 1616 + , 1617 + , 1618 + , 1619 + , 1620 + , 1621 + , 1622 + , 1623 + , 1624 + , 1625 + , 1626 + , 1627 + , 1628 + , 1629 + , 1630 + , 1631 + , 1632 + , 1633 + , 1634 + , 1635 + , 1636 + , 1637 + , 1638 + , 1639 + , 1640 + , 1641 + , 1642 + , 1643 + , 1644 + , 1645 + , 1646 + , 1647 + , 1648 + , 1649 + , 1650 + , 1651 + , 1652 + , 1653 + , 1654 + , 1655 + , 1656 + , 1657 + , 1658 + , 1659 + , 1660 + , 1661 + , 1662 + , 1663 + , 1664 + , 1665 + , 1666 + , 1667 + , 1668 + , 1669 + , 1670 + , 1671 + , 1672 + , 1673 + , 1674 + , 1675 + , 1676 + , 1677 + , 1678 + , 1679 + , 1680 + , 1681 + , 1682 + , 1683 + , 1684 + , 1685 + , 1686 + , 1687 + , 1688 + , 1689 + , 1690 + , 1691 + , 1692 + , 1693 + , 1694 + , 1695 + , 1696 + , 1697 + , 1698 + , 1699 + , 1700 + , 1701 + , 1702 + , 1703 + , 1704 + , 1705 + , 1706 + , 1707 + , 1708 + , 1709 + , 1710 + , 1711 + , 1712 + , 1713 + , 1714 + , 1715 + , 1716 + , 1717 + , 1718 + , 1719 + , 1720 + , 1721 + , 1722 + , 1723 + , 1724 + , 1725 + , 1726 + , 1727 + , 1728 + , 1729 + , 1730 + , 1731 + , 1732 + , 1733 + , 1734 + , 1735 + , 1736 + , 1737 + , 1738 + , 1739 + , 1740 + , 1741 + , 1742 + , 1743 + , 1744 + , 1745 + , 1746 + , 1747 + , 1748 + , 1749 + , 1750 + , 1751 + , 1752 + , 1753 + , 1754 + , 1755 + , 1756 + , 1757 + , 1758 + , 1759 + , 1760 + , 1761 + , 1762 + , 1763 + , 1764 + , 1765 + , 1766 + , 1767 + , 1768 + , 1769 + , 1770 + , 1771 + , 1772 + , 1773 + , 1774 + , 1775 + , 1776 + , 1777 + , 1778 + , 1779 + , 1780 + , 1781 + , 1782 + , 1783 + , 1784 + , 1785 + , 1786 + , 1787 + , 1788 + , 1789 + , 1790 + , 1791 + , 1792 + , 1793 + , 1794 + , 1795 + , 1796 + , 1797 + , 1798 + , 1799 + , 1800 + , 1801 + , 1802 + , 1803 + , 1804 + , 1805 + , 1806 + , 1807 + , 1808 + , 1809 + , 1810 + , 1811 + , 1812 + , 1813 + , 1814 + , 1815 + , 1816 + , 1817 + , 1818 + , 1819 + , 1820 + , 1821 + , 1822 + , 1823 + , 1824 + , 1825 + , 1826 + , 1827 + , 1828 + , 1829 + , 1830 + , 1831 + , 1832 + , 1833 + , 1834 + , 1835 + , 1836 + , 1837 + , 1838 + , 1839 + , 1840 + , 1841 + , 1842 + , 1843 + , 1844 + , 1845 + , 1846 + , 1847 + , 1848 + , 1849 + , 1850 + , 1851 + , 1852 + , 1853 + , 1854 + , 1855 + , 1856 + , 1857 + , 1858 + , 1859 + , 1860 + , 1861 + , 1862 + , 1863 + , 1864 + , 1865 + , 1866 + , 1867 + , 1868 + , 1869 + , 1870 + , 1871 + , 1872 + , 1873 + , 1874 + , 1875 + , 1876 + , 1877 + , 1878 + , 1879 + , 1880 + , 1881 + , 1882 + , 1883 + , 1884 + , 1885 + , 1886 + , 1887 + , 1888 + , 1889 + , 1890 + , 1891 + , 1892 + , 1893 + , 1894 + , 1895 + , 1896 + , 1897 + , 1898 + , 1899 + , 1900 + , 1901 + , 1902 + , 1903 + , 1904 + , 1905 + , 1906 + , 1907 + , 1908 + , 1909 + , 1910 + , 1911 + , 1912 + , 1913 + , 1914 + , 1915 + , 1916 + , 1917 + , 1918 + , 1919 + , 1920 + , 1921 + , 1922 + , 1923 + , 1924 + , 1925 + , 1926 + , 1927 + , 1928 + , 1929 + , 1930 + , 1931 + , 1932 + , 1933 + , 1934 + , 1935 + , 1936 + , 1937 + , 1938 + , 1939 + , 1940 + , 1941 + , 1942 + , 1943 + , 1944 + , 1945 + , 1946 + , 1947 + , 1948 + , 1949 + , 1950 + , 1951 + , 1952 + , 1953 + , 1954 + , 1955 + , 1956 + , 1957 + , 1958 + , 1959 + , 1960 + , 1961 + , 1962 + , 1963 + , 1964 + , 1965 + , 1966 + , 1967 + , 1968 + , 1969 + , 1970 + , 1971 + , 1972 + , 1973 + , 1974 + , 1975 + , 1976 + , 1977 + , 1978 + , 1979 + , 1980 + , 1981 + , 1982 + , 1983 + , 1984 + , 1985 + , 1986 + , 1987 + , 1988 + , 1989 + , 1990 + , 1991 + , 1992 + , 1993 + , 1994 + , 1995 + , 1996 + , 1997 + , 1998 + , 1999 + , 2000 + ] +``` diff --git a/unison-src/transcripts/idempotent/fix2712.md b/unison-src/transcripts/idempotent/fix2712.md new file mode 100644 index 0000000000..88e111877a --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2712.md @@ -0,0 +1,57 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +unique type Map k v = Tip | Bin Nat k v (Map k v) (Map k v) + +mapWithKey : (k ->{e} a ->{e} b) -> Map k a ->{e} Map k b +mapWithKey f m = Tip +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Map k v + mapWithKey : (k ->{e} a ->{e} b) -> Map k a ->{e} Map k b +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Map k v + mapWithKey : (k ->{e} a ->{e} b) -> Map k a ->{e} Map k b +``` + +``` unison + +naiomi = + susan: Nat -> Nat -> () + susan a b = () + + pam: Map Nat Nat + pam = Tip + + mapWithKey susan pam + +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + naiomi : Map Nat () +``` diff --git a/unison-src/transcripts/idempotent/fix2795.md b/unison-src/transcripts/idempotent/fix2795.md new file mode 100644 index 0000000000..ff161f91d7 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2795.md @@ -0,0 +1,46 @@ +``` ucm +scratch/main> builtins.mergeio + + Done. +``` + +```` unison +test = {{ + ``` + t : Text + t = "hi" + + t + ``` + @source{t1} + +}} + +t1 = "hi" +```` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + t1 : Text + test : Doc2 +``` + +``` ucm +scratch/main> display test + + t : Text + t = "hi" + t + ⧨ + "hi" + + t1 : Text + t1 = "hi" +``` diff --git a/unison-src/transcripts/idempotent/fix2822.md b/unison-src/transcripts/idempotent/fix2822.md new file mode 100644 index 0000000000..95e396946a --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2822.md @@ -0,0 +1,138 @@ +# Inability to reference a term or type with a name that has segments starting with an underscore + +``` ucm :hide +scratch/main> builtins.mergeio +``` + +There should be no issue having terms with an underscore-led component + +``` unison +_a.blah = 2 + +b = _a.blah + 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + _a.blah : Nat + b : Nat +``` + +Or even that *are* a single “blank” component + +``` unison +_b = 2 + +x = _b + 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + _b : Nat + x : Nat +``` + +Types can also have underscore-led components. + +``` unison +unique type _a.Blah = A + +c : _a.Blah +c = A +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type _a.Blah + c : Blah +``` + +And we should also be able to access underscore-led fields. + +``` unison +type Hello = {_value : Nat} + +doStuff = _value.modify +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Hello + Hello._value : Hello -> Nat + Hello._value.modify : (Nat ->{g} Nat) -> Hello ->{g} Hello + Hello._value.set : Nat -> Hello -> Hello + doStuff : (Nat ->{g} Nat) -> Hello ->{g} Hello +``` + +But pattern matching shouldn’t bind to underscore-led names. + +``` unison :error +dontMap f = cases + None -> false + Some _used -> f _used +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I couldn't figure out what _used refers to here: + + 3 | Some _used -> f _used + + I also don't know what type it should be. + + Some common causes of this error include: + * Your current namespace is too deep to contain the + definition in its subtree + * The definition is part of a library which hasn't been + added to this project + * You have a typo in the name +``` + +But we can use them as unbound patterns. + +``` unison +dontMap f = cases + None -> false + Some _unused -> f 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + dontMap : (Nat ->{g} Boolean) -> Optional a ->{g} Boolean +``` diff --git a/unison-src/transcripts/idempotent/fix2826.md b/unison-src/transcripts/idempotent/fix2826.md new file mode 100644 index 0000000000..29ab08d8c3 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2826.md @@ -0,0 +1,63 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +Supports fences that are longer than three backticks. + +```` unison + +doc = {{ + @typecheck ``` + x = 3 + ``` +}} + +```` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + doc : Doc2 +``` + +And round-trips properly. + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + doc : Doc2 + +scratch/main> edit.new doc + + ☝️ + + I added 1 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. + +scratch/main> load scratch.u + + Loading changes detected in scratch.u. + + I found and typechecked the definitions in scratch.u. This + file has been previously added to the codebase. +``` + +```` unison :added-by-ucm scratch.u +doc : Doc2 +doc = + {{ + @typecheck ``` + x = 3 + ``` + }} +```` diff --git a/unison-src/transcripts/idempotent/fix2970.md b/unison-src/transcripts/idempotent/fix2970.md new file mode 100644 index 0000000000..fbae0cdc4b --- /dev/null +++ b/unison-src/transcripts/idempotent/fix2970.md @@ -0,0 +1,24 @@ +Also fixes \#1519 (it's the same issue). + +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +foo.+.doc : Nat +foo.+.doc = 10 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo.+.doc : Nat +``` diff --git a/unison-src/transcripts/idempotent/fix3037.md b/unison-src/transcripts/idempotent/fix3037.md new file mode 100644 index 0000000000..d709d8984c --- /dev/null +++ b/unison-src/transcripts/idempotent/fix3037.md @@ -0,0 +1,63 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Tests for an unsound case of ability checking that was erroneously being +accepted before. In certain cases, abilities were able to be added to rows in +invariant positions. + +``` unison :error +structural type Runner g = Runner (forall a. '{g} a -> {} a) + +pureRunner : Runner {} +pureRunner = Runner base.force + +-- this compiles, but shouldn't the effect type parameter on Runner be invariant? +runner : Runner {IO} +runner = pureRunner +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found an ability mismatch when checking the expression in red + + 3 | pureRunner : Runner {} + 4 | pureRunner = Runner base.force + 5 | + 6 | -- this compiles, but shouldn't the effect type parameter on Runner be invariant? + 7 | runner : Runner {IO} + 8 | runner = pureRunner + + + When trying to match Runner {} with Runner {IO} the right hand + side contained extra abilities: {IO} + +``` + +Application version: + +``` unison :error +structural type A g = A (forall a. '{g} a ->{} a) + +anA : A {} +anA = A base.force + +h : A {IO} -> () +h _ = () + +> h anA +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found an ability mismatch when checking the application + + 9 | > h anA + + + When trying to match A {} with A {IO} the right hand side + contained extra abilities: {IO} + +``` diff --git a/unison-src/transcripts/idempotent/fix3171.md b/unison-src/transcripts/idempotent/fix3171.md new file mode 100644 index 0000000000..b01d751fee --- /dev/null +++ b/unison-src/transcripts/idempotent/fix3171.md @@ -0,0 +1,37 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Tests an case where decompiling could cause function arguments to occur in the +opposite order for partially applied functions. + +``` unison +f : Nat -> Nat -> Nat -> () -> Nat +f x y z _ = x + y * z + +> f 1 2 +> f 1 2 3 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + f : Nat -> Nat -> Nat -> 'Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 4 | > f 1 2 + ⧩ + z _ -> 1 Nat.+ 2 Nat.* z + + 5 | > f 1 2 3 + ⧩ + _ -> 1 Nat.+ 2 Nat.* 3 +``` diff --git a/unison-src/transcripts/idempotent/fix3196.md b/unison-src/transcripts/idempotent/fix3196.md new file mode 100644 index 0000000000..a64b3d79f0 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix3196.md @@ -0,0 +1,59 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Tests ability checking in scenarios where one side is concrete and the other is +a variable. This was supposed to be covered, but the method wasn't actually +symmetric, so doing `equate l r` might work, but not `equate r l`. + +Below were cases that caused the failing order. + +``` unison +structural type W es = W + +unique ability Zoot where + zoot : () + +-- here only to put a kind constraint on W +structural type C = C (W {}) + +woot : W {g} -> '{g, Zoot} a ->{Zoot} a +woot w a = todo () + +ex = do + w = (W : W {Zoot}) + woot w do bug "why don't you typecheck?" + +w1 : W {Zoot} +w1 = W + +w2 : W {g} -> W {g} +w2 = cases W -> W + +> w2 w1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type C + structural type W es + ability Zoot + ex : '{Zoot} r + w1 : W {Zoot} + w2 : W {g} -> W {g} + woot : W {g} -> '{g, Zoot} a ->{Zoot} a + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 22 | > w2 w1 + ⧩ + W +``` diff --git a/unison-src/transcripts/idempotent/fix3215.md b/unison-src/transcripts/idempotent/fix3215.md new file mode 100644 index 0000000000..714b93434c --- /dev/null +++ b/unison-src/transcripts/idempotent/fix3215.md @@ -0,0 +1,34 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Tests a case where concrete abilities were appearing multiple times in an +inferred type. This was due to the pre-pass that figures out which abilities +are being matched on. It was just concatenating the ability for each pattern +into a list, and not checking whether there were duplicates. + +``` unison +structural ability T where + nat : Nat + int : Int + flo : Float + +f = cases + {nat -> k} -> 5 + {int -> k} -> 5 + {flo -> k} -> 5 + {x} -> 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability T + f : Request {g, T} x -> Nat +``` diff --git a/unison-src/transcripts/idempotent/fix3244.md b/unison-src/transcripts/idempotent/fix3244.md new file mode 100644 index 0000000000..6f0f947f4a --- /dev/null +++ b/unison-src/transcripts/idempotent/fix3244.md @@ -0,0 +1,40 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +This tests an previously erroneous case in the pattern compiler. It was assuming +that the variables bound in a guard matched the variables bound in the rest of +the branch exactly, but apparently this needn't be the case. + +``` unison + +foo t = + (x, _) = t + f w = w + x + + match t with + (x, y) + | y < 5 -> f x + | otherwise -> x + y + +> foo (10,20) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : (Nat, Nat) -> Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 11 | > foo (10,20) + ⧩ + 30 +``` diff --git a/unison-src/transcripts/idempotent/fix3265.md b/unison-src/transcripts/idempotent/fix3265.md new file mode 100644 index 0000000000..f900a74015 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix3265.md @@ -0,0 +1,91 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Tests cases that produced bad decompilation output previously. There +are three cases that need to be 'fixed up.' + +1. lambda expressions with free variables need to be beta reduced +2. let defined functions need to have arguments removed and + occurrences rewritten. +3. let-rec defined functions need to have arguments removed, but + it is a more complicated process. + +``` unison +> Any (w x -> let + f0 y = match y with + 0 -> x + n -> 1 + f1 (drop y 1) + f1 y = match y with + 0 -> w + x + n -> 1 + f0 (drop y 1) + f2 x = f2 x + f3 y = 1 + y + f2 x + g h = h 1 + x + g (z -> x + f0 z)) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > Any (w x -> let + ⧩ + Any + (w x -> + let + use Nat + drop + f1 y = match y with + 0 -> w + x + n -> 1 + f0 (drop y 1) + f0 y = match y with + 0 -> x + n -> 1 + f1 (drop y 1) + f2 x = f2 x + f3 x y = 1 + y + f2 x + g h = h 1 + x + g (z -> x + f0 z)) +``` + +Also check for some possible corner cases. + +`f` should not have its `x` argument eliminated, because it doesn't +always occur with `x` as the first argument, but if we aren't careful, +we might do that, because we find the first occurrence of `f`, and +discard its arguments, where `f` also occurs. + +``` unison +> Any (x -> let + f x y = match y with + 0 -> 0 + _ -> f x (f y (drop y 1)) + + f x 20) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > Any (x -> let + ⧩ + Any + (x -> + let + f x y = match y with + 0 -> 0 + _ -> f x (f y (Nat.drop y 1)) + f x 20) +``` diff --git a/unison-src/transcripts/idempotent/fix3424.md b/unison-src/transcripts/idempotent/fix3424.md new file mode 100644 index 0000000000..dbd2e089f6 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix3424.md @@ -0,0 +1,49 @@ +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. +``` + +``` unison :hide +a = do b +b = "Hello, " ++ c ++ "!" +c = "World" +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + a : 'Text + b : Text + c : Text + +scratch/main> run a + + "Hello, World!" +``` + +``` unison :hide +a = do b +c = "Unison" +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +scratch/main> run a + + "Hello, Unison!" +``` + +The result should be "Hello, Unison\!". diff --git a/unison-src/transcripts/idempotent/fix3634.md b/unison-src/transcripts/idempotent/fix3634.md new file mode 100644 index 0000000000..57c398d09d --- /dev/null +++ b/unison-src/transcripts/idempotent/fix3634.md @@ -0,0 +1,45 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison +structural type M a = N | J a + +d = {{ + +{{ docExample 0 '(x -> J x) }} + +{J} + +}} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type M a + (also named builtin.Optional) + d : Doc2 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type M a + (also named builtin.Optional) + d : Doc2 + +scratch/main> display d + + `x -> J x` + + J +``` diff --git a/unison-src/transcripts/idempotent/fix3678.md b/unison-src/transcripts/idempotent/fix3678.md new file mode 100644 index 0000000000..d2eb422079 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix3678.md @@ -0,0 +1,32 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Array comparison was indexing out of bounds. + +``` unison +arr = Scope.run do + ma = Scope.arrayOf "asdf" 0 + freeze! ma + +> compare arr arr +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + arr : ImmutableArray Text + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 5 | > compare arr arr + ⧩ + +0 +``` diff --git a/unison-src/transcripts/idempotent/fix3752.md b/unison-src/transcripts/idempotent/fix3752.md new file mode 100644 index 0000000000..c017e69933 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix3752.md @@ -0,0 +1,34 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +These were failing to type check before, because id was not +generalized. + +``` unison + +foo = do + id x = + _ = 1 + x + id () + id "hello" + +bar = do + id x = x + id () + id "hello" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : 'Text + foo : 'Text +``` diff --git a/unison-src/transcripts/idempotent/fix3773.md b/unison-src/transcripts/idempotent/fix3773.md new file mode 100644 index 0000000000..52258f5ff9 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix3773.md @@ -0,0 +1,31 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +foo = + _ = 1 + _ = 22 + 42 + +> foo + 20 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 6 | > foo + 20 + ⧩ + 62 +``` diff --git a/unison-src/transcripts/idempotent/fix3977.md b/unison-src/transcripts/idempotent/fix3977.md new file mode 100644 index 0000000000..f779785cf4 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix3977.md @@ -0,0 +1,47 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Pretty-printing previously didn’t compensate for extra characters on a line that was about to be wrapped, resulting in a line-break without sufficient indentation. Now pretty-printing indents based on the starting column of the wrapped expression, not simply “prevIndent + 2”. + +``` unison :hide +failure msg context = Failure (typeLink Unit) msg (Any context) + +foo = Left (failure ("a loooooooooooooooooooooooooooooooooong" ++ "message with concatenation") ()) +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + failure : Text -> context -> Failure + foo : Either Failure b + +scratch/main> edit.new foo + + ☝️ + + I added 1 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. + +scratch/main> load scratch.u + + Loading changes detected in scratch.u. + + I found and typechecked the definitions in scratch.u. This + file has been previously added to the codebase. +``` + +``` unison :added-by-ucm scratch.u +foo : Either Failure b +foo = + use Text ++ + Left + (failure + ("a loooooooooooooooooooooooooooooooooong" + ++ "message with concatenation") + ()) +``` diff --git a/unison-src/transcripts/idempotent/fix4172.md b/unison-src/transcripts/idempotent/fix4172.md new file mode 100644 index 0000000000..8a4009a499 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4172.md @@ -0,0 +1,98 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +debug a = match Debug.toText a with + None -> "" + Some (Left a) -> a + Some (Right a) -> a + +test> t1 = if bool then [Ok "Yay"] + else [Fail (debug [1,2,3])] +bool = true + +allowDebug = debug [1,2,3] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + allowDebug : Text + bool : Boolean + debug : a -> Text + t1 : [Result] + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 6 | test> t1 = if bool then [Ok "Yay"] + + ✅ Passed Yay +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + allowDebug : Text + bool : Boolean + debug : a -> Text + t1 : [Result] + +scratch/main> test + + Cached test results (`help testcache` to learn more) + + 1. t1 ◉ Yay + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +``` unison +bool = false +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + bool : Boolean +``` + +``` ucm :error +scratch/main> update.old + + ⍟ I've updated these names to your new definition: + + bool : Boolean + +scratch/main> test + + ✅ + + + + New test results: + + 1. t1 ✗ [1, 2, 3] + + 🚫 1 test(s) failing + + Tip: Use view 1 to view the source of a test. +``` diff --git a/unison-src/transcripts/idempotent/fix4280.md b/unison-src/transcripts/idempotent/fix4280.md new file mode 100644 index 0000000000..5f5d6d2a9a --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4280.md @@ -0,0 +1,25 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +foo.bar._baz = 5 + +bonk : Nat +bonk = + use foo.bar _baz + _baz +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bonk : Nat + foo.bar._baz : Nat +``` diff --git a/unison-src/transcripts/idempotent/fix4397.md b/unison-src/transcripts/idempotent/fix4397.md new file mode 100644 index 0000000000..6757d22342 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4397.md @@ -0,0 +1,18 @@ +``` unison :error +structural type Foo f + = Foo (f ()) +unique type Baz = Baz (Foo Bar) + +unique type Bar + = Bar Baz +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Kind mismatch arising from + 3 | unique type Baz = Baz (Foo Bar) + + Foo expects an argument of kind: Type -> Type; however, it + is applied to Bar which has kind: Type. +``` diff --git a/unison-src/transcripts/idempotent/fix4415.md b/unison-src/transcripts/idempotent/fix4415.md new file mode 100644 index 0000000000..2f6087477e --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4415.md @@ -0,0 +1,17 @@ +``` unison +unique type Foo = Foo +unique type sub.Foo = +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + type sub.Foo +``` diff --git a/unison-src/transcripts/idempotent/fix4424.md b/unison-src/transcripts/idempotent/fix4424.md new file mode 100644 index 0000000000..8915119bd9 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4424.md @@ -0,0 +1,42 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Some basics: + +``` unison :hide +unique type Cat.Dog = Mouse Nat +unique type Rat.Dog = Bird + +countCat = cases + Cat.Dog.Mouse x -> Bird +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Cat.Dog + type Rat.Dog + countCat : Cat.Dog -> Rat.Dog +``` + +Now I want to add a constructor. + +``` unison :hide +unique type Rat.Dog = Bird | Mouse +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. +``` diff --git a/unison-src/transcripts/idempotent/fix4482.md b/unison-src/transcripts/idempotent/fix4482.md new file mode 100644 index 0000000000..ef8705ba8d --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4482.md @@ -0,0 +1,65 @@ +``` ucm :hide +myproj/main> builtins.merge +``` + +``` unison +lib.foo0.lib.bonk1.bar = 203 +lib.foo0.baz = 1 +lib.foo1.zonk = 204 +lib.foo1.lib.bonk2.qux = 1 +mybar = bar + bar +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.foo0.baz : Nat + lib.foo0.lib.bonk1.bar : Nat + lib.foo1.lib.bonk2.qux : Nat + lib.foo1.zonk : Nat + mybar : Nat +``` + +``` ucm :error +myproj/main> add + + ⍟ I've added these definitions: + + lib.foo0.baz : Nat + lib.foo0.lib.bonk1.bar : Nat + lib.foo1.lib.bonk2.qux : Nat + lib.foo1.zonk : Nat + mybar : Nat + +myproj/main> upgrade foo0 foo1 + + I couldn't automatically upgrade foo0 to foo1. However, I've + added the definitions that need attention to the top of + scratch.u. + + When you're done, you can run + + upgrade.commit + + to merge your changes back into main and delete the temporary + branch. Or, if you decide to cancel the upgrade instead, you + can run + + delete.branch /upgrade-foo0-to-foo1 + + to delete the temporary branch and switch back to main. +``` + +``` unison :added-by-ucm scratch.u +mybar : Nat +mybar = + use Nat + + use lib.foo0.lib.bonk1 bar + bar + bar +``` diff --git a/unison-src/transcripts/idempotent/fix4498.md b/unison-src/transcripts/idempotent/fix4498.md new file mode 100644 index 0000000000..350fa8cdf1 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4498.md @@ -0,0 +1,43 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +lib.dep0.bonk.foo = 5 +lib.dep0.zonk.foo = "hi" +lib.dep0.lib.dep1.foo = 6 +myterm = foo + 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.dep0.bonk.foo : Nat + lib.dep0.lib.dep1.foo : Nat + lib.dep0.zonk.foo : Text + myterm : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lib.dep0.bonk.foo : Nat + lib.dep0.lib.dep1.foo : Nat + lib.dep0.zonk.foo : Text + myterm : Nat + +scratch/main> view myterm + + myterm : Nat + myterm = + use Nat + + bonk.foo + 2 +``` diff --git a/unison-src/transcripts/idempotent/fix4515.md b/unison-src/transcripts/idempotent/fix4515.md new file mode 100644 index 0000000000..534be7e156 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4515.md @@ -0,0 +1,69 @@ +``` ucm :hide +myproject/main> builtins.merge +``` + +``` unison +unique type Foo = Foo1 +unique type Bar = X Foo +unique type Baz = X Foo + +useBar : Bar -> Nat +useBar = cases + Bar.X _ -> 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Bar + type Baz + type Foo + useBar : Bar -> Nat +``` + +``` ucm +myproject/main> add + + ⍟ I've added these definitions: + + type Bar + type Baz + type Foo + useBar : Bar -> Nat +``` + +``` unison +unique type Foo = Foo1 | Foo2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm +myproject/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. +``` diff --git a/unison-src/transcripts/idempotent/fix4528.md b/unison-src/transcripts/idempotent/fix4528.md new file mode 100644 index 0000000000..d91b7f016e --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4528.md @@ -0,0 +1,36 @@ +``` ucm :hide +foo/main> builtins.merge +``` + +``` unison +structural type Foo = MkFoo Nat + +main : () -> Foo +main _ = MkFoo 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type Foo + main : 'Foo +``` + +``` ucm +foo/main> add + + ⍟ I've added these definitions: + + structural type Foo + main : 'Foo + +foo/main> run main + + MkFoo 5 +``` diff --git a/unison-src/transcripts/idempotent/fix4556.md b/unison-src/transcripts/idempotent/fix4556.md new file mode 100644 index 0000000000..6b991bddb9 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4556.md @@ -0,0 +1,66 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +thing = 3 +foo.hello = 5 + thing +bar.hello = 5 + thing +hey = foo.hello +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar.hello : Nat + foo.hello : Nat + hey : Nat + thing : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar.hello : Nat + foo.hello : Nat + hey : Nat + thing : Nat +``` + +``` unison +thing = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + thing : Nat +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. +``` diff --git a/unison-src/transcripts/idempotent/fix4592.md b/unison-src/transcripts/idempotent/fix4592.md new file mode 100644 index 0000000000..f3e903cfdd --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4592.md @@ -0,0 +1,20 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison +doc = {{ {{ bug "bug" + 52 }} }} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + doc : Doc2 +``` diff --git a/unison-src/transcripts/idempotent/fix4618.md b/unison-src/transcripts/idempotent/fix4618.md new file mode 100644 index 0000000000..5e1f55a800 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4618.md @@ -0,0 +1,61 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +foo = 5 +unique type Bugs.Zonk = Bugs +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Bugs.Zonk + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Bugs.Zonk + foo : Nat +``` + +``` unison +foo = 4 +unique type Bugs = +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Bugs + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : Nat +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` diff --git a/unison-src/transcripts/idempotent/fix4711.md b/unison-src/transcripts/idempotent/fix4711.md new file mode 100644 index 0000000000..9365bf01aa --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4711.md @@ -0,0 +1,59 @@ +# Delayed Int literal doesn't round trip + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +thisWorks = '(+1) + +thisDoesNotWork = ['(+1)] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thisDoesNotWork : ['{g} Int] + thisWorks : 'Int +``` + +Since this is fixed, `thisDoesNotWork` now does work. + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + thisDoesNotWork : ['{g} Int] + thisWorks : 'Int + +scratch/main> edit.new thisWorks thisDoesNotWork + + ☝️ + + I added 2 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. + +scratch/main> load + + Loading changes detected in scratch.u. + + I found and typechecked the definitions in scratch.u. This + file has been previously added to the codebase. +``` + +``` unison :added-by-ucm scratch.u +thisDoesNotWork : ['{g} Int] +thisDoesNotWork = [do +1] + +thisWorks : 'Int +thisWorks = do +1 +``` diff --git a/unison-src/transcripts/idempotent/fix4722.md b/unison-src/transcripts/idempotent/fix4722.md new file mode 100644 index 0000000000..cf5cbc7545 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4722.md @@ -0,0 +1,61 @@ +Tests an improvement to type checking related to abilities. + +`foo` below typechecks fine as long as all the branches are *checked* +against their expected type. However, it's annoying to have to +annotate them. The old code was checking a match by just synthesizing +and subtyping, but we can instead check a match by pushing the +expected type into each case, allowing top-level annotations to act +like annotations on each case. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +ability X a where yield : {X a} () +ability Y where y : () + +type Foo b a = One a +type Bar a + = Leaf a + | Branch (Bar a) (Bar a) + +f : (a -> ()) -> '{g, X a} () -> '{g, X a} () -> '{g, X a} () +f _ x y = y + +abra : a -> '{Y, X z} r +abra = bug "" + +cadabra : (y -> z) -> '{g, X y} r -> '{g, X z} r +cadabra = bug "" + +foo : Bar (Optional b) -> '{Y, X (Foo z ('{Y} r))} () +foo = cases + Leaf a -> match a with + None -> abra a + Some _ -> cadabra One (abra a) + Branch l r -> + f (_ -> ()) (foo l) (foo r) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Bar a + type Foo b a + ability X a + ability Y + abra : a -> '{Y, X z} r + cadabra : (y ->{h} z) -> '{g, X y} r -> '{g, X z} r + f : (a ->{h} ()) + -> '{g, X a} () + -> '{g, X a} () + -> '{g, X a} () + foo : Bar (Optional b) -> '{Y, X (Foo z ('{Y} r))} () +``` diff --git a/unison-src/transcripts/idempotent/fix4731.md b/unison-src/transcripts/idempotent/fix4731.md new file mode 100644 index 0000000000..3c259c5973 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4731.md @@ -0,0 +1,92 @@ +``` unison +structural type Void = +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type Void +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type Void +``` + +We should be able to `match` on empty types like `Void`. + +``` unison +Void.absurdly : '{e} Void ->{e} a +Void.absurdly v = match !v with +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Void.absurdly : '{e} Void ->{e} a +``` + +``` unison +Void.absurdly : Void -> a +Void.absurdly v = match v with +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Void.absurdly : Void -> a +``` + +And empty `cases` should also work. + +``` unison +Void.absurdly : Void -> a +Void.absurdly = cases +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Void.absurdly : Void -> a +``` + +But empty function bodies are not allowed. + +``` unison :error +Void.absurd : Void -> a +Void.absurd x = +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I expected a block after this (in red), but there wasn't one. Maybe check your indentation: + 2 | Void.absurd x = +``` diff --git a/unison-src/transcripts/idempotent/fix4780.md b/unison-src/transcripts/idempotent/fix4780.md new file mode 100644 index 0000000000..bec569e265 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4780.md @@ -0,0 +1,25 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Just a simple test case to see whether partially applied +builtins decompile properly. + +``` unison +> (+) 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > (+) 2 + ⧩ + (Nat.+) 2 +``` diff --git a/unison-src/transcripts/idempotent/fix4898.md b/unison-src/transcripts/idempotent/fix4898.md new file mode 100644 index 0000000000..f414695494 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix4898.md @@ -0,0 +1,50 @@ +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +double : Int -> Int +double x = x + x + +redouble : Int -> Int +redouble x = double x + double x +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + double : Int -> Int + redouble : Int -> Int +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + double : Int -> Int + redouble : Int -> Int + +scratch/main> dependents double + + Dependents of: double + + Terms: + + 1. redouble + + Tip: Try `view 1` to see the source of any numbered item in + the above list. + +scratch/main> delete.term 1 + + Done. +``` diff --git a/unison-src/transcripts/idempotent/fix5055.md b/unison-src/transcripts/idempotent/fix5055.md new file mode 100644 index 0000000000..55a3fc4d5d --- /dev/null +++ b/unison-src/transcripts/idempotent/fix5055.md @@ -0,0 +1,45 @@ +``` ucm +test-5055/main> builtins.merge + + Done. +``` + +``` unison +foo.add x y = x Int.+ y + +foo.subtract x y = x Int.- y +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo.add : Int -> Int -> Int + foo.subtract : Int -> Int -> Int +``` + +``` ucm +test-5055/main> add + + ⍟ I've added these definitions: + + foo.add : Int -> Int -> Int + foo.subtract : Int -> Int -> Int + +test-5055/main> ls foo + + 1. add (Int -> Int -> Int) + 2. subtract (Int -> Int -> Int) + +test-5055/main> view 1 + + foo.add : Int -> Int -> Int + foo.add x y = + use Int + + x + y +``` diff --git a/unison-src/transcripts/idempotent/fix5076.md b/unison-src/transcripts/idempotent/fix5076.md new file mode 100644 index 0000000000..0eebc63a89 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix5076.md @@ -0,0 +1,24 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +Nested call to code lexer wasn’t terminating inline examples containing blocks properly. + +``` unison +x = {{ + ``let "me"`` live + ``do "me"`` in + }} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + x : Doc2 +``` diff --git a/unison-src/transcripts/idempotent/fix5080.md b/unison-src/transcripts/idempotent/fix5080.md new file mode 100644 index 0000000000..b71516e10d --- /dev/null +++ b/unison-src/transcripts/idempotent/fix5080.md @@ -0,0 +1,69 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtins +``` + +``` unison +test> fix5080.tests.success = [Ok "success"] +test> fix5080.tests.failure = [Fail "fail"] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + fix5080.tests.failure : [Result] + fix5080.tests.success : [Result] + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | test> fix5080.tests.success = [Ok "success"] + + ✅ Passed success + + 2 | test> fix5080.tests.failure = [Fail "fail"] + + 🚫 FAILED fail +``` + +``` ucm :error +scratch/main> add + + ⍟ I've added these definitions: + + fix5080.tests.failure : [Result] + fix5080.tests.success : [Result] + +scratch/main> test + + Cached test results (`help testcache` to learn more) + + 1. fix5080.tests.success ◉ success + + 2. fix5080.tests.failure ✗ fail + + 🚫 1 test(s) failing, ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +``` ucm +scratch/main> delete.term 2 + + Done. + +scratch/main> test + + Cached test results (`help testcache` to learn more) + + 1. fix5080.tests.success ◉ success + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` diff --git a/unison-src/transcripts/idempotent/fix5141.md b/unison-src/transcripts/idempotent/fix5141.md new file mode 100644 index 0000000000..fd50da1091 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix5141.md @@ -0,0 +1,5 @@ + diff --git a/unison-src/transcripts/idempotent/fix5168.md b/unison-src/transcripts/idempotent/fix5168.md new file mode 100644 index 0000000000..f6b197aadc --- /dev/null +++ b/unison-src/transcripts/idempotent/fix5168.md @@ -0,0 +1,17 @@ +The `edit` seems to suppress a following ` ``` unison ` block: + +``` unison +b = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + b : ##Nat +``` diff --git a/unison-src/transcripts/idempotent/fix5337.md b/unison-src/transcripts/idempotent/fix5337.md new file mode 100644 index 0000000000..558f763771 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix5337.md @@ -0,0 +1,30 @@ +``` ucm +scratch/main> builtins.mergeio + + Done. +``` + +The following `Doc` fails to typecheck with `ucm` `0.5.26`: + +``` unison :bug +testDoc : Doc2 +testDoc = {{ + key: '{{ docWord "value" }}'. +}} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 3 | key: '{{ docWord "value" }}'. + + + I was surprised to find a . here. + I was expecting one of these instead: + + * end of input +``` + +The same code typechecks ok with `0.5.25`. diff --git a/unison-src/transcripts/idempotent/fix5349.md b/unison-src/transcripts/idempotent/fix5349.md new file mode 100644 index 0000000000..48e16991e4 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix5349.md @@ -0,0 +1,77 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +Empty code blocks are invalid in Unison, but shouldn’t crash the parser. + +```` unison :error +README = {{ +``` +``` +}} +```` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I expected a block after this (in red), but there wasn't one. Maybe check your indentation: + 0 | README = {{ +``` + +``` unison :error +README = {{ {{ }} }} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + + + I was surprised to find an end of input here. + I was expecting one of these instead: + + * bang + * do + * false + * force + * handle + * if + * lambda + * let + * quote + * termLink + * true + * tuple + * typeLink +``` + +``` unison :error +README = {{ `` `` }} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + + + I was surprised to find an end of input here. + I was expecting one of these instead: + + * bang + * do + * false + * force + * handle + * if + * lambda + * let + * quote + * termLink + * true + * tuple + * typeLink +``` diff --git a/unison-src/transcripts/idempotent/fix5419.md b/unison-src/transcripts/idempotent/fix5419.md new file mode 100644 index 0000000000..b59561855f --- /dev/null +++ b/unison-src/transcripts/idempotent/fix5419.md @@ -0,0 +1,76 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Below is an example of variable capture occuring from pattern matching. + +``` unison + +foo w = match (5, w) with + x -> + y = toText x + match 99 with _ -> () + z = toText x + (y,z) + +> foo 8 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : w + -> ( Optional (Either Text Text), + Optional (Either Text Text)) + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 9 | > foo 8 + ⧩ + (Some (Right "(5, 8)"), Some (Right "(5, 8)")) +``` + +Arguably, the root cause is flattening of nested lets like this one. + +``` unison + +bar x = + -- argument here + y = Debug.toText x + let + x = 5 + () + -- 5 here, before fix + z = Debug.toText x + (y, z) + +> bar 3 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : x + -> ( Optional (Either Text Text), + Optional (Either Text Text)) + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 12 | > bar 3 + ⧩ + (Some (Right "3"), Some (Right "3")) +``` diff --git a/unison-src/transcripts/idempotent/fix5448.md b/unison-src/transcripts/idempotent/fix5448.md new file mode 100644 index 0000000000..fc71f75da7 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix5448.md @@ -0,0 +1,12 @@ +``` unison :hide +type NewType = NewType +main = do NewType +``` + +You shouldn't have to `add` a type before using it with `run`. + +``` ucm +scratch/main> run main + + NewType +``` diff --git a/unison-src/transcripts/idempotent/fix614.md b/unison-src/transcripts/idempotent/fix614.md new file mode 100644 index 0000000000..121ae4df94 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix614.md @@ -0,0 +1,122 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +This transcript demonstrates that Unison forces actions in blocks to have a return type of `()`. + +This works, as expected: + +``` unison +structural ability Stream a where emit : a -> () + +ex1 = do + Stream.emit 1 + Stream.emit 2 + 42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Stream a + ex1 : '{Stream Nat} Nat +``` + +``` ucm :hide +scratch/main> add +``` + +This does not typecheck, we've accidentally underapplied `Stream.emit`: + +``` unison :error +ex2 = do + Stream.emit + 42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found a value of type: a ->{Stream a} Unit + where I expected to find: Unit + + 2 | Stream.emit + 3 | 42 + + Hint: Actions within a block must have type Unit. + Use _ = to ignore a result. +``` + +We can explicitly ignore an unused result like so: + +``` unison +ex3 = do + _ = Stream.emit + () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex3 : '() +``` + +Using a helper function like `void` also works fine: + +``` unison +void x = () + +ex4 = + void [1,2,3] + () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex4 : () + void : x -> () +``` + +One more example: + +``` unison :error +ex4 = + [1,2,3] -- no good + () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found a value of type: [Nat] + where I expected to find: Unit + + 2 | [1,2,3] -- no good + 3 | () + + from right here: + + 2 | [1,2,3] -- no good + + Hint: Actions within a block must have type Unit. + Use _ = to ignore a result. +``` diff --git a/unison-src/transcripts/idempotent/fix689.md b/unison-src/transcripts/idempotent/fix689.md new file mode 100644 index 0000000000..c6afe171c4 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix689.md @@ -0,0 +1,25 @@ +Tests the fix for https://github.com/unisonweb/unison/issues/689 + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +structural ability SystemTime where + systemTime : ##Nat + +tomorrow = '(SystemTime.systemTime + 24 * 60 * 60) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability SystemTime + tomorrow : '{SystemTime} Nat +``` diff --git a/unison-src/transcripts/idempotent/fix693.md b/unison-src/transcripts/idempotent/fix693.md new file mode 100644 index 0000000000..7f28372497 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix693.md @@ -0,0 +1,131 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +structural ability X t where + x : t -> a -> a + +structural ability Abort where + abort : a +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Abort + structural ability X t +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural ability Abort + structural ability X t +``` + +This code should not type check. The match on X.x ought to introduce a +skolem variable `a` such that `c : a` and the continuation has type +`a ->{X} b`. Thus, `handle c with h : Optional a`, which is not the +correct result type. + +``` unison :error +h0 : Request {X t} b -> Optional b +h0 req = match req with + { X.x _ c -> _ } -> handle c with h0 + { d } -> Some d +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Each case of a match / with expression need to have the same + type. + + Here, one is: Optional b + and another is: Optional a + + + 3 | { X.x _ c -> _ } -> handle c with h0 + + from these spots, respectively: + + 1 | h0 : Request {X t} b -> Optional b +``` + +This code should not check because `t` does not match `b`. + +``` unison :error +h1 : Request {X t} b -> Optional b +h1 req = match req with + { X.x t _ -> _ } -> handle t with h1 + { d } -> Some d +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Each case of a match / with expression need to have the same + type. + + Here, one is: Optional b + and another is: Optional t + + + 3 | { X.x t _ -> _ } -> handle t with h1 + + from these spots, respectively: + + 1 | h1 : Request {X t} b -> Optional b +``` + +This code should not check for reasons similar to the first example, +but with the continuation rather than a parameter. + +``` unison :error +h2 : Request {Abort} r -> r +h2 req = match req with + { Abort.abort -> k } -> handle k 5 with h2 + { r } -> r +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + The 1st argument to `k` + + has type: Nat + but I expected: a + + 3 | { Abort.abort -> k } -> handle k 5 with h2 +``` + +This should work fine. + +``` unison +h3 : Request {X b, Abort} b -> Optional b +h3 = cases + { r } -> Some r + { Abort.abort -> _ } -> None + { X.x b _ -> _ } -> Some b +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + h3 : Request {X b, Abort} b -> Optional b +``` diff --git a/unison-src/transcripts/idempotent/fix845.md b/unison-src/transcripts/idempotent/fix845.md new file mode 100644 index 0000000000..57c5dc7fcd --- /dev/null +++ b/unison-src/transcripts/idempotent/fix845.md @@ -0,0 +1,149 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Add `List.zonk` to the codebase: + +``` unison +List.zonk : [a] -> [a] +List.zonk xs = xs + +Text.zonk : Text -> Text +Text.zonk txt = txt ++ "!! " +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + List.zonk : [a] -> [a] + Text.zonk : Text -> Text +``` + +``` ucm :hide +scratch/main> add +``` + +Now, typecheck a file with a reference to `Blah.zonk` (which doesn't exist in the codebase). This should fail: + +``` unison :error +-- should not typecheck as there's no `Blah.zonk` in the codebase +> Blah.zonk [1,2,3] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I couldn't figure out what Blah.zonk refers to here: + + 2 | > Blah.zonk [1,2,3] + + I think its type should be: + + [Nat] -> o + + Some common causes of this error include: + * Your current namespace is too deep to contain the + definition in its subtree + * The definition is part of a library which hasn't been + added to this project + * You have a typo in the name +``` + +Here's another example, just checking that TDNR works for definitions in the same file: + +``` unison +foo.bar.baz = 42 + +qux.baz = "hello" + +ex = baz ++ ", world!" + +> ex +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex : Text + foo.bar.baz : Nat + qux.baz : Text + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 7 | > ex + ⧩ + "hello, world!" +``` + +Here's another example, checking that TDNR works when multiple codebase definitions have matching names: + +``` unison +ex = zonk "hi" + +> ex +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex : Text + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 3 | > ex + ⧩ + "hi!! " +``` + +Last example, showing that TDNR works when there are multiple matching names in both the file and the codebase: + +``` unison +woot.zonk = "woot" +woot2.zonk = 9384 + +ex = zonk "hi" -- should resolve to Text.zonk, from the codebase + ++ zonk -- should resolve to the local `woot.zonk` from this file + +> ex +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ex : Text + woot.zonk : Text + woot2.zonk : Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 7 | > ex + ⧩ + "hi!! woot" +``` diff --git a/unison-src/transcripts/idempotent/fix849.md b/unison-src/transcripts/idempotent/fix849.md new file mode 100644 index 0000000000..1f799f68e1 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix849.md @@ -0,0 +1,30 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +See [this ticket](https://github.com/unisonweb/unison/issues/849). + +``` unison +x = 42 + +> x +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + x : Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 3 | > x + ⧩ + 42 +``` diff --git a/unison-src/transcripts/idempotent/fix942.md b/unison-src/transcripts/idempotent/fix942.md new file mode 100644 index 0000000000..af26d19d25 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix942.md @@ -0,0 +1,125 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +First we add some code: + +``` unison +x = 0 +y = x + 1 +z = y + 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + x : Nat + y : Nat + z : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + x : Nat + y : Nat + z : Nat +``` + +Now we edit `x` to be `7`, which should make `z` equal `10`: + +``` unison +x = 7 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + x : Nat +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +scratch/main> view x y z + + x : Nat + x = 7 + + y : Nat + y = + use Nat + + x + 1 + + z : Nat + z = + use Nat + + y + 2 +``` + +Uh oh\! `z` is still referencing the old version. Just to confirm: + +``` unison +test> t1 = if z == 3 then [Fail "nooo!!!"] else [Ok "great"] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + t1 : [Result] + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | test> t1 = if z == 3 then [Fail "nooo!!!"] else [Ok "great"] + + ✅ Passed great +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + t1 : [Result] + +scratch/main> test + + Cached test results (`help testcache` to learn more) + + 1. t1 ◉ great + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` diff --git a/unison-src/transcripts/idempotent/fix987.md b/unison-src/transcripts/idempotent/fix987.md new file mode 100644 index 0000000000..e17e1d1974 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix987.md @@ -0,0 +1,70 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +First we'll add a definition: + +``` unison +structural ability DeathStar where + attack : Text -> () + +spaceAttack1 x = + y = attack "saturn" + z = attack "neptune" + "All done" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability DeathStar + spaceAttack1 : x ->{DeathStar} Text +``` + +Add it to the codebase: + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural ability DeathStar + spaceAttack1 : x ->{DeathStar} Text +``` + +Now we'll try to add a different definition that runs the actions in a different order. This should work fine: + +``` unison +spaceAttack2 x = + z = attack "neptune" + y = attack "saturn" + "All done" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + spaceAttack2 : x ->{DeathStar} Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + spaceAttack2 : x ->{DeathStar} Text +``` + +Previously, this would fail because the hashing algorithm was being given one big let rec block whose binding order was normalized. diff --git a/unison-src/transcripts/idempotent/formatter.md b/unison-src/transcripts/idempotent/formatter.md new file mode 100644 index 0000000000..ac170b1b5e --- /dev/null +++ b/unison-src/transcripts/idempotent/formatter.md @@ -0,0 +1,207 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison :hide +{{ # Doc +This is a *doc*! + +term link {x} + +type link {type Optional} + +}} +x : + Nat + -> Nat +x y = + x = 1 + 1 + x + y +-- Should keep comments after + +-- symbolyDefinition +(<|>) : Nat -> Nat -> (Nat, Nat) +(<|>) a b = (a, b) + +symbolyEndOfBlock = + x = 1 + (+:) + + +-- Test for a previous regression that added extra brackets. +oneLiner = {{ one liner }} +-- After + +-- Before +explicit.doc = {{ +# Here's a top-level doc + +With a paragraph + +Or two +}} +-- After + +{{ A doc before an ability }} +ability Thing where + more : Nat -> Text -> Nat + doThing : Nat -> Int + + +{{ Ability with single constructor }} +structural ability Ask a where + ask : {Ask a} a + +-- Regression test for: https://github.com/unisonweb/unison/issues/4666 +provide : a -> '{Ask a} r -> r +provide a action = + h = cases + {ask -> resume} -> handle resume a with h + {r} -> r + handle !action with h + +{{ +A Doc before a type +}} +structural type Optional a = More Text + | Some + | Other a + | None Nat + +{{ A doc before a type with no type-vars }} +type Two = One Nat | Two Text + +-- Regression for https://github.com/unisonweb/unison/issues/4669 + +multilineBold = {{ + +**This paragraph is really really really really really long and spans multiple lines +with a strike-through block** + +_This paragraph is really really really really really long and spans multiple lines +with a strike-through block_ + +~This paragraph is really really really really really long and spans multiple lines +with a strike-through block~ + +}} +``` + +``` ucm +scratch/main> debug.format +``` + +``` unison :added-by-ucm scratch.u +x.doc = + {{ + # Doc This is a **doc**! + + term link {x} + + type link {type Optional} + }} +x : Nat -> Nat +x y = + use Nat + + x = 1 + 1 + x + y +-- Should keep comments after + +-- symbolyDefinition +(<|>) : Nat -> Nat -> (Nat, Nat) +a <|> b = (a, b) + +symbolyEndOfBlock = + x = 1 + (+:) + + +-- Test for a previous regression that added extra brackets. +oneLiner = {{ one liner }} +-- After + +-- Before +explicit.doc = + {{ + # Here's a top-level doc + + With a paragraph + + Or two + }} +-- After + +Thing.doc = {{ A doc before an ability }} +ability Thing where + more : Nat -> Text ->{Thing} Nat + doThing : Nat ->{Thing} Int + + +Ask.doc = {{ Ability with single constructor }} +structural ability Ask a where ask : {Ask a} a + +-- Regression test for: https://github.com/unisonweb/unison/issues/4666 +provide : a -> '{Ask a} r -> r +provide a action = + h = cases + { ask -> resume } -> handle resume a with h + { r } -> r + handle action() with h + +Optional.doc = {{ A Doc before a type }} +structural type Optional a = More Text | Some | Other a | None Nat + +Two.doc = {{ A doc before a type with no type-vars }} +type Two = One Nat | Two Text + +-- Regression for https://github.com/unisonweb/unison/issues/4669 + +multilineBold = + {{ + **This paragraph is really really really really really long and spans + multiple lines with a strike-through block** + + __This paragraph is really really really really really long and spans + multiple lines with a strike-through block__ + + ~~This paragraph is really really really really really long and spans + multiple lines with a strike-through block~~ + }} +``` + +Formatter should leave things alone if the file doesn't typecheck. + +``` unison :error +brokenDoc = {{ hello }} + 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I couldn't figure out what + refers to here: + + 1 | brokenDoc = {{ hello }} + 1 + + The name + is ambiguous. I tried to resolve it by type but no + term with that name would pass typechecking. I think its type + should be: + + Doc2 -> Nat -> o + + If that's not what you expected, you may have a type error + somewhere else in your code. + Help me out by using a more specific name here or adding a + type annotation. + + I found some terms in scope with matching names but different + types. If one of these is what you meant, try using its full + name: + + (Float.+) : Float -> Float -> Float + (Int.+) : Int -> Int -> Int + (Nat.+) : Nat -> Nat -> Nat +``` + +``` ucm +scratch/main> debug.format +``` diff --git a/unison-src/transcripts/idempotent/fuzzy-options.md b/unison-src/transcripts/idempotent/fuzzy-options.md new file mode 100644 index 0000000000..0e6ae51d30 --- /dev/null +++ b/unison-src/transcripts/idempotent/fuzzy-options.md @@ -0,0 +1,82 @@ +# Test that the options selector for fuzzy finding is working as expected for different argument types. + +If an argument is required but doesn't have a fuzzy resolver, the command should just print the help. + +``` ucm :error +-- The second argument of move.term is a 'new-name' and doesn't have a fuzzy resolver + +scratch/main> move.term + + `move.term foo bar` renames `foo` to `bar`. +``` + +If a fuzzy resolver doesn't have any options available it should print a message instead of +opening an empty fuzzy-select. + +``` ucm :error +scratch/empty> view + + ⚠️ + + Sorry, I was expecting an argument for the definition to view, and I couldn't find any to suggest to you. 😅 +``` + +``` unison :hide +optionOne = 1 + +nested.optionTwo = 2 +``` + +Definition args + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + nested.optionTwo : ##Nat + optionOne : ##Nat + +scratch/main> debug.fuzzy-options view _ + + Select a definition to view: + * optionOne + * nested.optionTwo +``` + +Namespace args + +``` ucm +scratch/main> add + + ⊡ Ignored previously added definitions: nested.optionTwo + optionOne + +scratch/main> debug.fuzzy-options find-in _ + + Select a namespace: + * nested +``` + +Project Branch args + +``` ucm +myproject/main> branch mybranch + + Done. I've created the mybranch branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /mybranch`. + +scratch/main> debug.fuzzy-options switch _ + + Select a project or branch to switch to: + * /empty + * /main + * myproject/main + * myproject/mybranch + * scratch/empty + * scratch/main + * myproject + * scratch +``` diff --git a/unison-src/transcripts/idempotent/generic-parse-errors.md b/unison-src/transcripts/idempotent/generic-parse-errors.md new file mode 100644 index 0000000000..e68aeaa8ff --- /dev/null +++ b/unison-src/transcripts/idempotent/generic-parse-errors.md @@ -0,0 +1,139 @@ +Just a bunch of random parse errors to test the error formatting. + +``` unison :error +x = + foo.123 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 2 | foo.123 + + + I was surprised to find a 1 here. + I was expecting one of these instead: + + * end of input + * hash (ex: #af3sj3) + * identifier (ex: abba1, snake_case, .foo.bar#xyz, .foo.++#xyz, or 🌻) +``` + +``` unison :error +namespace.blah = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 1 | namespace.blah = 1 + + + I was surprised to find a = here. + I was expecting one of these instead: + + * ability + * bang + * binding + * do + * false + * force + * handle + * if + * lambda + * let + * newline or semicolon + * quote + * termLink + * true + * tuple + * type + * typeLink + * use +``` + +``` unison :error +x = 1 ] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found a closing ']' here without a matching '['. + + 1 | x = 1 ] +``` + +``` unison :error +x = a.#abc +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 1 | x = a.#abc + + + I was surprised to find a '.' here. + I was expecting one of these instead: + + * and + * bang + * do + * false + * force + * handle + * if + * infixApp + * let + * newline or semicolon + * or + * quote + * termLink + * true + * tuple + * typeLink +``` + +``` unison :error +x = "hi +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 2 | + + I was surprised to find an end of input here. + I was expecting one of these instead: + + * " + * \s + * literal character +``` + +``` unison :error +y : a +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 2 | + + I was surprised to find an end of section here. + I was expecting one of these instead: + + * -> + * newline or semicolon +``` diff --git a/unison-src/transcripts/idempotent/help.md b/unison-src/transcripts/idempotent/help.md new file mode 100644 index 0000000000..7dc5975ed0 --- /dev/null +++ b/unison-src/transcripts/idempotent/help.md @@ -0,0 +1,1024 @@ +# Shows `help` output + +``` ucm +scratch/main> help + + add + `add` adds to the codebase all the definitions from the most recently typechecked file. + + add.preview + `add.preview` previews additions to the codebase from the most recently typechecked file. This command only displays cached typechecking results. Use `load` to reparse & typecheck the file if the context has changed. + + add.run + `add.run name` adds to the codebase the result of the most recent `run` command as `name`. + + alias.many (or copy) + `alias.many [relative2...] ` creates + aliases `relative1`, `relative2`, ... in the namespace + `namespace`. + `alias.many foo.foo bar.bar .quux` creates aliases + `.quux.foo.foo` and `.quux.bar.bar`. + + alias.term + `alias.term foo bar` introduces `bar` with the same definition as `foo`. + + alias.type + `alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`. + + api + `api` provides details about the API. + + auth.login + Obtain an authentication session with Unison Share. + `auth.login`authenticates ucm with Unison Share. + + back (or popd) + `back` undoes the last `switch` command. + + branch (or branch.create, create.branch) + `branch foo` forks the current project branch to a new + branch `foo` + `branch /bar foo` forks the branch `bar` of the current + project to a new branch `foo` + + branch.empty (or branch.create-empty, create.empty-branch) + Create a new empty branch. + + branch.rename (or rename.branch) + `branch.rename foo` renames the current branch to `foo` + + branches (or list.branch, ls.branch, branch.list) + `branches` lists all branches in the current project + `branches foo` lists all branches in the project `foo` + + clear + `clear` Clears the screen. + + clone + `clone @unison/json/topic json/my-topic` creates + `json/my-topic` from + the remote branch + `@unison/json/topic` + `clone @unison/base base/` creates `base/main` + from the remote + branch + `@unison/base/main` + `clone @unison/base /main2` creates the branch + `main2` in the + current project from + the remote branch + `@unison/base/main` + `clone /main /main2` creates the branch + `main2` in the + current project from + the remote branch + `main` of the + current project's + associated remote + (see + `help-topics remotes`) + `clone /main my-fork/` creates + `my-fork/main` from + the branch `main` of + the current + project's associated + remote (see + `help-topics remotes`) + + compile (or compile.output) + `compile main file` Outputs a stand alone file that can be + directly loaded and executed by unison. + Said execution will have the effect of + running `!main`. + + create.author + `create.author alicecoder "Alice McGee"` creates `alicecoder` + values in `metadata.authors` and `metadata.copyrightHolders.` + + debug.clear-cache + Clear the watch expression cache + + debug.doc-to-markdown + `debug.doc-to-markdown term.doc` Render a doc to markdown. + + debug.doctor + Analyze your codebase for errors and inconsistencies. + + debug.dump-namespace + Dump the namespace to a text file + + debug.dump-namespace-simple + Dump the namespace to a text file + + debug.file + View details about the most recent successfully typechecked file. + + debug.find.global + `find` lists all definitions in the + current namespace. + `find foo` lists all definitions with a + name similar to 'foo' in the + current namespace (excluding + those under 'lib'). + `find foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the current + namespace (excluding those + under 'lib'). + `find-in namespace` lists all definitions in the + specified subnamespace. + `find-in namespace foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the specified + subnamespace. + find.all foo lists all definitions with a + name similar to 'foo' in the + current namespace (including + one level of 'lib'). + `find-in.all namespace` lists all definitions in the + specified subnamespace + (including one level of its + 'lib'). + `find-in.all namespace foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the specified + subnamespace (including one + level of its 'lib'). + debug.find.global foo Iteratively searches all + projects and branches and + lists all definitions with a + name similar to 'foo'. Note + that this is a very slow + operation. + + debug.names.global + `debug.names.global foo` Iteratively search across all + projects and branches for names matching `foo`. Note that this + is expected to be quite slow and is primarily for debugging + issues with your codebase. + + debug.numberedArgs + Dump the contents of the numbered args state. + + delete + `delete foo` removes the term or type name `foo` from the namespace. + `delete foo bar` removes the term or type name `foo` and `bar` from the namespace. + + delete.branch (or branch.delete) + `delete.branch foo/bar` deletes the branch `bar` in the + project `foo` + `delete.branch /bar` deletes the branch `bar` in the + current project + + delete.namespace + `delete.namespace ` deletes the namespace `foo` + + delete.namespace.force + `delete.namespace.force ` deletes the namespace `foo`,deletion will proceed even if other code depends on definitions in foo. + + delete.project (or project.delete) + `delete.project foo` deletes the local project `foo` + + delete.term + `delete.term foo` removes the term name `foo` from the namespace. + `delete.term foo bar` removes the term name `foo` and `bar` from the namespace. + + delete.term.verbose + `delete.term.verbose foo` removes the term name `foo` from the namespace. + `delete.term.verbose foo bar` removes the term name `foo` and `bar` from the namespace. + + delete.type + `delete.type foo` removes the type name `foo` from the namespace. + `delete.type foo bar` removes the type name `foo` and `bar` from the namespace. + + delete.type.verbose + `delete.type.verbose foo` removes the type name `foo` from the namespace. + `delete.type.verbose foo bar` removes the type name `foo` and `bar` from the namespace. + + delete.verbose + `delete.verbose foo` removes the term or type name `foo` from the namespace. + `delete.verbose foo bar` removes the term or type name `foo` and `bar` from the namespace. + + dependencies + List the dependencies of the specified definition. + + dependents + List the named dependents of the specified definition. + + deprecated.cd (or deprecated.namespace) + Moves your perspective to a different namespace. Deprecated for now because too many important things depend on your perspective selection. + + `deprecated.cd foo.bar` descends into foo.bar from the + current namespace. + `deprecated.cd .cat.dog` sets the current namespace to the + absolute namespace .cat.dog. + `deprecated.cd ..` moves to the parent of the current + namespace. E.g. moves from + '.cat.dog' to '.cat' + `deprecated.cd` invokes a search to select which + namespace to move to, which requires + that `fzf` can be found within your + PATH. + + deprecated.root-reflog + `deprecated.root-reflog` lists the changes that have affected the root namespace. This has been deprecated in favor of `reflog` which shows the reflog for the current project. + + diff.namespace + `diff.namespace before after` shows how the namespace `after` + differs from the namespace + `before` + `diff.namespace before` shows how the current namespace + differs from the namespace + `before` + + display + `display foo` prints a rendered version of the term `foo`. + `display` without arguments invokes a search to select a definition to display, which requires that `fzf` can be found within your PATH. + + display.to + `display.to foo` prints a rendered version of the + term `foo` to the given file. + + docs + `docs foo` shows documentation for the definition `foo`. + `docs` without arguments invokes a search to select which definition to view documentation for, which requires that `fzf` can be found within your PATH. + + docs.to-html + `docs.to-html .path.to.ns doc-dir` Render + all docs + contained + within + the + namespace + `.path.to.ns`, + no matter + how deep, + to html + files in + `doc-dir` + in the + directory + UCM was + run from. + `docs.to-html project0/branch0:a.path /tmp/doc-dir` Renders + all docs + anywhere + in the + namespace + `a.path` + from + `branch0` + of + `project0` + to html + in + `/tmp/doc-dir`. + + edit + `edit foo` prepends the definition of `foo` to the top of the most recently saved file. + `edit` without arguments invokes a search to select a definition for editing, which requires that `fzf` can be found within your PATH. + + edit.dependents + Like `edit`, but also includes all transitive dependents in the current project. + + edit.namespace + `edit.namespace` will load all terms and types contained within the current namespace into your scratch file. This includes definitions in namespaces, but excludes libraries. + `edit.namespace ns1 ns2 ...` loads the terms and types contained within the provided namespaces. + + edit.new + Like `edit`, but adds a new fold line below the definitions. + + find + `find` lists all definitions in the + current namespace. + `find foo` lists all definitions with a + name similar to 'foo' in the + current namespace (excluding + those under 'lib'). + `find foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the current + namespace (excluding those + under 'lib'). + `find-in namespace` lists all definitions in the + specified subnamespace. + `find-in namespace foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the specified + subnamespace. + find.all foo lists all definitions with a + name similar to 'foo' in the + current namespace (including + one level of 'lib'). + `find-in.all namespace` lists all definitions in the + specified subnamespace + (including one level of its + 'lib'). + `find-in.all namespace foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the specified + subnamespace (including one + level of its 'lib'). + debug.find.global foo Iteratively searches all + projects and branches and + lists all definitions with a + name similar to 'foo'. Note + that this is a very slow + operation. + + find-in + `find` lists all definitions in the + current namespace. + `find foo` lists all definitions with a + name similar to 'foo' in the + current namespace (excluding + those under 'lib'). + `find foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the current + namespace (excluding those + under 'lib'). + `find-in namespace` lists all definitions in the + specified subnamespace. + `find-in namespace foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the specified + subnamespace. + find.all foo lists all definitions with a + name similar to 'foo' in the + current namespace (including + one level of 'lib'). + `find-in.all namespace` lists all definitions in the + specified subnamespace + (including one level of its + 'lib'). + `find-in.all namespace foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the specified + subnamespace (including one + level of its 'lib'). + debug.find.global foo Iteratively searches all + projects and branches and + lists all definitions with a + name similar to 'foo'. Note + that this is a very slow + operation. + + find-in.all + `find` lists all definitions in the + current namespace. + `find foo` lists all definitions with a + name similar to 'foo' in the + current namespace (excluding + those under 'lib'). + `find foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the current + namespace (excluding those + under 'lib'). + `find-in namespace` lists all definitions in the + specified subnamespace. + `find-in namespace foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the specified + subnamespace. + find.all foo lists all definitions with a + name similar to 'foo' in the + current namespace (including + one level of 'lib'). + `find-in.all namespace` lists all definitions in the + specified subnamespace + (including one level of its + 'lib'). + `find-in.all namespace foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the specified + subnamespace (including one + level of its 'lib'). + debug.find.global foo Iteratively searches all + projects and branches and + lists all definitions with a + name similar to 'foo'. Note + that this is a very slow + operation. + + find.all + `find` lists all definitions in the + current namespace. + `find foo` lists all definitions with a + name similar to 'foo' in the + current namespace (excluding + those under 'lib'). + `find foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the current + namespace (excluding those + under 'lib'). + `find-in namespace` lists all definitions in the + specified subnamespace. + `find-in namespace foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the specified + subnamespace. + find.all foo lists all definitions with a + name similar to 'foo' in the + current namespace (including + one level of 'lib'). + `find-in.all namespace` lists all definitions in the + specified subnamespace + (including one level of its + 'lib'). + `find-in.all namespace foo bar` lists all definitions with a + name similar to 'foo' or + 'bar' in the specified + subnamespace (including one + level of its 'lib'). + debug.find.global foo Iteratively searches all + projects and branches and + lists all definitions with a + name similar to 'foo'. Note + that this is a very slow + operation. + + find.all.verbose + `find.all.verbose` searches for definitions like `find.all`, but includes hashes and aliases in the results. + + find.verbose + `find.verbose` searches for definitions like `find`, but includes hashes and aliases in the results. + + fork (or copy.namespace) + `fork src dest` creates + the + namespace + `dest` as + a copy of + `src`. + `fork project0/branch0:a.path project1/branch1:foo` creates + the + namespace + `foo` in + `branch1` + of + `project1` + as a copy + of + `a.path` + in + `project0/branch0`. + `fork srcproject/srcbranch dest` creates + the + namespace + `dest` as + a copy of + the + branch + `srcbranch` + of + `srcproject`. + + help (or ?) + `help` shows general help and `help ` shows help for one command. + + help-topics (or help-topic) + `help-topics` lists all topics and `help-topics ` shows an explanation of that topic. + + history + `history` Shows the history of the current + path. + `history .foo` Shows history of the path .foo. + `history #9dndk3kbsk13nbpeu` Shows the history of the + namespace with the given hash. + The full hash must be provided. + + io.test (or test.io) + `io.test mytest` Runs `!mytest`, where `mytest` is a delayed + test that can use the `IO` and `Exception` + abilities. + + io.test.all (or test.io.all) + `io.test.all` runs unit tests for the current branch that use + IO + + lib.install (or install.lib) + The `lib.install` command installs a dependency into the `lib` + namespace. + + `lib.install @unison/base/releases/latest` installs the + latest release of + `@unison/base` + `lib.install @unison/base/releases/3.0.0` installs version + 3.0.0 of + `@unison/base` + `lib.install @unison/base/topic` installs the + `topic` branch of + `@unison/base` + + list (or ls, dir) + `list` lists definitions and namespaces at the current + level of the current namespace. + `list foo` lists the 'foo' namespace. + `list .foo` lists the '.foo' namespace. + + load + `load` parses, typechecks, and evaluates the + most recent scratch file. + `load ` parses, typechecks, and evaluates the + given scratch file. + + merge + `merge /branch` merges `branch` into the current branch + + merge.commit (or commit.merge) + `merge.commit` merges a temporary branch created by the + `merge` command back into its parent branch, and removes the + temporary branch. + + For example, if you've done `merge topic` from main, then + `merge.commit` is equivalent to doing + + * switch /main + * merge /merge-topic-into-main + * delete.branch /merge-topic-into-main + + move (or rename) + `move foo bar` renames the term, type, and namespace foo to bar. + + move.namespace (or rename.namespace) + `move.namespace foo bar` renames the path `foo` to `bar`. + + move.term (or rename.term) + `move.term foo bar` renames `foo` to `bar`. + + move.type (or rename.type) + `move.type foo bar` renames `foo` to `bar`. + + names + `names foo` List all known names for `foo` in the current + branch. + + namespace.dependencies + List the external dependencies of the specified namespace. + + project.create (or create.project) + `project.create` creates a project with a random name + `project.create foo` creates a project named `foo` + + project.reflog (or reflog.project) + `project.reflog` lists all the changes that have affected any branches in the current project. + `project.reflog myproject` lists all the changes that have affected any branches in myproject. + + project.rename (or rename.project) + `project.rename foo` renames the current project to `foo` + + projects (or list.project, ls.project, project.list) + List projects. + + pull + The `pull` command merges a remote namespace into a local + branch + + `pull @unison/base/main` merges the branch + `main` of the Unison + Share hosted project + `@unison/base` into + the current branch + `pull @unison/base/main my-base/topic` merges the branch + `main` of the Unison + Share hosted project + `@unison/base` into + the branch `topic` of + the local `my-base` + project + + where `remote` is a project or project branch, such as: + Project (defaults to the /main branch) `@unison/base` + Project Branch `@unison/base/feature` + Contributor Branch `@unison/base/@johnsmith/feature` + Project Release `@unison/base/releases/1.0.0` + + pull.without-history + The `pull.without-history` command merges a remote namespace + into a local branch without including the remote's history. + This usually results in smaller codebase sizes. + + `pull.without-history @unison/base/main` merges + the + branch + `main` + of the + Unison + Share + hosted + project + `@unison/base` + into + the + current + branch + `pull.without-history @unison/base/main my-base/topic` merges + the + branch + `main` + of the + Unison + Share + hosted + project + `@unison/base` + into + the + branch + `topic` + of the + local + `my-base` + project + + where `remote` is a project or project branch, such as: + Project (defaults to the /main branch) `@unison/base` + Project Branch `@unison/base/feature` + Contributor Branch `@unison/base/@johnsmith/feature` + Project Release `@unison/base/releases/1.0.0` + + push + The `push` command merges a local project or namespace into a + remote project or namespace. + + `push ` publishes the contents of a local + namespace or branch into a remote + namespace or branch. + `push ` publishes the current namespace or + branch into a remote namespace or + branch + `push` publishes the current namespace or + branch. Remote mappings for + namespaces are configured in your + `.unisonConfig` at the key + `RemoteMappings.` where + `` is the current + namespace. Remote mappings for + branches default to the branch that + you cloned from or pushed to + initially. Otherwise, it is pushed to + @/ + + where `remote` is a project or project branch, such as: + Project (defaults to the /main branch) `@unison/base` + Project Branch `@unison/base/feature` + Contributor Branch `@unison/base/@johnsmith/feature` + + push.create + The `push.create` command pushes a local namespace to an empty + remote namespace. + + `push.create remote local` pushes the contents of the local + namespace `local` into the empty + remote namespace `remote`. + `push.create remote` publishes the current namespace + into the empty remote namespace + `remote` + `push.create` publishes the current namespace + into the remote namespace + configured in your `.unisonConfig` + at the key + `RemoteMappings.` where + `` is the current + namespace, then publishes the + current namespace to that + location. + + where `remote` is a project or project branch, such as: + Project (defaults to the /main branch) `@unison/base` + Project Branch `@unison/base/feature` + Contributor Branch `@unison/base/@johnsmith/feature` + + quit (or exit, :q) + Exits the Unison command line interface. + + reflog (or reflog.branch, branch.reflog) + `reflog` lists all the changes that have affected the current branch. + `reflog /mybranch` lists all the changes that have affected /mybranch. + + reflog.global + `reflog.global` lists all recent changes across all projects and branches. + + release.draft (or draft.release) + Draft a release. + + reset + `reset #pvfd222s8n` reset the current namespace to the + hash `#pvfd222s8n` + `reset foo` reset the current namespace to the + state of the `foo` namespace. + `reset #pvfd222s8n /topic` reset the branch `topic` of the + current project to the causal + `#pvfd222s8n`. + + If you make a mistake using reset, consult the `reflog` + command and use another `reset` command to return to a + previous state. + + rewrite (or sfind.replace) + `rewrite rule1` rewrites definitions in the latest scratch file. + + The argument `rule1` must refer to a `@rewrite` block or a + function that immediately returns a `@rewrite` block. It can + be in the codebase or scratch file. An example: + + rule1 x = @rewrite term x + 1 ==> Nat.increment x + + Here, `x` will stand in for any expression wherever this + rewrite is applied, so this rule will match `(42+10+11) + 1` + and replace it with `Nat.increment (42+10+11)`. + + See https://unison-lang.org/learn/structured-find to learn more. + + Also see the related command `rewrite.find` + + rewrite.find (or sfind) + `rewrite.find rule1` finds definitions that match any of the + left side(s) of `rule` in the current namespace. + + The argument `rule1` must refer to a `@rewrite` block or a + function that immediately returns a `@rewrite` block. It can + be in the codebase or scratch file. An example: + + -- right of ==> is ignored by this command + rule1 x = @rewrite term x + 1 ==> () + + Here, `x` will stand in for any expression, so this rule will + match `(42+10+11) + 1`. + + See https://unison-lang.org/learn/structured-find to learn more. + + Also see the related command `rewrite` + + run + `run mymain args...` Runs `!mymain`, where `mymain` is + searched for in the most recent + typechecked file, or in the codebase. + Any provided arguments will be passed as + program arguments as though they were + provided at the command line when + running mymain as an executable. + + run.native + `run.native main args` Executes !main using native + compilation via scheme. + + switch + `switch` opens an interactive selector to pick a + project and branch + `switch foo/bar` switches to the branch `bar` in the project + `foo` + `switch foo/` switches to the last branch you visited in + the project `foo` + `switch /bar` switches to the branch `bar` in the current + project + + test + `test` runs unit tests for the current branch + `test foo` runs unit tests for the current branch defined in + namespace `foo` + + test.all + `test.all` runs unit tests for the current branch (including the `lib` namespace). + + text.find (or grep) + `text.find token1 "99" token2` finds terms with literals (text + or numeric) containing `token1`, `99`, and `token2`. + + Numeric literals must be quoted (ex: "42") but single words + need not be quoted. + + Use `text.find.all` to include search of `lib`. + + text.find.all (or grep.all) + `text.find.all token1 "99" token2` finds terms with literals + (text or numeric) containing `token1`, `99`, and `token2`. + + Numeric literals must be quoted (ex: "42") but single words + need not be quoted. + + Use `text.find` to exclude `lib` from search. + + todo + `todo` lists the current namespace's outstanding issues, + including conflicted names, dependencies with missing names, + and merge precondition violations. + + ui + `ui` opens the Local UI in the default browser. + + undo + `undo` reverts the most recent change to the codebase. + + unsafe.force-push (or push.unsafe-force) + Like `push`, but forcibly overwrites the remote namespace. + + update + Adds everything in the most recently typechecked file to the + namespace, replacing existing definitions having the same + name, and attempts to update all the existing dependents + accordingly. If the process can't be completed automatically, + the dependents will be added back to the scratch file for your + review. + + update.old + `update.old` works like `add`, except that if a definition in + the file has the same name as an existing definition, the name + gets updated to point to the new definition. If the old + definition has any dependents, `update` will add those + dependents to a refactoring session, specified by an optional + patch.`update.old` adds all definitions in + the .u file, noting replacements + in the default patch for the + current namespace. + `update.old ` adds all definitions in the .u + file, noting replacements in the + specified patch. + `update.old foo bar` adds `foo`, `bar`, and their + dependents from the .u file, + noting any replacements into the + specified patch. + + update.old.nopatch + `update.old.nopatch` works like `update.old`, except it + doesn't add a patch entry for any updates. Use this when you + want to make changes to definitions without pushing those + changes to dependents beyond your codebase. An example is when + updating docs, or when updating a term you just added.`update.old.nopatch` updates + all definitions in the .u file. + `update.old.nopatch foo bar` updates `foo`, `bar`, and their + dependents from the .u file. + + update.old.preview + `update.old.preview` previews updates to the codebase from the most recently typechecked file. This command only displays cached typechecking results. Use `load` to reparse & typecheck the file if the context has changed. + + upgrade + `upgrade old new` upgrades library dependency `lib.old` to + `lib.new`, and, if successful, deletes `lib.old`. + + upgrade.commit (or commit.upgrade) + `upgrade.commit` merges a temporary branch created by the + `upgrade` command back into its parent branch, and removes the + temporary branch. + + For example, if you've done `upgrade foo bar` from main, then + `upgrade.commit` is equivalent to doing + + * switch /main + * merge /upgrade-foo-to-bar + * delete.branch /upgrade-foo-to-bar + + version + Print the version of unison you're running + + view + `view foo` shows definitions named `foo` within your current + namespace. + `view` without arguments invokes a search to select + definitions to view, which requires that `fzf` can be found + within your PATH. + + Supports glob syntax, where ? acts a wildcard, so + `view List.?` will show `List.map`, `List.filter`, etc, but + not `List.map.doc` (since ? only matches 1 name segment). + + view.global + `view.global foo` prints definitions of `foo` within your codebase. + `view.global` without arguments invokes a search to select definitions to view, which requires that `fzf` can be found within your PATH. + +scratch/main> help-topics + + 🌻 + + Here's a list of topics I can tell you more about: + + filestatus + messages.disallowedAbsolute + namespaces + projects + remotes + testcache + + Example: use `help-topics filestatus` to learn more about that topic. + +scratch/main> help-topic filestatus + + 📓 + + Here's a list of possible status messages you might see for + definitions in a .u file. + + needs update A definition with the same name as an + existing definition. Doing `update` + instead of `add` will turn this failure + into a successful update. + + term/ctor collision A definition with the same name as an + existing constructor for some data type. + Rename your definition or the data type + before trying again to `add` or `update`. + + ctor/term collision A type defined in the file has a + constructor that's named the same as an + existing term. Rename that term or your + constructor before trying again to `add` + or `update`. + + blocked This definition was blocked because it + dependended on a definition with a failed + status. + + extra dependency This definition was added because it was + a dependency of a definition explicitly + selected. + +scratch/main> help-topic messages.disallowedAbsolute + + 🤖 + + Although I can understand absolute (ex: .foo.bar) or relative + (ex: util.math.sqrt) references to existing definitions + (help namespaces to learn more), I can't yet handle giving new + definitions with absolute names in a .u file. + + As a workaround, you can give definitions with a relative name + temporarily (like `exports.blah.foo`) and then use `move.*`. + +scratch/main> help-topic namespaces + + 🧐 + + There are two kinds of namespaces, absolute, such as (.foo.bar + or .base.math.+) and relative, such as (math.sqrt or + util.List.++). + + Relative names are converted to absolute names by prepending + the current namespace. For example, if your Unison prompt + reads: + + .foo.bar> + + and your .u file looks like: + + x = 41 + + then doing an add will create the definition with the absolute + name .foo.bar.x = 41 + + and you can refer to x by its absolute name .foo.bar.x + elsewhere in your code. For instance: + + answerToLifeTheUniverseAndEverything = .foo.bar.x + 1 + +scratch/main> help-topic projects + + A project is a versioned collection of code that can be + edited, published, and depended on other projects. Unison + projects are analogous to Git repositories. + + project.create create a new project + projects list all your projects + branch create a new workstream + branches list all your branches + merge merge one branch into another + switch switch to a project or branch + push upload your changes to Unison Share + pull download code(/changes/updates) from Unison Share + clone download a Unison Share project or branch for contribution + + Tip: Use `help project.create` to learn more. + + For full documentation, see + https://unison-lang.org/learn/projects + +scratch/main> help-topic remotes + + 🤖 + + Local projects may be associated with at most one remote + project on Unison Share. When this relationship is + established, it becomes the default argument for a number of + share commands. For example, running `push` or `pull` in a + project with no arguments will push to or pull from the + associated remote, if it exists. + + This association is created automatically on when a project is + created by `clone`. If the project was created locally then + the relationship will be established on the first `push`. + +scratch/main> help-topic testcache + + 🎈 + + Unison caches the results of test> watch expressions. Since + these expressions are pure and always yield the same result + when evaluated, there's no need to run them more than once! + + A test is rerun only if it has changed, or if one of the + definitions it depends on has changed. +``` + +We should add a command to show help for hidden commands also. diff --git a/unison-src/transcripts/idempotent/higher-rank.md b/unison-src/transcripts/idempotent/higher-rank.md new file mode 100644 index 0000000000..5ac44083de --- /dev/null +++ b/unison-src/transcripts/idempotent/higher-rank.md @@ -0,0 +1,156 @@ +This transcript does some testing of higher-rank types. Regression tests related to higher-rank types can be added here. + +``` ucm :hide +scratch/main> alias.type ##Nat Nat + +scratch/main> alias.type ##Text Text + +scratch/main> alias.type ##IO IO +``` + +In this example, a higher-rank function is defined, `f`. No annotation is needed at the call-site of `f`, because the lambda is being checked against the polymorphic type `forall a . a -> a`, rather than inferred: + +``` unison +f : (forall a . a -> a) -> (Nat, Text) +f id = (id 1, id "hi") + +> f (x -> x) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + f : (∀ a. a ->{g} a) ->{g} (Nat, Text) + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 4 | > f (x -> x) + ⧩ + (1, "hi") +``` + +Another example, involving abilities. Here the ability-polymorphic function is instantiated with two different ability lists, `{}` and `{IO}`: + +``` unison +f : (forall a g . '{g} a -> '{g} a) -> () -> () +f id _ = + _ = (id ('1 : '{} Nat), id ('("hi") : '{IO} Text)) + () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + f : (∀ a g. '{g} a ->{h} '{g} a) -> '{h} () +``` + +Here's an example, showing that polymorphic functions can be fields of a constructor, and the functions remain polymorphic even when the field is bound to a name during pattern matching: + +``` unison +unique type Functor f = Functor (forall a b . (a -> b) -> f a -> f b) + +Functor.map : Functor f -> (forall a b . (a -> b) -> f a -> f b) +Functor.map = cases Functor f -> f + +Functor.blah : Functor f -> () +Functor.blah = cases Functor f -> + g : forall a b . (a -> b) -> f a -> f b + g = f + () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Functor f + Functor.blah : Functor f -> () + Functor.map : Functor f + -> (∀ a b. (a -> b) -> f a -> f b) +``` + +This example is similar, but involves abilities: + +``` unison +unique ability Remote t where doRemoteStuff : t () +unique type Loc = Loc (forall t a . '{Remote t} a ->{Remote t} t a) + +Loc.blah : Loc -> () +Loc.blah = cases Loc f -> + f0 : '{Remote tx} ax ->{Remote tx} tx ax + f0 = f + () + +-- In this case, no annotation is needed since the lambda +-- is checked against a polymorphic type +Loc.transform : (forall t a . '{Remote t} a -> '{Remote t} a) + -> Loc -> Loc +Loc.transform nt = cases Loc f -> Loc (a -> f (nt a)) + +-- In this case, the annotation is needed since f' is inferred +-- on its own it won't infer the higher-rank type +Loc.transform2 : (forall t a . '{Remote t} a -> '{Remote t} a) + -> Loc -> Loc +Loc.transform2 nt = cases Loc f -> + f' : forall t a . '{Remote t} a ->{Remote t} t a + f' a = f (nt a) + Loc f' +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Loc + ability Remote t + Loc.blah : Loc -> () + Loc.transform : (∀ t a. '{Remote t} a -> '{Remote t} a) + -> Loc + -> Loc + Loc.transform2 : (∀ t a. '{Remote t} a -> '{Remote t} a) + -> Loc + -> Loc +``` + +## Types with polymorphic fields + +``` unison :hide +structural type HigherRanked = HigherRanked (forall a. a -> a) +``` + +We should be able to add and view records with higher-rank fields. + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type HigherRanked + +scratch/main> view HigherRanked + + structural type HigherRanked = HigherRanked (∀ a. a -> a) +``` diff --git a/unison-src/transcripts/idempotent/input-parse-errors.md b/unison-src/transcripts/idempotent/input-parse-errors.md new file mode 100644 index 0000000000..2b497f5372 --- /dev/null +++ b/unison-src/transcripts/idempotent/input-parse-errors.md @@ -0,0 +1,213 @@ +# demonstrating our new input parsing errors + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison :hide +x = 55 +``` + +``` ucm :hide +scratch/main> add +``` + +`handleNameArg` parse error in `add` + +``` ucm :error +scratch/main> add . + + ⚠️ + + Sorry, I wasn’t sure how to process your request: + + 1:2: + | + 1 | . + | ^ + unexpected end of input + expecting '`' or operator (valid characters: !$%&*+-/:<=>\^|~) + + + You can run `help add` for more information on using `add`. + +scratch/main> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + +scratch/main> add 1 + + +scratch/main> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + +scratch/main> add 2 + + ⊡ Ignored previously added definitions: x +``` + +todo: + +``` haskell + SA.Name name -> pure name + SA.NameWithBranchPrefix (Left _) name -> pure name + SA.NameWithBranchPrefix (Right prefix) name -> pure $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name + SA.HashQualified hqname -> maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toName hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . Path.prefixNameIfRel (Path.AbsolutePath' prefix) $ HQ'.toName hqname + SA.ShallowListEntry prefix entry -> + pure . HQ'.toName . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry + SA.SearchResult mpath result -> + maybe (Left "can’t find a name from the numbered arg") pure . HQ.toName $ searchResultToHQ mpath result + otherNumArg -> Left . I.Formatted $ wrongStructuredArgument "a name" otherNumArg +``` + +aliasMany: skipped -- similar to `add` + +``` ucm :error +scratch/main> update arg + + ⚠️ + + Sorry, I wasn’t sure how to process your request: + + I expected no arguments, but received one. + + You can run `help update` for more information on using + `update`. +``` + +aliasTerm + +``` +scratch/main> alias.term ##Nat.+ Nat.+ +``` + +aliasTermForce, +aliasType, + +todo: + +``` + +aliasMany, +api, +authLogin, +back, +branchEmptyInputPattern, +branchInputPattern, +branchRenameInputPattern, +branchesInputPattern, +cd, +clear, +clone, +compileScheme, +createAuthor, +debugClearWatchCache, +debugDoctor, +debugDumpNamespace, +debugDumpNamespaceSimple, +debugTerm, +debugTermVerbose, +debugType, +debugLSPFoldRanges, +debugFileHashes, +debugNameDiff, +debugNumberedArgs, +debugTabCompletion, +debugFuzzyOptions, +debugFormat, +delete, +deleteBranch, +deleteProject, +deleteNamespace, +deleteNamespaceForce, +deleteTerm, +deleteTermVerbose, +deleteType, +deleteTypeVerbose, +deleteVerbose, +dependencies, +dependents, +diffNamespace, +display, +displayTo, +docToMarkdown, +docs, +docsToHtml, +edit, +editNamespace, +execute, +find, +findIn, +findAll, +findInAll, +findGlobal, +findShallow, +findVerbose, +findVerboseAll, +sfind, +sfindReplace, +forkLocal, +help, +helpTopics, +history, +ioTest, +ioTestAll, +libInstallInputPattern, +load, +makeStandalone, +mergeBuiltins, +mergeIOBuiltins, +mergeOldInputPattern, +mergeOldPreviewInputPattern, +mergeOldSquashInputPattern, +mergeInputPattern, +mergeCommitInputPattern, +names False, -- names +names True, -- names.global +namespaceDependencies, +previewAdd, +previewUpdate, +printVersion, +projectCreate, +projectCreateEmptyInputPattern, +projectRenameInputPattern, +projectSwitch, +projectsInputPattern, +pull, +pullWithoutHistory, +push, +pushCreate, +pushExhaustive, +pushForce, +quit, +releaseDraft, +renameBranch, +renameTerm, +renameType, +moveAll, +reset, +resetRoot, +runScheme, +saveExecuteResult, +test, +testAll, +todo, +ui, +undo, +up, +update, +updateBuiltins, +updateOld, +updateOldNoPatch, +upgrade, +upgradeCommitInputPattern, +view, +viewGlobal, +viewReflog +``` diff --git a/unison-src/transcripts/idempotent/io-test-command.md b/unison-src/transcripts/idempotent/io-test-command.md new file mode 100644 index 0000000000..395ac149b3 --- /dev/null +++ b/unison-src/transcripts/idempotent/io-test-command.md @@ -0,0 +1,81 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +The `io.test` command should run all of the tests within the current namespace, excluding libs. + +``` unison :hide +-- We manually specify types so we don't need to pull in base to run IO and such +ioAndExceptionTest : '{IO, Exception} [Result] +ioAndExceptionTest = do + [Ok "Success"] + +ioTest : '{IO} [Result] +ioTest = do + [Ok "Success"] + +lib.ioAndExceptionTestInLib : '{IO, Exception} [Result] +lib.ioAndExceptionTestInLib = do + [Ok "Success"] +``` + +``` ucm :hide +scratch/main> add +``` + +Run a IO tests one by one + +``` ucm +scratch/main> io.test ioAndExceptionTest + + New test results: + + 1. ioAndExceptionTest ◉ Success + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. + +scratch/main> io.test ioTest + + New test results: + + 1. ioTest ◉ Success + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +`io.test` doesn't cache results + +``` ucm +scratch/main> io.test ioAndExceptionTest + + New test results: + + 1. ioAndExceptionTest ◉ Success + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +`io.test.all` will run all matching tests except those in the `lib` namespace. + +``` ucm +scratch/main> io.test.all + + + + + + New test results: + + 1. ioAndExceptionTest ◉ Success + 2. ioTest ◉ Success + + ✅ 2 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` diff --git a/unison-src/transcripts/idempotent/io.md b/unison-src/transcripts/idempotent/io.md new file mode 100644 index 0000000000..6244e80ad8 --- /dev/null +++ b/unison-src/transcripts/idempotent/io.md @@ -0,0 +1,747 @@ +# tests for built-in IO functions + +``` ucm :hide +scratch/main> builtins.merge + +scratch/main> builtins.mergeio + +scratch/main> load unison-src/transcripts-using-base/base.u + +scratch/main> add +``` + +Tests for IO builtins which wired to foreign haskell calls. + +## Setup + +You can skip the section which is just needed to make the transcript self-contained. + +TempDirs/autoCleaned is an ability/hanlder which allows you to easily +create a scratch directory which will automatically get cleaned up. + +``` ucm :hide +scratch/main> add +``` + +## Basic File Functions + +### Creating/Deleting/Renaming Directories + +Tests: + + - createDirectory, + - isDirectory, + - fileExists, + - renameDirectory, + - deleteDirectory + +``` unison +testCreateRename : '{io2.IO} [Result] +testCreateRename _ = + test = 'let + tempDir = newTempDir "fileio" + fooDir = tempDir ++ "/foo" + barDir = tempDir ++ "/bar" + void x = () + void (createDirectory.impl fooDir) + check "create a foo directory" (isDirectory fooDir) + check "directory should exist" (fileExists fooDir) + renameDirectory fooDir barDir + check "foo should no longer exist" (not (fileExists fooDir)) + check "directory should no longer exist" (not (fileExists fooDir)) + check "bar should now exist" (fileExists barDir) + + bazDir = barDir ++ "/baz" + void (createDirectory.impl bazDir) + void (removeDirectory.impl barDir) + + check "removeDirectory works recursively" (not (isDirectory barDir)) + check "removeDirectory works recursively" (not (isDirectory bazDir)) + + runTest test +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + testCreateRename : '{IO} [Result] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + testCreateRename : '{IO} [Result] + +scratch/main> io.test testCreateRename + + New test results: + + 1. testCreateRename ◉ create a foo directory + ◉ directory should exist + ◉ foo should no longer exist + ◉ directory should no longer exist + ◉ bar should now exist + ◉ removeDirectory works recursively + ◉ removeDirectory works recursively + + ✅ 7 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +### Opening / Closing files + +Tests: + + - openFile + - closeFile + - isFileOpen + +``` unison +testOpenClose : '{io2.IO} [Result] +testOpenClose _ = + test = 'let + tempDir = (newTempDir "seek") + fooFile = tempDir ++ "/foo" + handle1 = openFile fooFile FileMode.Write + check "file should be open" (isFileOpen handle1) + setBuffering handle1 (SizedBlockBuffering 1024) + check "file handle buffering should match what we just set." (getBuffering handle1 == SizedBlockBuffering 1024) + setBuffering handle1 (getBuffering handle1) + putBytes handle1 0xs01 + setBuffering handle1 NoBuffering + setBuffering handle1 (getBuffering handle1) + putBytes handle1 0xs23 + setBuffering handle1 BlockBuffering + setBuffering handle1 (getBuffering handle1) + putBytes handle1 0xs45 + setBuffering handle1 LineBuffering + setBuffering handle1 (getBuffering handle1) + putBytes handle1 0xs67 + closeFile handle1 + check "file should be closed" (not (isFileOpen handle1)) + + -- make sure the bytes have been written + handle2 = openFile fooFile FileMode.Read + check "bytes have been written" (getBytes handle2 4 == 0xs01234567) + closeFile handle2 + + -- checking that ReadWrite mode works fine + handle3 = openFile fooFile FileMode.ReadWrite + check "bytes have been written" (getBytes handle3 4 == 0xs01234567) + closeFile handle3 + + check "file should be closed" (not (isFileOpen handle1)) + + runTest test +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + testOpenClose : '{IO} [Result] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + testOpenClose : '{IO} [Result] + +scratch/main> io.test testOpenClose + + New test results: + + 1. testOpenClose ◉ file should be open + ◉ file handle buffering should match what we just set. + ◉ file should be closed + ◉ bytes have been written + ◉ bytes have been written + ◉ file should be closed + + ✅ 6 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +### Reading files with getSomeBytes + +Tests: + + - getSomeBytes + - putBytes + - isFileOpen + - seekHandle + +``` unison +testGetSomeBytes : '{io2.IO} [Result] +testGetSomeBytes _ = + test = 'let + tempDir = (newTempDir "getSomeBytes") + fooFile = tempDir ++ "/foo" + + testData = "0123456789" + testSize = size testData + + chunkSize = 7 + check "chunk size splits data into 2 uneven sides" ((chunkSize > (testSize / 2)) && (chunkSize < testSize)) + + + -- write testData to a temporary file + fooWrite = openFile fooFile Write + putBytes fooWrite (toUtf8 testData) + closeFile fooWrite + check "file should be closed" (not (isFileOpen fooWrite)) + + -- reopen for reading back the data in chunks + fooRead = openFile fooFile Read + + -- read first part of file + chunk1 = getSomeBytes fooRead chunkSize |> fromUtf8 + check "first chunk matches first part of testData" (chunk1 == take chunkSize testData) + + -- read rest of file + chunk2 = getSomeBytes fooRead chunkSize |> fromUtf8 + check "second chunk matches rest of testData" (chunk2 == drop chunkSize testData) + + check "should be at end of file" (isFileEOF fooRead) + + readAtEOF = getSomeBytes fooRead chunkSize + check "reading at end of file results in Bytes.empty" (readAtEOF == Bytes.empty) + + -- request many bytes from the start of the file + seekHandle fooRead AbsoluteSeek +0 + bigRead = getSomeBytes fooRead (testSize * 999) |> fromUtf8 + check "requesting many bytes results in what's available" (bigRead == testData) + + closeFile fooRead + check "file should be closed" (not (isFileOpen fooRead)) + + runTest test +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + testGetSomeBytes : '{IO} [Result] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + testGetSomeBytes : '{IO} [Result] + +scratch/main> io.test testGetSomeBytes + + New test results: + + 1. testGetSomeBytes ◉ chunk size splits data into 2 uneven sides + ◉ file should be closed + ◉ first chunk matches first part of testData + ◉ second chunk matches rest of testData + ◉ should be at end of file + ◉ reading at end of file results in Bytes.empty + ◉ requesting many bytes results in what's available + ◉ file should be closed + + ✅ 8 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +### Seeking in open files + +Tests: + + - openFile + - putBytes + - closeFile + - isSeekable + - isFileEOF + - seekHandle + - getBytes + - getLine + +``` unison +testSeek : '{io2.IO} [Result] +testSeek _ = + test = 'let + tempDir = newTempDir "seek" + emit (Ok "seeked") + fooFile = tempDir ++ "/foo" + handle1 = openFile fooFile FileMode.Append + putBytes handle1 (toUtf8 "12345678") + closeFile handle1 + + handle3 = openFile fooFile FileMode.Read + check "readable file should be seekable" (isSeekable handle3) + check "shouldn't be the EOF" (not (isFileEOF handle3)) + expectU "we should be at position 0" 0 (handlePosition handle3) + + seekHandle handle3 AbsoluteSeek +1 + expectU "we should be at position 1" 1 (handlePosition handle3) + bytes3a = getBytes handle3 1000 + text3a = Text.fromUtf8 bytes3a + expectU "should be able to read our temporary file after seeking" "2345678" text3a + closeFile handle3 + + barFile = tempDir ++ "/bar" + handle4 = openFile barFile FileMode.Append + putBytes handle4 (toUtf8 "foobar\n") + closeFile handle4 + + handle5 = openFile barFile FileMode.Read + expectU "getLine should get a line" "foobar" (getLine handle5) + closeFile handle5 + + runTest test + +testSetEcho : '{io2.IO} [Result] +testSetEcho = do + a = setEcho.impl (stdHandle StdErr) true + b = setEcho.impl (stdHandle StdErr) false + match (a, b) with + (Right _, Right _) -> [ Ok "setEcho works" ] + _ -> [ Fail "setEcho failure" ] + +testAppend : '{io2.IO} [Result] +testAppend _ = + test = 'let + tempDir = newTempDir "openFile" + fooFile = tempDir ++ "/foo" + handle1 = openFile fooFile FileMode.Write + putBytes handle1 (toUtf8 "test1") + closeFile handle1 + + handle2 = openFile fooFile FileMode.Append + putBytes handle2 (toUtf8 "test2") + closeFile handle2 + + handle3 = openFile fooFile FileMode.Read + bytes3 = getBytes handle3 1000 + text3 = Text.fromUtf8 bytes3 + + expectU "should be able to read our temporary file" "test1test2" text3 + + closeFile handle3 + + runTest test +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + testAppend : '{IO} [Result] + testSeek : '{IO} [Result] + testSetEcho : '{IO} [Result] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + testAppend : '{IO} [Result] + testSeek : '{IO} [Result] + testSetEcho : '{IO} [Result] + +scratch/main> io.test testSeek + + New test results: + + 1. testSeek ◉ seeked + ◉ readable file should be seekable + ◉ shouldn't be the EOF + ◉ we should be at position 0 + ◉ we should be at position 1 + ◉ should be able to read our temporary file after seeking + ◉ getLine should get a line + + ✅ 7 test(s) passing + + Tip: Use view 1 to view the source of a test. + +scratch/main> io.test testSetEcho + + New test results: + + 1. testSetEcho ◉ setEcho works + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. + +scratch/main> io.test testAppend + + New test results: + + 1. testAppend ◉ should be able to read our temporary file + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +### SystemTime + +``` unison +testSystemTime : '{io2.IO} [Result] +testSystemTime _ = + test = 'let + t = !systemTime + check "systemTime should be sane" ((t > 1600000000) && (t < 2000000000)) + + runTest test +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + testSystemTime : '{IO} [Result] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + testSystemTime : '{IO} [Result] + +scratch/main> io.test testSystemTime + + New test results: + + 1. testSystemTime ◉ systemTime should be sane + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +### Get temp directory + +``` unison :hide +testGetTempDirectory : '{io2.IO} [Result] +testGetTempDirectory _ = + test = 'let + tempDir = reraise !getTempDirectory.impl + check "Temp directory is directory" (isDirectory tempDir) + check "Temp directory should exist" (fileExists tempDir) + runTest test +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + testGetTempDirectory : '{IO} [Result] + +scratch/main> io.test testGetTempDirectory + + New test results: + + 1. testGetTempDirectory ◉ Temp directory is directory + ◉ Temp directory should exist + + ✅ 2 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +### Get current directory + +``` unison :hide +testGetCurrentDirectory : '{io2.IO} [Result] +testGetCurrentDirectory _ = + test = 'let + currentDir = reraise !getCurrentDirectory.impl + check "Current directory is directory" (isDirectory currentDir) + check "Current directory should exist" (fileExists currentDir) + runTest test +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + testGetCurrentDirectory : '{IO} [Result] + +scratch/main> io.test testGetCurrentDirectory + + New test results: + + 1. testGetCurrentDirectory ◉ Current directory is directory + ◉ Current directory should exist + + ✅ 2 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +### Get directory contents + +``` unison :hide +testDirContents : '{io2.IO} [Result] +testDirContents _ = + test = 'let + tempDir = newTempDir "dircontents" + c = reraise (directoryContents.impl tempDir) + check "directory size should be" (size c == 2) + check "directory contents should have current directory and parent" let + (c == [".", ".."]) || (c == ["..", "."]) + runTest test +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + testDirContents : '{IO} [Result] + +scratch/main> io.test testDirContents + + New test results: + + 1. testDirContents ◉ directory size should be + ◉ directory contents should have current directory and parent + + ✅ 2 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +### Read environment variables + +``` unison :hide +testGetEnv : '{io2.IO} [Result] +testGetEnv _ = + test = 'let + path = reraise (getEnv.impl "PATH") -- PATH exists on windows, mac and linux. + check "PATH environent variable should be set" (size path > 0) + match getEnv.impl "DOESNTEXIST" with + Right _ -> emit (Fail "env var shouldn't exist") + Left _ -> emit (Ok "DOESNTEXIST didn't exist") + runTest test +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + testGetEnv : '{IO} [Result] + +scratch/main> io.test testGetEnv + + New test results: + + 1. testGetEnv ◉ PATH environent variable should be set + ◉ DOESNTEXIST didn't exist + + ✅ 2 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +### Read command line args + +`runMeWithNoArgs`, `runMeWithOneArg`, and `runMeWithTwoArgs` raise exceptions +unless they called with the right number of arguments. + +``` unison :hide +testGetArgs.fail : Text -> Failure +testGetArgs.fail descr = Failure (typeLink IOFailure) descr !Any + +testGetArgs.runMeWithNoArgs : '{io2.IO, Exception} () +testGetArgs.runMeWithNoArgs = 'let + args = reraise !getArgs.impl + match args with + [] -> printLine "called with no args" + _ -> raise (testGetArgs.fail "called with args") + +testGetArgs.runMeWithOneArg : '{io2.IO, Exception} () +testGetArgs.runMeWithOneArg = 'let + args = reraise !getArgs.impl + match args with + [] -> raise (testGetArgs.fail "called with no args") + [_] -> printLine "called with one arg" + _ -> raise (testGetArgs.fail "called with too many args") + +testGetArgs.runMeWithTwoArgs : '{io2.IO, Exception} () +testGetArgs.runMeWithTwoArgs = 'let + args = reraise !getArgs.impl + match args with + [] -> raise (testGetArgs.fail "called with no args") + [_] -> raise (testGetArgs.fail "called with one arg") + [_, _] -> printLine "called with two args" + _ -> raise (testGetArgs.fail "called with too many args") +``` + +Test that they can be run with the right number of args. + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + testGetArgs.fail : Text -> Failure + testGetArgs.runMeWithNoArgs : '{IO, Exception} () + testGetArgs.runMeWithOneArg : '{IO, Exception} () + testGetArgs.runMeWithTwoArgs : '{IO, Exception} () + +scratch/main> run runMeWithNoArgs + + () + +scratch/main> run runMeWithOneArg foo + + () + +scratch/main> run runMeWithTwoArgs foo bar + + () +``` + +Calling our examples with the wrong number of args will error. + +``` ucm :error +scratch/main> run runMeWithNoArgs foo + + 💔💥 + + The program halted with an unhandled exception: + + Failure (typeLink IOFailure) "called with args" (Any ()) + + Stack trace: + ##raise +``` + +``` ucm :error +scratch/main> run runMeWithOneArg + + 💔💥 + + The program halted with an unhandled exception: + + Failure (typeLink IOFailure) "called with no args" (Any ()) + + Stack trace: + ##raise +``` + +``` ucm :error +scratch/main> run runMeWithOneArg foo bar + + 💔💥 + + The program halted with an unhandled exception: + + Failure + (typeLink IOFailure) "called with too many args" (Any ()) + + Stack trace: + ##raise +``` + +``` ucm :error +scratch/main> run runMeWithTwoArgs + + 💔💥 + + The program halted with an unhandled exception: + + Failure (typeLink IOFailure) "called with no args" (Any ()) + + Stack trace: + ##raise +``` + +### Get the time zone + +``` unison :hide +testTimeZone = do + (offset, summer, name) = Clock.internals.systemTimeZone +0 + _ = (offset : Int, summer : Nat, name : Text) + () +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + testTimeZone : '{IO} () + +scratch/main> run testTimeZone + + () +``` + +### Get some random bytes + +``` unison :hide +testRandom : '{io2.IO} [Result] +testRandom = do + test = do + bytes = IO.randomBytes 10 + check "randomBytes returns the right number of bytes" (size bytes == 10) + runTest test +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + testRandom : '{IO} [Result] + +scratch/main> io.test testGetEnv + + New test results: + + 1. testGetEnv ◉ PATH environent variable should be set + ◉ DOESNTEXIST didn't exist + + ✅ 2 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` diff --git a/unison-src/transcripts/keyword-identifiers.md b/unison-src/transcripts/idempotent/keyword-identifiers.md similarity index 83% rename from unison-src/transcripts/keyword-identifiers.md rename to unison-src/transcripts/idempotent/keyword-identifiers.md index 665180fb39..d8574e0995 100644 --- a/unison-src/transcripts/keyword-identifiers.md +++ b/unison-src/transcripts/idempotent/keyword-identifiers.md @@ -4,34 +4,34 @@ In particular, following a keyword with a `wordyIdChar` should be a valid identi Related issues: -- https://github.com/unisonweb/unison/issues/2091 -- https://github.com/unisonweb/unison/issues/2727 + - https://github.com/unisonweb/unison/issues/2091 + - https://github.com/unisonweb/unison/issues/2727 ## Keyword list Checks the following keywords: -- `type` -- `ability` -- `structural` -- `unique` -- `if` -- `then` -- `else` -- `forall` -- `handle` -- `with` -- `where` -- `use` -- `true` -- `false` -- `alias` -- `typeLink` -- `termLink` -- `let` -- `namespace` -- `match` -- `cases` + - `type` + - `ability` + - `structural` + - `unique` + - `if` + - `then` + - `else` + - `forall` + - `handle` + - `with` + - `where` + - `use` + - `true` + - `false` + - `alias` + - `typeLink` + - `termLink` + - `let` + - `namespace` + - `match` + - `cases` Note that although `∀` is a keyword, it cannot actually appear at the start of identifier. @@ -40,7 +40,7 @@ identifier. `type`: -```unison:hide +``` unison :hide typeFoo = 99 type1 = "I am a variable" type_ = 292 @@ -52,7 +52,7 @@ structural type type! type_ = type' type_ | type'' `ability`: -```unison:hide +``` unison :hide abilityFoo = 99 ability1 = "I am a variable" ability_ = 292 @@ -63,7 +63,7 @@ structural type ability! ability_ = ability' ability_ | ability'' `structural` -```unison:hide +``` unison :hide structuralFoo = 99 structural1 = "I am a variable" structural_ = 292 @@ -74,7 +74,7 @@ structural type structural! structural_ = structural' structural_ | structural'' `unique` -```unison:hide +``` unison :hide uniqueFoo = 99 unique1 = "I am a variable" unique_ = 292 @@ -85,7 +85,7 @@ structural type unique! unique_ = unique' unique_ | unique'' `if` -```unison:hide +``` unison :hide ifFoo = 99 if1 = "I am a variable" if_ = 292 @@ -96,7 +96,7 @@ structural type if! if_ = if' if_ | if'' `then` -```unison:hide +``` unison :hide thenFoo = 99 then1 = "I am a variable" then_ = 292 @@ -107,7 +107,7 @@ structural type then! then_ = then' then_ | then'' `else` -```unison:hide +``` unison :hide elseFoo = 99 else1 = "I am a variable" else_ = 292 @@ -118,7 +118,7 @@ structural type else! else_ = else' else_ | else'' `forall` -```unison:hide +``` unison :hide forallFoo = 99 forall1 = "I am a variable" forall_ = 292 @@ -129,7 +129,7 @@ structural type forall! forall_ = forall' forall_ | forall'' `handle` -```unison:hide +``` unison :hide handleFoo = 99 handle1 = "I am a variable" handle_ = 292 @@ -140,7 +140,7 @@ structural type handle! handle_ = handle' handle_ | handle'' `with` -```unison:hide +``` unison :hide withFoo = 99 with1 = "I am a variable" with_ = 292 @@ -151,7 +151,7 @@ structural type with! with_ = with' with_ | with'' `where` -```unison:hide +``` unison :hide whereFoo = 99 where1 = "I am a variable" where_ = 292 @@ -162,7 +162,7 @@ structural type where! where_ = where' where_ | where'' `use` -```unison:hide +``` unison :hide useFoo = 99 use1 = "I am a variable" use_ = 292 @@ -173,7 +173,7 @@ structural type use! use_ = use' use_ | use'' `true` -```unison:hide +``` unison :hide trueFoo = 99 true1 = "I am a variable" true_ = 292 @@ -184,7 +184,7 @@ structural type true! true_ = true' true_ | true'' `false` -```unison:hide +``` unison :hide falseFoo = 99 false1 = "I am a variable" false_ = 292 @@ -195,7 +195,7 @@ structural type false! false_ = false' false_ | false'' `alias` -```unison:hide +``` unison :hide aliasFoo = 99 alias1 = "I am a variable" alias_ = 292 @@ -206,7 +206,7 @@ structural type alias! alias_ = alias' alias_ | alias'' `typeLink` -```unison:hide +``` unison :hide typeLinkFoo = 99 typeLink1 = "I am a variable" typeLink_ = 292 @@ -217,7 +217,7 @@ structural type typeLink! typeLink_ = typeLink' typeLink_ | typeLink'' `termLink` -```unison:hide +``` unison :hide termLinkFoo = 99 termLink1 = "I am a variable" termLink_ = 292 @@ -228,7 +228,7 @@ structural type termLink! termLink_ = termLink' termLink_ | termLink'' `let` -```unison:hide +``` unison :hide letFoo = 99 let1 = "I am a variable" let_ = 292 @@ -239,7 +239,7 @@ structural type let! let_ = let' let_ | let'' `namespace` -```unison:hide +``` unison :hide namespaceFoo = 99 namespace1 = "I am a variable" namespace_ = 292 @@ -250,7 +250,7 @@ structural type namespace! namespace_ = namespace' namespace_ | namespace'' `match` -```unison:hide +``` unison :hide matchFoo = 99 match1 = "I am a variable" match_ = 292 @@ -261,7 +261,7 @@ structural type match! match_ = match' match_ | match'' `cases` -```unison:hide +``` unison :hide casesFoo = 99 cases1 = "I am a variable" cases_ = 292 diff --git a/unison-src/transcripts/idempotent/kind-inference.md b/unison-src/transcripts/idempotent/kind-inference.md new file mode 100644 index 0000000000..3553d9941e --- /dev/null +++ b/unison-src/transcripts/idempotent/kind-inference.md @@ -0,0 +1,347 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +## A type param cannot have conflicting kind constraints within a single decl + +conflicting constraints on the kind of `a` in a product + +``` unison :error +unique type T a = T a (a Nat) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Kind mismatch arising from + 1 | unique type T a = T a (a Nat) + + a doesn't expect an argument; however, it is applied to Nat. +``` + +conflicting constraints on the kind of `a` in a sum + +``` unison :error +unique type T a + = Star a + | StarStar (a Nat) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Kind mismatch arising from + 2 | = Star a + + The arrow type (->) expects arguments of kind Type; however, + it is applied to a which has kind: Type -> Type. +``` + +## Kinds are inferred by decl component + +Successfully infer `a` in `Ping a` to be of kind `* -> *` by +inspecting its component-mate `Pong`. + +``` unison +unique type Ping a = Ping Pong +unique type Pong = Pong (Ping Optional) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Ping a + type Pong +``` + +Catch the conflict on the kind of `a` in `Ping a`. `Ping` restricts +`a` to `*`, whereas `Pong` restricts `a` to `* -> *`. + +``` unison :error +unique type Ping a = Ping a Pong +unique type Pong = Pong (Ping Optional) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Kind mismatch arising from + 1 | unique type Ping a = Ping a Pong + + The arrow type (->) expects arguments of kind Type; however, + it is applied to a which has kind: Type -> Type. +``` + +Successful example between mutually recursive type and ability + +``` unison +unique type Ping a = Ping (a Nat -> {Pong Nat} ()) +unique ability Pong a where + pong : Ping Optional -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Ping a + ability Pong a +``` + +Catch conflict between mutually recursive type and ability + +``` unison :error +unique type Ping a = Ping (a -> {Pong Nat} ()) +unique ability Pong a where + pong : Ping Optional -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Kind mismatch arising from + 3 | pong : Ping Optional -> () + + Ping expects an argument of kind: Type; however, it is + applied to Optional which has kind: Type -> Type. +``` + +Consistent instantiation of `T`'s `a` parameter in `S` + +``` unison +unique type T a = T a + +unique type S = S (T Nat) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type S + type T a +``` + +Delay kind defaulting until all components are processed. Here `S` +constrains the kind of `T`'s `a` parameter, although `S` is not in +the same component as `T`. + +``` unison +unique type T a = T + +unique type S = S (T Optional) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type S + type T a +``` + +Catch invalid instantiation of `T`'s `a` parameter in `S` + +``` unison :error +unique type T a = T a + +unique type S = S (T Optional) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Kind mismatch arising from + 3 | unique type S = S (T Optional) + + T expects an argument of kind: Type; however, it is applied + to Optional which has kind: Type -> Type. +``` + +## Checking annotations + +Catch kind error in type annotation + +``` unison :error +test : Nat Nat +test = 0 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Kind mismatch arising from + 1 | test : Nat Nat + + Nat doesn't expect an argument; however, it is applied to + Nat. +``` + +Catch kind error in annotation example 2 + +``` unison :error +test : Optional -> () +test _ = () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Kind mismatch arising from + 1 | test : Optional -> () + + The arrow type (->) expects arguments of kind Type; however, + it is applied to Optional which has kind: Type -> Type. +``` + +Catch kind error in annotation example 3 + +``` unison :error +unique type T a = T (a Nat) + +test : T Nat -> () +test _ = () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Kind mismatch arising from + 3 | test : T Nat -> () + + T expects an argument of kind: Type -> Type; however, it is + applied to Nat which has kind: Type. +``` + +Catch kind error in scoped type variable annotation + +``` unison :error +unique type StarStar a = StarStar (a Nat) +unique type Star a = Star a + +test : StarStar a -> () +test _ = + buggo : Star a + buggo = bug "" + () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Kind mismatch arising from + 6 | buggo : Star a + + Star expects an argument of kind: Type; however, it is + applied to a which has kind: Type -> Type. +``` + +## Effect/type mismatch + +Effects appearing where types are expected + +``` unison :error +unique ability Foo where + foo : () + +test : Foo -> () +test _ = () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Kind mismatch arising from + 4 | test : Foo -> () + + The arrow type (->) expects arguments of kind Type; however, + it is applied to Foo which has kind: Ability. +``` + +Types appearing where effects are expected + +``` unison :error +test : {Nat} () +test _ = () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Kind mismatch arising from + 1 | test : {Nat} () + + An ability list must consist solely of abilities; however, + this list contains Nat which has kind Type. Abilities are of + kind Ability. +``` + +## Cyclic kinds + +``` unison :error +unique type T a = T (a a) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Cannot construct infinite kind + 1 | unique type T a = T (a a) + + The above application constrains the kind of a to be + infinite, generated by the constraint k = k -> Type where k + is the kind of a. +``` + +``` unison :error +unique type T a b = T (a b) (b a) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Cannot construct infinite kind + 1 | unique type T a b = T (a b) (b a) + + The above application constrains the kind of b to be + infinite, generated by the constraint + k = (k -> Type) -> Type where k is the kind of b. +``` + +``` unison :error +unique type Ping a = Ping (a Pong) +unique type Pong a = Pong (a Ping) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Cannot construct infinite kind + 1 | unique type Ping a = Ping (a Pong) + + The above application constrains the kind of a to be + infinite, generated by the constraint + k = (((k -> Type) -> Type) -> Type) -> Type where k is the + kind of a. +``` diff --git a/unison-src/transcripts/idempotent/lambdacase.md b/unison-src/transcripts/idempotent/lambdacase.md new file mode 100644 index 0000000000..c85050e2ec --- /dev/null +++ b/unison-src/transcripts/idempotent/lambdacase.md @@ -0,0 +1,239 @@ +# Lambda case syntax + +``` ucm :hide +scratch/main> builtins.merge +``` + +This function takes a single argument and immediately pattern matches on it. As we'll see below, it can be written using `cases` syntax: + +``` unison +isEmpty x = match x with + [] -> true + _ -> false +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + isEmpty : [t] -> Boolean +``` + +``` ucm :hide +scratch/main> add +``` + +Here's the same function written using `cases` syntax: + +``` unison +isEmpty2 = cases + [] -> true + _ -> false +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + isEmpty2 : [t] -> Boolean + (also named isEmpty) +``` + +Notice that Unison detects this as an alias of `isEmpty`, and if we view `isEmpty` + +``` ucm +scratch/main> view isEmpty + + isEmpty : [t] -> Boolean + isEmpty = cases + [] -> true + _ -> false +``` + +it shows the definition using `cases` syntax opportunistically, even though the code was originally written without that syntax. + +## Multi-argument cases + +Functions that take multiple arguments and immediately match on a tuple of arguments can also be rewritten to use `cases`. Here's a version using regular `match` syntax on a tuple: + +``` unison :hide +merge : [a] -> [a] -> [a] +merge xs ys = match (xs, ys) with + ([], ys) -> ys + (xs, []) -> xs + (h +: t, h2 +: t2) -> + if h <= h2 then h +: merge t (h2 +: t2) + else h2 +: merge (h +: t) t2 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + merge : [a] -> [a] -> [a] +``` + +And here's a version using `cases`. The patterns are separated by commas: + +``` unison +merge2 : [a] -> [a] -> [a] +merge2 = cases + [], ys -> ys + xs, [] -> xs + h +: t, h2 +: t2 -> + if h <= h2 then h +: merge2 t (h2 +: t2) + else h2 +: merge2 (h +: t) t2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + merge2 : [a] -> [a] -> [a] + (also named merge) +``` + +Notice that Unison detects this as an alias of `merge`, and if we view `merge` + +``` ucm +scratch/main> view merge + + merge : [a] -> [a] -> [a] + merge = cases + [], ys -> ys + xs, [] -> xs + h +: t, h2 +: t2 -> + if h <= h2 then h +: merge t (h2 +: t2) + else h2 +: merge (h +: t) t2 +``` + +it again shows the definition using the multi-argument `cases` syntax opportunistically, even though the code was originally written without that syntax. + +Here's another example: + +``` unison +structural type B = T | F + +blah : B -> B -> Text +blah = cases + T, x -> "hi" + x, y -> "bye" + +blorf = cases + x, T -> x + x, y -> y + +> blah T F +> blah F F +> blorf T F +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type B + blah : B -> B -> Text + blorf : B -> B -> B + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 12 | > blah T F + ⧩ + "hi" + + 13 | > blah F F + ⧩ + "bye" + + 14 | > blorf T F + ⧩ + F +``` + +## Patterns with multiple guards + +``` unison +merge3 : [a] -> [a] -> [a] +merge3 = cases + [], ys -> ys + xs, [] -> xs + h +: t, h2 +: t2 | h <= h2 -> h +: merge3 t (h2 +: t2) + | otherwise -> h2 +: merge3 (h +: t) t2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + merge3 : [a] -> [a] -> [a] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + merge3 : [a] -> [a] -> [a] + +scratch/main> view merge3 + + merge3 : [a] -> [a] -> [a] + merge3 = cases + [], ys -> ys + xs, [] -> xs + h +: t, h2 +: t2 + | h <= h2 -> h +: merge3 t (h2 +: t2) + | otherwise -> h2 +: merge3 (h +: t) t2 +``` + +This is the same definition written with multiple patterns and not using the `cases` syntax; notice it is considered an alias of `merge3` above. + +``` unison +merge4 : [a] -> [a] -> [a] +merge4 a b = match (a,b) with + [], ys -> ys + xs, [] -> xs + h +: t, h2 +: t2 | h <= h2 -> h +: merge4 t (h2 +: t2) + h +: t, h2 +: t2 | otherwise -> h2 +: merge4 (h +: t) t2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + merge4 : [a] -> [a] -> [a] + (also named merge3) +``` diff --git a/unison-src/transcripts/idempotent/lsp-fold-ranges.md b/unison-src/transcripts/idempotent/lsp-fold-ranges.md new file mode 100644 index 0000000000..50f3242b57 --- /dev/null +++ b/unison-src/transcripts/idempotent/lsp-fold-ranges.md @@ -0,0 +1,57 @@ +``` ucm :hide +scratch/main> builtins.mergeio +``` + +``` unison :hide + +{{ Type doc }} +structural type Optional a = + None + | Some a + +{{ + Multi line + + Term doc +}} +List.map : + (a -> b) + -> [a] + -> [b] +List.map f = cases + (x +: xs) -> f x +: List.map f xs + [] -> [] + +test> z = let + x = "hello" + y = "world" + [Ok (x ++ y)] +``` + +``` ucm +scratch/main> debug.lsp.fold-ranges + + + 《{{ Type doc }}》 + 《structural type Optional a = + None + | Some a》 + + 《{{ + Multi line + + Term doc + }}》 + 《List.map : + (a -> b) + -> [a] + -> [b] + List.map f = cases + (x +: xs) -> f x +: List.map f xs + [] -> []》 + + 《test> z = let + x = "hello" + y = "world" + [Ok (x ++ y)]》 +``` diff --git a/unison-src/transcripts/idempotent/lsp-name-completion.md b/unison-src/transcripts/idempotent/lsp-name-completion.md new file mode 100644 index 0000000000..c3af7b2e61 --- /dev/null +++ b/unison-src/transcripts/idempotent/lsp-name-completion.md @@ -0,0 +1,46 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtins +``` + +``` unison :hide +foldMap = "top-level" +nested.deeply.foldMap = "nested" +lib.base.foldMap = "lib" +lib.dep.lib.transitive.foldMap = "transitive-lib" +-- A deeply nested definition with the same hash as the top level one. +-- This should not be included in the completion results if a better name with the same hash IS included. +lib.dep.lib.transitive_same_hash.foldMap = "top-level" +foldMapWith = "partial match" + +other = "other" +``` + +``` ucm :hide +scratch/main> add +``` + +Completion should find all the `foldMap` definitions in the codebase, +sorted by number of name segments, shortest first. + +Individual LSP clients may still handle sorting differently, e.g. doing a fuzzy match over returned results, or +prioritizing exact matches over partial matches. We don't have any control over that. + +``` ucm +scratch/main> debug.lsp-name-completion foldMap + + Matching Path Name Hash + foldMap foldMap #o38ps8p4q6 + foldMapWith foldMapWith #r9rs4mcb0m + foldMap nested.deeply.foldMap #snrjegr5dk + foldMap lib.base.foldMap #jf4buul17k + foldMap lib.dep.lib.transitive.foldMap #0o01gvr3fi +``` + +Should still find the term which has a matching hash to a better name if the better name doesn't match. + +``` ucm +scratch/main> debug.lsp-name-completion transitive_same_hash.foldMap + + Matching Path Name Hash + transitive_same_hash.foldMap lib.dep.lib.transitive_same_hash.foldMap #o38ps8p4q6 +``` diff --git a/unison-src/transcripts/idempotent/move-all.md b/unison-src/transcripts/idempotent/move-all.md new file mode 100644 index 0000000000..3a7a4abd7b --- /dev/null +++ b/unison-src/transcripts/idempotent/move-all.md @@ -0,0 +1,204 @@ +# Tests for `move` + +``` ucm :hide +scratch/main> builtins.merge +``` + +## Happy Path - namespace, term, and type + +Create a term, type, and namespace with history + +``` unison +Foo = 2 +unique type Foo = Foo +Foo.termInA = 1 +unique type Foo.T = T +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + type Foo.T + Foo : Nat + Foo.termInA : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + type Foo.T + Foo : Nat + Foo.termInA : Nat +``` + +``` unison +Foo.termInA = 2 +unique type Foo.T = T1 | T2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo.T + Foo.termInA : Nat + (also named Foo) +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +Should be able to move the term, type, and namespace, including its types, terms, and sub-namespaces. + +``` ucm +scratch/main> move Foo Bar + + Done. + +scratch/main> ls + + 1. Bar (Nat) + 2. Bar (type) + 3. Bar/ (4 terms, 1 type) + 4. builtin/ (469 terms, 74 types) + +scratch/main> ls Bar + + 1. Foo (Bar) + 2. T (type) + 3. T/ (2 terms) + 4. termInA (Nat) + +scratch/main> history Bar + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #hk3a3lsc2e + + + Adds / updates: + + T T.T1 T.T2 termInA + + - Deletes: + + T.T + + □ 2. #vqc50q3b3v (start of history) +``` + +## Happy Path - Just term + +``` unison +bonk = 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bonk : Nat +``` + +``` ucm +z/main> builtins.merge + + Done. + +z/main> add + + ⍟ I've added these definitions: + + bonk : Nat + +z/main> move bonk zonk + + Done. + +z/main> ls + + 1. builtin/ (469 terms, 74 types) + 2. zonk (Nat) +``` + +## Happy Path - Just namespace + +``` unison +bonk.zonk = 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bonk.zonk : Nat + (also named zonk) +``` + +``` ucm +a/main> builtins.merge + + Done. + +a/main> add + + ⍟ I've added these definitions: + + bonk.zonk : Nat + +a/main> move bonk zonk + + Done. + +a/main> ls + + 1. builtin/ (469 terms, 74 types) + 2. zonk/ (1 term) + +a/main> view zonk.zonk + + zonk.zonk : Nat + zonk.zonk = 5 +``` + +## Sad Path - No term, type, or namespace named src + +``` ucm :error +scratch/main> move doesntexist foo + + ⚠️ + + There is no term, type, or namespace at doesntexist. +``` diff --git a/unison-src/transcripts/idempotent/move-namespace.md b/unison-src/transcripts/idempotent/move-namespace.md new file mode 100644 index 0000000000..0b8b967bab --- /dev/null +++ b/unison-src/transcripts/idempotent/move-namespace.md @@ -0,0 +1,376 @@ +# Tests for `move.namespace` + +## Moving the Root + +I should be able to move the root into a sub-namespace + +``` unison :hide +foo = 1 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : ##Nat + +-- Should request confirmation + +scratch/main> move.namespace . .root.at.path + + ⚠️ + + Moves which affect the root branch cannot be undone, are you sure? + Re-run the same command to proceed. + +scratch/main> move.namespace . .root.at.path + + Done. + +scratch/main> ls + + 1. root/ (1 term) + +scratch/main> history + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #g97lh1m2v7 (start of history) +``` + +``` ucm +scratch/main> ls .root.at.path + + 1. foo (##Nat) + +scratch/main> history .root.at.path + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #08a6hgi6s4 (start of history) +``` + +I should be able to move a sub namespace *over* the root. + +``` ucm +-- Should request confirmation + +scratch/main> move.namespace .root.at.path . + + ⚠️ + + Moves which affect the root branch cannot be undone, are you sure? + Re-run the same command to proceed. + +scratch/main> move.namespace .root.at.path . + + Done. + +scratch/main> ls + + 1. foo (##Nat) + +scratch/main> history + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #08a6hgi6s4 (start of history) +``` + +``` ucm :error +-- should be empty + +scratch/main> ls .root.at.path + + nothing to show + +scratch/main> history .root.at.path + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #sg60bvjo91 (start of history) +``` + +``` ucm :hide +scratch/happy> builtins.merge lib.builtins +``` + +## Happy path + +Create a namespace and add some history to it + +``` unison +a.termInA = 1 +unique type a.T = T +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type a.T + a.termInA : Nat +``` + +``` ucm +scratch/happy> add + + ⍟ I've added these definitions: + + type a.T + a.termInA : Nat +``` + +``` unison +a.termInA = 2 +unique type a.T = T1 | T2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type a.T + a.termInA : Nat +``` + +``` ucm +scratch/happy> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +Should be able to move the namespace, including its types, terms, and sub-namespaces. + +``` ucm +scratch/happy> move.namespace a b + + Done. + +scratch/happy> ls b + + 1. T (type) + 2. T/ (2 terms) + 3. termInA (Nat) + +scratch/happy> history b + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #ugqniosnp0 + + + Adds / updates: + + T T.T1 T.T2 termInA + + - Deletes: + + T.T + + □ 2. #a7r726o5ut (start of history) +``` + +## Namespace history + +``` ucm :hide +scratch/history> builtins.merge lib.builtins +``` + +Create some namespaces and add some history to them + +``` unison +a.termInA = 1 +b.termInB = 10 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + a.termInA : Nat + b.termInB : Nat +``` + +``` ucm +scratch/history> add + + ⍟ I've added these definitions: + + a.termInA : Nat + b.termInB : Nat +``` + +``` unison +a.termInA = 2 +b.termInB = 11 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + a.termInA : Nat + b.termInB : Nat +``` + +``` ucm +scratch/history> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +Deleting a namespace should not leave behind any history, +if we move another to that location we expect the history to simply be the history +of the moved namespace. + +``` ucm +scratch/history> delete.namespace b + + Done. + +scratch/history> move.namespace a b + + Done. + +-- Should be the history from 'a' + +scratch/history> history b + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #j0cjjqepb3 + + + Adds / updates: + + termInA + + □ 2. #m8smmmgjso (start of history) + +-- Should be empty + +scratch/history> history a + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #sg60bvjo91 (start of history) +``` + +## Moving over an existing branch + +``` ucm :hide +scratch/existing> builtins.merge lib.builtins +``` + +Create some namespace and add some history to them + +``` unison +a.termInA = 1 +b.termInB = 10 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + a.termInA : Nat + b.termInB : Nat +``` + +``` ucm +scratch/existing> add + + ⍟ I've added these definitions: + + a.termInA : Nat + b.termInB : Nat +``` + +``` unison +a.termInA = 2 +b.termInB = 11 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + a.termInA : Nat + b.termInB : Nat +``` + +``` ucm +scratch/existing> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/existing> move.namespace a b + + ⚠️ + + A branch existed at the destination: b so I over-wrote it. + + Tip: You can use `undo` or use a hash from `reflog` to undo + this change. + + Done. +``` diff --git a/unison-src/transcripts/idempotent/name-resolution.md b/unison-src/transcripts/idempotent/name-resolution.md new file mode 100644 index 0000000000..2354c16dce --- /dev/null +++ b/unison-src/transcripts/idempotent/name-resolution.md @@ -0,0 +1,441 @@ +# Example 1 + +We have a namespace type named `Namespace.Foo` and a file type named `File.Foo`. A reference to the type `Foo` is +ambiguous. A reference to `Namespace.Foo` or `File.Foo` work fine. + +``` ucm +scratch/main> builtins.mergeio lib.builtins + + Done. +``` + +``` unison +type Namespace.Foo = Bar +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Namespace.Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Namespace.Foo +``` + +``` unison :error +type File.Foo = Baz +type UsesFoo = UsesFoo Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + ❓ + + I couldn't resolve any of these symbols: + + 2 | type UsesFoo = UsesFoo Foo + + + Symbol Suggestions + + Foo File.Foo + Namespace.Foo +``` + +``` unison +type File.Foo = Baz +type UsesFoo = UsesFoo Namespace.Foo File.Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type File.Foo + type UsesFoo +``` + +``` ucm +scratch/main> project.delete scratch +``` + +# Example 2 + +We have a namespace type named `Foo` and a file type named `File.Foo`. A reference to the type `Foo` is not ambiguous: +it refers to the namespace type (because it is an exact match). + +``` ucm +scratch/main> builtins.mergeio lib.builtins + + Done. +``` + +``` unison +type Foo = Bar +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo +``` + +``` unison +type File.Foo = Baz +type UsesFoo = UsesFoo Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type File.Foo + type UsesFoo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type File.Foo + type UsesFoo + +scratch/main> view UsesFoo + + type UsesFoo = UsesFoo Foo +``` + +``` ucm +scratch/main> project.delete scratch +``` + +# Example 3 + +We have a namespace type named `Namespace.Foo` and a file type named `Foo`. A reference to the type `Foo` is not ambiguous: +it refers to the file type (because it is an exact match). + +``` ucm +scratch/main> builtins.mergeio lib.builtins + + Done. +``` + +``` unison +type Namespace.Foo = Bar +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Namespace.Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Namespace.Foo +``` + +``` unison +type Foo = Baz +type UsesFoo = UsesFoo Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + type UsesFoo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + type UsesFoo + +scratch/main> view UsesFoo + + type UsesFoo = UsesFoo Foo +``` + +``` ucm +scratch/main> project.delete scratch +``` + +# Example 4 + +We have a namespace term `ns.foo : Nat` and a file term `file.foo : Text`. A reference to the term `foo` is ambiguous, +but resolves to `ns.foo` via TDNR. + +``` ucm +scratch/main> builtins.mergeio lib.builtins + + Done. +``` + +``` unison +ns.foo : Nat +ns.foo = 42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ns.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ns.foo : Nat +``` + +``` unison +file.foo : Text +file.foo = "foo" + +bar : Text +bar = foo ++ "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Text + file.foo : Text +``` + +``` ucm +scratch/main> project.delete scratch +``` + +# Example 4 + +We have a namespace term `ns.foo : Nat` and a file term `file.foo : Text`. A reference to the term `foo` is ambiguous, +but resolves to `file.foo` via TDNR. + +``` ucm +scratch/main> builtins.mergeio lib.builtins + + Done. +``` + +``` unison +ns.foo : Nat +ns.foo = 42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ns.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ns.foo : Nat +``` + +``` unison +file.foo : Text +file.foo = "foo" + +bar : Nat +bar = foo + 42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + file.foo : Text +``` + +``` ucm +scratch/main> project.delete scratch +``` + +# Example 4 + +We have a namespace term `ns.foo : Nat` and a file term `file.foo : Nat`. A reference to the term `foo` is ambiguous. +A reference to `ns.foo` or `file.foo` work fine. + +``` ucm +scratch/main> builtins.mergeio lib.builtins + + Done. +``` + +``` unison +ns.foo : Nat +ns.foo = 42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ns.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + ns.foo : Nat +``` + +``` unison :error +file.foo : Nat +file.foo = 43 + +bar : Nat +bar = foo + 10 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I couldn't figure out what foo refers to here: + + 5 | bar = foo + 10 + + The name foo is ambiguous. Its type should be: Nat + + I found some terms in scope that have matching names and + types. Maybe you meant one of these: + + file.foo : Nat + ns.foo : Nat +``` + +``` unison +file.foo : Nat +file.foo = 43 + +bar : Nat +bar = file.foo + ns.foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + file.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + file.foo : Nat + +scratch/main> view bar + + bar : Nat + bar = + use Nat + + file.foo + ns.foo +``` + +``` ucm +scratch/main> project.delete scratch +``` diff --git a/unison-src/transcripts/idempotent/name-segment-escape.md b/unison-src/transcripts/idempotent/name-segment-escape.md new file mode 100644 index 0000000000..4df8f773a9 --- /dev/null +++ b/unison-src/transcripts/idempotent/name-segment-escape.md @@ -0,0 +1,37 @@ +You can use a keyword or reserved operator as a name segment if you surround it with backticks. + +``` ucm :error +scratch/main> view `match` + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + `match` + +scratch/main> view `=` + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + `=` +``` + +You can also use backticks to expand the set of valid symbols in a symboly name segment to include these three: `.()` + +This allows you to spell `.` or `()` as name segments (which historically have appeared in the namespace). + +``` ucm :error +scratch/main> view `.` + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + `.` + +scratch/main> view `()` + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + `()` +``` diff --git a/unison-src/transcripts/idempotent/name-selection.md b/unison-src/transcripts/idempotent/name-selection.md new file mode 100644 index 0000000000..bc89c80b6b --- /dev/null +++ b/unison-src/transcripts/idempotent/name-selection.md @@ -0,0 +1,206 @@ +This transcript shows how the pretty-printer picks names for a hash when multiple are available. The algorithm is: + +1. Names that are "name-only" come before names that are hash qualified. So `List.map` comes before `List.map#2384a` and also `aaaa#xyz`. +2. Shorter names (in terms of segment count) come before longer ones, for instance `base.List.map` comes before `somelibrary.external.base.List.map`. +3. Otherwise if there are multiple names with a minimal number of segments, compare the names alphabetically. + +``` ucm :hide +scratch/main> builtins.merge lib.builtins + +scratch/biasing> builtins.merge lib.builtins +``` + +``` unison :hide +a.a = a.b + 1 +a.b = 0 + 1 +a.aaa.but.more.segments = 0 + 1 +``` + +Will add `a` and `b` to the codebase and give `b` a longer (in terms of segment length alias), and show that it isn't used when viewing `a`: + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + a.a : Nat + a.aaa.but.more.segments : Nat + a.b : Nat + +scratch/main> view a.a + + a.a : Nat + a.a = + use Nat + + b + 1 +``` + +Next let's introduce a conflicting symbol and show that its hash qualified name isn't used when it has an unconflicted name: + +``` unison :hide +a2.a = a2.b + 1 +a2.b = 0 + 1 +a2.aaa.but.more.segments = 0 + 1 +a2.c = 1 +a2.d = a2.c + 10 +a2.long.name.but.shortest.suffixification = 1 + +a3.a = a3.b + 1 +a3.b = 0 + 1 +a3.aaa.but.more.segments = 0 + 1 +a3.c = 2 +a3.d = a3.c + 10 +a3.long.name.but.shortest.suffixification = 1 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + a2.a : Nat + (also named a.a) + a2.aaa.but.more.segments : Nat + (also named a.b and a.aaa.but.more.segments) + a2.b : Nat + (also named a.b and a.aaa.but.more.segments) + a2.c : Nat + a2.d : Nat + a2.long.name.but.shortest.suffixification : Nat + a3.a : Nat + (also named a.a) + a3.aaa.but.more.segments : Nat + (also named a.b and a.aaa.but.more.segments) + a3.b : Nat + (also named a.b and a.aaa.but.more.segments) + a3.c : Nat + a3.d : Nat + a3.long.name.but.shortest.suffixification : Nat + +scratch/main> debug.alias.term.force a2.c a3.c + + Done. + +scratch/main> debug.alias.term.force a2.d a3.d + + Done. +``` + +At this point, `a3` is conflicted for symbols `c` and `d`, so those are deprioritized. +The original `a2` namespace has an unconflicted definition for `c` and `d`, but since there are multiple 'c's in scope, +`a2.c` is chosen because although the suffixified version has fewer segments, its fully-qualified name has the fewest segments. + +``` ucm +scratch/main> view a b c d + + a.a : Nat + a.a = + use Nat + + b + 1 + + a.b : Nat + a.b = + use Nat + + 0 + 1 + + a2.c : Nat + a2.c = 1 + + a2.d : Nat + a2.d = + use Nat + + a2.c + 10 + + a3.c#dcgdua2lj6 : Nat + a3.c#dcgdua2lj6 = 2 + + a3.d#9ivhgvhthc : Nat + a3.d#9ivhgvhthc = + use Nat + + c#dcgdua2lj6 + 10 +``` + +## Name biasing + +``` unison +deeply.nested.term = + a + 1 + +deeply.nested.num = 10 + +a = 10 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + a : Nat + deeply.nested.num : Nat + deeply.nested.term : Nat +``` + +``` ucm +scratch/biasing> add + + ⍟ I've added these definitions: + + a : Nat + deeply.nested.num : Nat + deeply.nested.term : Nat + +-- Despite being saved with name `a`, + +-- the pretty printer should prefer the suffixified 'deeply.nested.num name' over the shallow 'a'. + +-- It's closer to the term being printed. + +scratch/biasing> view deeply.nested.term + + deeply.nested.term : Nat + deeply.nested.term = + use Nat + + num + 1 +``` + +Add another term with `num` suffix to force longer suffixification of `deeply.nested.num` + +``` unison +other.num = 20 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + other.num : Nat +``` + +``` ucm +scratch/biasing> add + + ⍟ I've added these definitions: + + other.num : Nat + +-- nested.num should be preferred over the shorter name `a` due to biasing + +-- because `deeply.nested.num` is nearby to the term being viewed. + +scratch/biasing> view deeply.nested.term + + deeply.nested.term : Nat + deeply.nested.term = + use Nat + + nested.num + 1 +``` diff --git a/unison-src/transcripts/idempotent/names.md b/unison-src/transcripts/idempotent/names.md new file mode 100644 index 0000000000..ca74561ba8 --- /dev/null +++ b/unison-src/transcripts/idempotent/names.md @@ -0,0 +1,115 @@ +# `names` command + +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. +``` + +Example uses of the `names` command and output + +``` unison +-- Some names with the same value +some.place.x = 1 +some.otherplace.y = 1 +some.otherplace.x = 10 +somewhere.z = 1 +-- Some similar name with a different value +somewhere.y = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + some.otherplace.x : Nat + some.otherplace.y : Nat + some.place.x : Nat + somewhere.y : Nat + somewhere.z : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + some.otherplace.x : Nat + some.otherplace.y : Nat + some.place.x : Nat + somewhere.y : Nat + somewhere.z : Nat +``` + +`names` searches relative to the current path. + +``` ucm +-- We can search by suffix and find all definitions named 'x', and each of their aliases respectively. + +scratch/main> names x + + Terms + Hash: #gjmq673r1v + Names: some.otherplace.y some.place.x somewhere.z + + Hash: #pi25gcdv0o + Names: some.otherplace.x + +-- We can search by hash, and see all aliases of that hash + +scratch/main> names #gjmq673r1v + + Term + Hash: #gjmq673r1v + Names: some.otherplace.y some.place.x somewhere.z + +-- Works with absolute names too + +scratch/main> names .some.place.x + + Term + Hash: #gjmq673r1v + Names: some.otherplace.y some.place.x somewhere.z +``` + +`debug.names.global` searches from the root, and absolutely qualifies results + +``` ucm +-- We can search from a different branch and find all names in the codebase named 'x', and each of their aliases respectively. + +scratch/other> debug.names.global x + + Found results in scratch/main + + Terms + Hash: #gjmq673r1v + Names: some.otherplace.y some.place.x somewhere.z + + Hash: #pi25gcdv0o + Names: some.otherplace.x + +-- We can search by hash, and see all aliases of that hash in the codebase + +scratch/other> debug.names.global #gjmq673r1v + + Found results in scratch/main + + Term + Hash: #gjmq673r1v + Names: some.otherplace.y some.place.x somewhere.z + +-- We can search using an absolute name + +scratch/other> debug.names.global .some.place.x + + Found results in scratch/main + + Term + Hash: #gjmq673r1v + Names: some.otherplace.y some.place.x somewhere.z +``` diff --git a/unison-src/transcripts/idempotent/namespace-deletion-regression.md b/unison-src/transcripts/idempotent/namespace-deletion-regression.md new file mode 100644 index 0000000000..86e07b4d48 --- /dev/null +++ b/unison-src/transcripts/idempotent/namespace-deletion-regression.md @@ -0,0 +1,30 @@ +# Namespace deletion regression test + +See https://github.com/unisonweb/unison/issues/1552 + +If branch operations aren't performed in the correct order it's possible to end up with unexpected results. + +Previously the following sequence delete the current namespace +unexpectedly 😬. + +``` ucm +scratch/main> alias.term ##Nat.+ Nat.+ + + Done. + +scratch/main> ls Nat + + 1. + (##Nat -> ##Nat -> ##Nat) + +scratch/main> move.namespace Nat Nat.operators + + Done. + +scratch/main> ls Nat + + 1. operators/ (1 term) + +scratch/main> ls Nat.operators + + 1. + (##Nat -> ##Nat -> ##Nat) +``` diff --git a/unison-src/transcripts/idempotent/namespace-dependencies.md b/unison-src/transcripts/idempotent/namespace-dependencies.md new file mode 100644 index 0000000000..672c0b76f6 --- /dev/null +++ b/unison-src/transcripts/idempotent/namespace-dependencies.md @@ -0,0 +1,32 @@ +# namespace.dependencies command + +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. +``` + +``` unison :hide +const a b = a +external.mynat = 1 +mynamespace.dependsOnText = const external.mynat 10 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + const : a -> b -> a + external.mynat : Nat + mynamespace.dependsOnText : Nat + +scratch/main> namespace.dependencies mynamespace + + External dependency Dependents in scratch/main:.mynamespace + lib.builtins.Nat 1. dependsOnText + + const 1. dependsOnText + + external.mynat 1. dependsOnText +``` diff --git a/unison-src/transcripts/idempotent/namespace-directive.md b/unison-src/transcripts/idempotent/namespace-directive.md new file mode 100644 index 0000000000..f9eabb86c0 --- /dev/null +++ b/unison-src/transcripts/idempotent/namespace-directive.md @@ -0,0 +1,199 @@ +A `namespace foo` directive is optional, and may only appear at the top of a file. + +It affects the contents of the file as follows: + +1. All bindings like `x.y.z` are prefixed with the namespace; note that when this file is saved, the feedback mentions + the full bindings' names. + +``` ucm +scratch/main> builtins.mergeio lib.builtins + + Done. +``` + +``` unison +namespace foo + +baz : Nat +baz = 17 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo.baz : Nat +``` + +2. Free variables whose names exactly match bindings in the file are rewritten to refer to the prefixed binder instead. + That is, a term like `factorial = ... factorial ...` is rewritten to `foo.factorial = ... foo.factorial ...`. + +``` unison +namespace foo + +factorial : Int -> Int +factorial = cases + +0 -> +1 + n -> n * factorial (n - +1) + +longer.evil.factorial : Int -> Int +longer.evil.factorial n = n +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo.factorial : Int -> Int + foo.longer.evil.factorial : Int -> Int +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo.factorial : Int -> Int + foo.longer.evil.factorial : Int -> Int + +scratch/main> view factorial + + foo.factorial : Int -> Int + foo.factorial = cases + +0 -> +1 + n -> n Int.* foo.factorial (n Int.- +1) + + foo.longer.evil.factorial : Int -> Int + foo.longer.evil.factorial n = n +``` + +Note that in the above example, we do not want the existence of a `namespace foo` directive to determine whether the +reference to the name `factorial` within the body of `factorial` is a recursive reference (good, behavior without +namespace directive, exact-name-match-wins semantics) or an ambiguous reference (bad, as would be the case if the +bindings were expanded to `foo.factorial` and `foo.longer.evil.factorial`, but the variables left alone). + +Here are a few more examples demonstrating that type names, constructor names, generated record accessor names, and +type links are all properly handled. + +``` unison +type longer.foo.Foo = Bar +type longer.foo.Baz = { qux : Nat } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type longer.foo.Baz + type longer.foo.Foo + longer.foo.Baz.qux : Baz -> Nat + longer.foo.Baz.qux.modify : (Nat ->{g} Nat) + -> Baz + ->{g} Baz + longer.foo.Baz.qux.set : Nat -> Baz -> Baz +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type longer.foo.Baz + type longer.foo.Foo + longer.foo.Baz.qux : Baz -> Nat + longer.foo.Baz.qux.modify : (Nat ->{g} Nat) -> Baz ->{g} Baz + longer.foo.Baz.qux.set : Nat -> Baz -> Baz +``` + +``` unison +namespace foo + +type Foo = Bar +type Baz = { qux : Nat } + +type RefersToFoo = RefersToFoo Foo + +refersToBar = cases + Foo.Bar -> 17 + +refersToQux baz = + Baz.qux baz + Baz.qux baz + +hasTypeLink = + {{ {type Foo} }} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type foo.Baz + type foo.Foo + type foo.RefersToFoo + foo.Baz.qux : foo.Baz -> Nat + foo.Baz.qux.modify : (Nat ->{g} Nat) + -> foo.Baz + ->{g} foo.Baz + foo.Baz.qux.set : Nat -> foo.Baz -> foo.Baz + foo.hasTypeLink : Doc2 + foo.refersToBar : foo.Foo -> Nat + foo.refersToQux : foo.Baz -> Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type foo.Baz + type foo.Foo + type foo.RefersToFoo + foo.Baz.qux : foo.Baz -> Nat + foo.Baz.qux.modify : (Nat ->{g} Nat) + -> foo.Baz + ->{g} foo.Baz + foo.Baz.qux.set : Nat -> foo.Baz -> foo.Baz + foo.hasTypeLink : Doc2 + foo.refersToBar : foo.Foo -> Nat + foo.refersToQux : foo.Baz -> Nat + +scratch/main> view RefersToFoo refersToBar refersToQux hasTypeLink + + type foo.RefersToFoo = RefersToFoo foo.Foo + + foo.hasTypeLink : Doc2 + foo.hasTypeLink = {{ {type foo.Foo} }} + + foo.refersToBar : foo.Foo -> Nat + foo.refersToBar = cases foo.Foo.Bar -> 17 + + foo.refersToQux : foo.Baz -> Nat + foo.refersToQux baz = + use Nat + + use foo.Baz qux + qux baz + qux baz + +scratch/main> todo + + You have no pending todo items. Good work! ✅ +``` diff --git a/unison-src/transcripts/idempotent/numbered-args.md b/unison-src/transcripts/idempotent/numbered-args.md new file mode 100644 index 0000000000..1b6166f0d4 --- /dev/null +++ b/unison-src/transcripts/idempotent/numbered-args.md @@ -0,0 +1,164 @@ +# Using numbered arguments in UCM + +``` ucm :hide +scratch/main> alias.type ##Text Text +``` + +First lets add some contents to our codebase. + +``` unison +foo = "foo" +bar = "bar" +baz = "baz" +qux = "qux" +quux = "quux" +corge = "corge" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Text + baz : Text + corge : Text + foo : Text + quux : Text + qux : Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Text + baz : Text + corge : Text + foo : Text + quux : Text + qux : Text +``` + +We can get the list of things in the namespace, and UCM will give us a numbered +list: + +``` ucm +scratch/main> find + + 1. bar : Text + 2. baz : Text + 3. corge : Text + 4. foo : Text + 5. quux : Text + 6. qux : Text + 7. builtin type Text +``` + +We can ask to `view` the second element of this list: + +``` ucm +scratch/main> find + + 1. bar : Text + 2. baz : Text + 3. corge : Text + 4. foo : Text + 5. quux : Text + 6. qux : Text + 7. builtin type Text + +scratch/main> view 2 + + baz : Text + baz = "baz" +``` + +And we can `view` multiple elements by separating with spaces: + +``` ucm +scratch/main> find + + 1. bar : Text + 2. baz : Text + 3. corge : Text + 4. foo : Text + 5. quux : Text + 6. qux : Text + 7. builtin type Text + +scratch/main> view 2 3 5 + + baz : Text + baz = "baz" + + corge : Text + corge = "corge" + + quux : Text + quux = "quux" +``` + +We can also ask for a range: + +``` ucm +scratch/main> find + + 1. bar : Text + 2. baz : Text + 3. corge : Text + 4. foo : Text + 5. quux : Text + 6. qux : Text + 7. builtin type Text + +scratch/main> view 2-4 + + baz : Text + baz = "baz" + + corge : Text + corge = "corge" + + foo : Text + foo = "foo" +``` + +And we can ask for multiple ranges and use mix of ranges and numbers: + +``` ucm +scratch/main> find + + 1. bar : Text + 2. baz : Text + 3. corge : Text + 4. foo : Text + 5. quux : Text + 6. qux : Text + 7. builtin type Text + +scratch/main> view 1-3 4 5-6 + + bar : Text + bar = "bar" + + baz : Text + baz = "baz" + + corge : Text + corge = "corge" + + foo : Text + foo = "foo" + + quux : Text + quux = "quux" + + qux : Text + qux = "qux" +``` diff --git a/unison-src/transcripts/idempotent/old-fold-right.md b/unison-src/transcripts/idempotent/old-fold-right.md new file mode 100644 index 0000000000..fe321cb955 --- /dev/null +++ b/unison-src/transcripts/idempotent/old-fold-right.md @@ -0,0 +1,29 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +oldRight: (b ->{e} a ->{e} b) -> [a] ->{e} [b] +oldRight f la = bug "out" + +pecan: '{} [Text] +pecan = 'let + la = [1, 2, 3] + f: Text -> Nat -> Text + f = bug "out" + + oldRight f la +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + oldRight : (b ->{e} a ->{e} b) -> [a] ->{e} [b] + pecan : '[Text] +``` diff --git a/unison-src/transcripts/idempotent/pattern-match-coverage.md b/unison-src/transcripts/idempotent/pattern-match-coverage.md new file mode 100644 index 0000000000..144c546419 --- /dev/null +++ b/unison-src/transcripts/idempotent/pattern-match-coverage.md @@ -0,0 +1,1290 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +# Basics + +## non-exhaustive patterns + +``` unison :error +unique type T = A | B | C + +test : T -> () +test = cases + A -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 4 | test = cases + 5 | A -> () + + + Patterns not matched: + + * B + * C +``` + +``` unison :error +unique type T = A | B + +test : (T, Optional T) -> () +test = cases + (A, Some _) -> () + (A, None) -> () + (B, Some A) -> () + (B, None) -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 4 | test = cases + 5 | (A, Some _) -> () + 6 | (A, None) -> () + 7 | (B, Some A) -> () + 8 | (B, None) -> () + + + Patterns not matched: + * (B, Some B) +``` + +## redundant patterns + +``` unison :error +unique type T = A | B | C + +test : T -> () +test = cases + A -> () + B -> () + C -> () + _ -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 8 | _ -> () + +``` + +``` unison :error +unique type T = A | B + +test : (T, Optional T) -> () +test = cases + (A, Some _) -> () + (A, None) -> () + (B, Some _) -> () + (B, None) -> () + (A, Some A) -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 9 | (A, Some A) -> () + +``` + +# Uninhabited patterns + +match is complete without covering uninhabited patterns + +``` unison +unique type V = + +test : Optional (Optional V) -> () +test = cases + None -> () + Some None -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type V + test : Optional (Optional V) -> () +``` + +uninhabited patterns are reported as redundant + +``` unison :error +unique type V = + +test0 : V -> () +test0 = cases + _ -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 5 | _ -> () + +``` + +``` unison :error +unique type V = + +test : Optional (Optional V) -> () +test = cases + None -> () + Some None -> () + Some _ -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 7 | Some _ -> () + +``` + +# Guards + +## Incomplete patterns due to guards should be reported + +``` unison :error +test : () -> () +test = cases + () | false -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | test = cases + 3 | () | false -> () + + + Patterns not matched: + * () +``` + +``` unison :error +test : Optional Nat -> Nat +test = cases + None -> 0 + Some x + | isEven x -> x +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | test = cases + 3 | None -> 0 + 4 | Some x + 5 | | isEven x -> x + + + Patterns not matched: + * Some _ +``` + +## Complete patterns with guards should be accepted + +``` unison :error +test : Optional Nat -> Nat +test = cases + None -> 0 + Some x + | isEven x -> x + | otherwise -> 0 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + test : Optional Nat -> Nat +``` + +# Pattern instantiation depth + +Uncovered patterns are only instantiated as deeply as necessary to +distinguish them from existing patterns. + +``` unison :error +unique type T = A | B | C + +test : Optional (Optional T) -> () +test = cases + None -> () + Some None -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 4 | test = cases + 5 | None -> () + 6 | Some None -> () + + + Patterns not matched: + * Some (Some _) +``` + +``` unison :error +unique type T = A | B | C + +test : Optional (Optional T) -> () +test = cases + None -> () + Some None -> () + Some (Some A) -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 4 | test = cases + 5 | None -> () + 6 | Some None -> () + 7 | Some (Some A) -> () + + + Patterns not matched: + + * Some (Some B) + * Some (Some C) +``` + +# Literals + +## Non-exhaustive + +Nat + +``` unison :error +test : Nat -> () +test = cases + 0 -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | test = cases + 3 | 0 -> () + + + Patterns not matched: + * _ +``` + +Boolean + +``` unison :error +test : Boolean -> () +test = cases + true -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | test = cases + 3 | true -> () + + + Patterns not matched: + * false +``` + +## Exhaustive + +Nat + +``` unison +test : Nat -> () +test = cases + 0 -> () + _ -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + test : Nat -> () +``` + +Boolean + +``` unison +test : Boolean -> () +test = cases + true -> () + false -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + test : Boolean -> () +``` + +# Redundant + +Nat + +``` unison :error +test : Nat -> () +test = cases + 0 -> () + 0 -> () + _ -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 4 | 0 -> () + +``` + +Boolean + +``` unison :error +test : Boolean -> () +test = cases + true -> () + false -> () + _ -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 5 | _ -> () + +``` + +# Sequences + +## Exhaustive + +``` unison +test : [()] -> () +test = cases + [] -> () + x +: xs -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + test : [()] -> () +``` + +## Non-exhaustive + +``` unison :error +test : [()] -> () +test = cases + [] -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | test = cases + 3 | [] -> () + + + Patterns not matched: + * (() +: _) +``` + +``` unison :error +test : [()] -> () +test = cases + x +: xs -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | test = cases + 3 | x +: xs -> () + + + Patterns not matched: + * [] +``` + +``` unison :error +test : [()] -> () +test = cases + xs :+ x -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | test = cases + 3 | xs :+ x -> () + + + Patterns not matched: + * [] +``` + +``` unison :error +test : [()] -> () +test = cases + x0 +: (x1 +: xs) -> () + [] -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | test = cases + 3 | x0 +: (x1 +: xs) -> () + 4 | [] -> () + + + Patterns not matched: + * (() +: []) +``` + +``` unison :error +test : [()] -> () +test = cases + [] -> () + x0 +: [] -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | test = cases + 3 | [] -> () + 4 | x0 +: [] -> () + + + Patterns not matched: + * (() +: (() +: _)) +``` + +## Uninhabited + +`Cons` is not expected since `V` is uninhabited + +``` unison +unique type V = + +test : [V] -> () +test = cases + [] -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type V + test : [V] -> () +``` + +## Length restrictions can equate cons and nil patterns + +Here the first pattern matches lists of length two or greater, the +second pattern matches lists of length 0. The third case matches when the +final element is `false`, while the fourth pattern matches when the +first element is `true`. However, the only possible list length at +the third or fourth clause is 1, so the first and final element must +be equal. Thus, the pattern match is exhaustive. + +``` unison +test : [Boolean] -> () +test = cases + [a, b] ++ xs -> () + [] -> () + xs :+ false -> () + true +: xs -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + test : [Boolean] -> () +``` + +This is the same idea as above but shows that fourth match is redundant. + +``` unison :error +test : [Boolean] -> () +test = cases + [a, b] ++ xs -> () + [] -> () + xs :+ true -> () + true +: xs -> () + _ -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 6 | true +: xs -> () + +``` + +This is another similar example. The first pattern matches lists of +length 5 or greater. The second matches lists of length 4 or greater where the +first and third element are true. The third matches lists of length 4 +or greater where the final 4 elements are `true, false, true, false`. +The list must be exactly of length 4 to arrive at the second or third +clause, so the third pattern is redundant. + +``` unison :error +test : [Boolean] -> () +test = cases + [a, b, c, d, f] ++ xs -> () + [true, _, true, _] ++ _ -> () + _ ++ [true, false, true, false] -> () + _ -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 5 | _ ++ [true, false, true, false] -> () + +``` + +# bugfix: Sufficient data decl map + +``` unison +unique type T = A + +unit2t : Unit -> T +unit2t = cases + () -> A +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type T + unit2t : 'T +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type T + unit2t : 'T +``` + +Pattern coverage checking needs the data decl map to contain all +transitive type dependencies of the scrutinee type. We do this +before typechecking begins in a roundabout way: fetching all +transitive type dependencies of references that appear in the expression. + +This test ensures that we have fetched the `T` type although there is +no data decl reference to `T` in `witht`. + +``` unison +witht : Unit +witht = match unit2t () with + x -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + witht : () +``` + +``` unison +unique type V = + +evil : Unit -> V +evil = bug "" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type V + evil : 'V +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type V + evil : 'V +``` + +``` unison :error +withV : Unit +withV = match evil () with + x -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 3 | x -> () + +``` + +``` unison +unique type SomeType = A +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type SomeType +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type SomeType +``` + +``` unison +unique type R = R SomeType + +get x = match x with + R y -> y +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type R + get : R -> SomeType +``` + +``` unison +unique type R = { someType : SomeType } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type R + R.someType : R -> SomeType + R.someType.modify : (SomeType ->{g} SomeType) -> R ->{g} R + R.someType.set : SomeType -> R -> R +``` + +# Ability handlers + +## Exhaustive ability handlers are accepted + +``` unison +structural ability Abort where + abort : {Abort} a + + +result : '{e, Abort} a -> {e} a +result f = handle !f with cases + { x } -> x + { abort -> _ } -> bug "aborted" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Abort + result : '{e, Abort} a ->{e} a +``` + +``` unison +structural ability Abort where + abort : {Abort} a + +unique type T = A | B + +result : '{e, Abort} T -> {e} () +result f = handle !f with cases + { T.A } -> () + { B } -> () + { abort -> _ } -> bug "aborted" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Abort + result : '{e, Abort} T ->{e} () + + ⍟ These names already exist. You can `update` them to your + new definition: + + type T +``` + +``` unison +structural ability Abort where + abort : {Abort} a + +result : '{e, Abort} V -> {e} V +result f = + impl : Request {Abort} V -> V + impl = cases + { abort -> _ } -> bug "aborted" + handle !f with impl +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Abort + result : '{e, Abort} V ->{e} V +``` + +``` unison +structural ability Abort where + abort : {Abort} a + +structural ability Stream a where + emit : a -> {Stream a} Unit + +handleMulti : '{Stream a, Abort} r -> (Optional r, [a]) +handleMulti c = + impl xs = cases + { r } -> (Some r, xs) + { emit x -> resume } -> handle !resume with impl (xs :+ x) + { abort -> _ } -> (None, xs) + handle !c with impl [] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Abort + structural ability Stream a + handleMulti : '{Abort, Stream a} r -> (Optional r, [a]) +``` + +## Non-exhaustive ability handlers are rejected + +``` unison :error +structural ability Abort where + abort : {Abort} a + abortWithMessage : Text -> {Abort} a + + +result : '{e, Abort} a -> {e} a +result f = handle !f with cases + { abort -> _ } -> bug "aborted" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 7 | result f = handle !f with cases + 8 | { abort -> _ } -> bug "aborted" + + + Patterns not matched: + + * { _ } + * { abortWithMessage _ -> _ } +``` + +``` unison :error +structural ability Abort where + abort : {Abort} a + +unique type T = A | B + +result : '{e, Abort} T -> {e} () +result f = handle !f with cases + { T.A } -> () + { abort -> _ } -> bug "aborted" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 7 | result f = handle !f with cases + 8 | { T.A } -> () + 9 | { abort -> _ } -> bug "aborted" + + + Patterns not matched: + * { B } +``` + +``` unison :error +unique ability Give a where + give : a -> {Give a} Unit + +unique type T = A | B + +result : '{e, Give T} r -> {e} r +result f = handle !f with cases + { x } -> x + { give T.A -> resume } -> result resume +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 7 | result f = handle !f with cases + 8 | { x } -> x + 9 | { give T.A -> resume } -> result resume + + + Patterns not matched: + * { give B -> _ } +``` + +``` unison :error +structural ability Abort where + abort : {Abort} a + +structural ability Stream a where + emit : a -> {Stream a} Unit + +handleMulti : '{Stream a, Abort} r -> (Optional r, [a]) +handleMulti c = + impl : [a] -> Request {Stream a, Abort} r -> (Optional r, [a]) + impl xs = cases + { r } -> (Some r, xs) + { emit x -> resume } -> handle !resume with impl (xs :+ x) + handle !c with impl [] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 10 | impl xs = cases + 11 | { r } -> (Some r, xs) + 12 | { emit x -> resume } -> handle !resume with impl (xs :+ x) + + + Patterns not matched: + * { abort -> _ } +``` + +## Redundant handler cases are rejected + +``` unison :error +unique ability Give a where + give : a -> {Give a} Unit + +unique type T = A | B + +result : '{e, Give T} r -> {e} r +result f = handle !f with cases + { x } -> x + { give _ -> resume } -> result resume + { give T.A -> resume } -> result resume +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 10 | { give T.A -> resume } -> result resume + +``` + +## Exhaustive ability reinterpretations are accepted + +``` unison +structural ability Abort where + abort : {Abort} a + abortWithMessage : Text -> {Abort} a + + +result : '{e, Abort} a -> {e, Abort} a +result f = handle !f with cases + { x } -> x + { abort -> _ } -> abort + { abortWithMessage msg -> _ } -> abortWithMessage ("aborting: " ++ msg) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Abort + result : '{e, Abort} a ->{e, Abort} a +``` + +``` unison +structural ability Abort a where + abort : {Abort a} r + abortWithMessage : a -> {Abort a} r + +result : '{e, Abort V} a -> {e, Abort V} a +result f = + impl : Request {Abort V} r -> {Abort V} r + impl = cases + { x } -> x + { abort -> _ } -> abort + handle !f with impl +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Abort a + result : '{e, Abort V} a ->{e, Abort V} a +``` + +## Non-exhaustive ability reinterpretations are rejected + +``` unison :error +structural ability Abort where + abort : {Abort} a + abortWithMessage : Text -> {Abort} a + + +result : '{e, Abort} a -> {e, Abort} a +result f = handle !f with cases + { x } -> x + { abortWithMessage msg -> _ } -> abortWithMessage ("aborting: " ++ msg) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 7 | result f = handle !f with cases + 8 | { x } -> x + 9 | { abortWithMessage msg -> _ } -> abortWithMessage ("aborting: " ++ msg) + + + Patterns not matched: + * { abort -> _ } +``` + +## Hacky workaround for uninhabited abilities + +Although all of the constructors of an ability might be uninhabited, +the typechecker requires at least one be specified so that it can +determine that the ability should be discharged. So, the default +pattern match coverage checking behavior of prohibiting covering any +of the cases is problematic. Instead, the pattern match coverage +checker will require that at least one constructor be given, even if +they are all uninhabited. + +The messages here aren't the best, but I don't think uninhabited +abilities will come up and get handlers written for them often. + +``` unison :error +unique ability Give a where + give : a -> {Give a} Unit + give2 : a -> {Give a} Unit + +result : '{e, Give V} r -> {e} r +result f = + impl : Request {Give V} r -> {} r + impl = cases + { x } -> x + handle !f with impl +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 8 | impl = cases + 9 | { x } -> x + + + Patterns not matched: + + * { give _ -> _ } + * { give2 _ -> _ } +``` + +``` unison +unique ability Give a where + give : a -> {Give a} Unit + give2 : a -> {Give a} Unit + +result : '{e, Give V} r -> {e} r +result f = + impl : Request {Give V} r -> {} r + impl = cases + { x } -> x + { give _ -> resume } -> bug "impossible" + handle !f with impl +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ability Give a + result : '{e, Give V} r ->{e} r +``` + +``` unison +unique ability Give a where + give : a -> {Give a} Unit + give2 : a -> {Give a} Unit + +result : '{e, Give V} r -> {e} r +result f = + impl : Request {Give V} r -> {} r + impl = cases + { x } -> x + { give2 _ -> resume } -> bug "impossible" + handle !f with impl +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ability Give a + result : '{e, Give V} r ->{e} r +``` + +``` unison :error +unique ability Give a where + give : a -> {Give a} Unit + give2 : a -> {Give a} Unit + +result : '{e, Give V} r -> {e} r +result f = + impl : Request {Give V} r -> {} r + impl = cases + { x } -> x + { give _ -> resume } -> bug "impossible" + { give2 _ -> resume } -> bug "impossible" + handle !f with impl +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 11 | { give2 _ -> resume } -> bug "impossible" + +``` + +``` unison :error +unique ability GiveA a where + giveA : a -> {GiveA a} Unit + giveA2 : a -> {GiveA a} Unit + +unique ability GiveB a where + giveB : a -> {GiveB a} Unit + giveB2 : a -> {GiveB a} Unit + +result : '{e, GiveA V, GiveB V} r -> {e} r +result f = + impl : Request {GiveA V, GiveB V} r -> {} r + impl = cases + { x } -> x + { giveA _ -> _ } -> bug "impossible" + { giveA2 _ -> _ } -> bug "impossible" + { giveB _ -> _ } -> bug "impossible" + { giveB2 _ -> _ } -> bug "impossible" + handle !f with impl +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 15 | { giveA2 _ -> _ } -> bug "impossible" + +``` + +``` unison +unique ability GiveA a where + giveA : a -> {GiveA a} Unit + giveA2 : a -> {GiveA a} Unit + +unique ability GiveB a where + giveB : a -> {GiveB a} Unit + giveB2 : a -> {GiveB a} Unit + +result : '{e, GiveA V, GiveB V} r -> {e} r +result f = + impl : Request {GiveA V, GiveB V} r -> {} r + impl = cases + { x } -> x + { giveA2 _ -> _ } -> bug "impossible" + { giveB _ -> _ } -> bug "impossible" + handle !f with impl +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + ability GiveA a + ability GiveB a + result : '{e, GiveB V, GiveA V} r ->{e} r +``` diff --git a/unison-src/transcripts/idempotent/pattern-pretty-print-2345.md b/unison-src/transcripts/idempotent/pattern-pretty-print-2345.md new file mode 100644 index 0000000000..860329390d --- /dev/null +++ b/unison-src/transcripts/idempotent/pattern-pretty-print-2345.md @@ -0,0 +1,206 @@ +Regression test for https://github.com/unisonweb/unison/pull/2377 + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +structural ability Ab where + a: Nat -> () + +dopey = cases + ?0 -> () + _ -> () + +grumpy = cases + d -> () + +happy = cases + true -> () + false -> () + +sneezy = cases + +1 -> () + _ -> () + +bashful = cases + Some a -> () + _ -> () + +mouthy = cases + [] -> () + _ -> () + +pokey = cases + h +: t -> () + _ -> () + +sleepy = cases + i :+ l -> () + _ -> () + +demure = cases + [0] -> () + _ -> () + +angry = cases + a ++ [] -> () + +tremulous = cases + (0,1) -> () + _ -> () + +throaty = cases + { Ab.a a -> k } -> () + { _ } -> () + +agitated = cases + a | a == 2 -> () + _ -> () + +doc = cases + y@4 -> () + _ -> () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Ab + agitated : Nat -> () + angry : [t] -> () + bashful : Optional a -> () + demure : [Nat] -> () + doc : Nat -> () + dopey : Char -> () + grumpy : ff284oqf651 -> () + happy : Boolean -> () + mouthy : [t] -> () + pokey : [t] -> () + sleepy : [t] -> () + sneezy : Int -> () + throaty : Request {g, Ab} x -> () + tremulous : (Nat, Nat) -> () +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural ability Ab + agitated : Nat -> () + angry : [t] -> () + bashful : Optional a -> () + demure : [Nat] -> () + doc : Nat -> () + dopey : Char -> () + grumpy : ff284oqf651 -> () + happy : Boolean -> () + mouthy : [t] -> () + pokey : [t] -> () + sleepy : [t] -> () + sneezy : Int -> () + throaty : Request {g, Ab} x -> () + tremulous : (Nat, Nat) -> () + +scratch/main> view dopey + + dopey : Char -> () + dopey = cases + ?0 -> () + _ -> () + +scratch/main> view grumpy + + grumpy : ff284oqf651 -> () + grumpy = cases d -> () + +scratch/main> view happy + + happy : Boolean -> () + happy = cases + true -> () + false -> () + +scratch/main> view sneezy + + sneezy : Int -> () + sneezy = cases + +1 -> () + _ -> () + +scratch/main> view bashful + + bashful : Optional a -> () + bashful = cases + Some a -> () + _ -> () + +scratch/main> view mouthy + + mouthy : [t] -> () + mouthy = cases + [] -> () + _ -> () + +scratch/main> view pokey + + pokey : [t] -> () + pokey = cases + h +: t -> () + _ -> () + +scratch/main> view sleepy + + sleepy : [t] -> () + sleepy = cases + i :+ l -> () + _ -> () + +scratch/main> view demure + + demure : [Nat] -> () + demure = cases + [0] -> () + _ -> () + +scratch/main> view angry + + angry : [t] -> () + angry = cases a ++ [] -> () + +scratch/main> view tremulous + + tremulous : (Nat, Nat) -> () + tremulous = cases + (0, 1) -> () + _ -> () + +scratch/main> view throaty + + throaty : Request {g, Ab} x -> () + throaty = cases + { Ab.a a -> k } -> () + { _ } -> () + +scratch/main> view agitated + + agitated : Nat -> () + agitated = cases + a | a == 2 -> () + _ -> () + +scratch/main> view doc + + doc : Nat -> () + doc = cases + y@4 -> () + _ -> () +``` diff --git a/unison-src/transcripts/idempotent/patternMatchTls.md b/unison-src/transcripts/idempotent/patternMatchTls.md new file mode 100644 index 0000000000..fc6517f872 --- /dev/null +++ b/unison-src/transcripts/idempotent/patternMatchTls.md @@ -0,0 +1,51 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +We had bugs in the calling conventions for both send and terminate which would +cause pattern matching on the resulting (Right ()) would cause a runtime error. + +``` unison +use builtin.io2.Tls newClient send handshake terminate + +frank: '{IO} () +frank = do + socket = assertRight (clientSocket.impl "example.com" "443") + config = ClientConfig.default "example.com" 0xs + tls = assertRight (newClient.impl config socket) + () = assertRight (handshake.impl tls) + () = assertRight (send.impl tls 0xs) + () = assertRight (terminate.impl tls) + () + +assertRight : Either a b -> b +assertRight = cases + Right x -> x + Left _ -> bug "expected a right but got a left" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + assertRight : Either a b -> b + frank : '{IO} () +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + assertRight : Either a b -> b + frank : '{IO} () + +scratch/main> run frank + + () +``` diff --git a/unison-src/transcripts/idempotent/patterns.md b/unison-src/transcripts/idempotent/patterns.md new file mode 100644 index 0000000000..1baa09fdda --- /dev/null +++ b/unison-src/transcripts/idempotent/patterns.md @@ -0,0 +1,35 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Some tests of pattern behavior. + +``` unison +p1 = join [literal "blue", literal "frog"] + +> Pattern.run (many p1) "bluefrogbluegoat" +> Pattern.run (many.corrected p1) "bluefrogbluegoat" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + p1 : Pattern Text + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 3 | > Pattern.run (many p1) "bluefrogbluegoat" + ⧩ + Some ([], "goat") + + 4 | > Pattern.run (many.corrected p1) "bluefrogbluegoat" + ⧩ + Some ([], "bluegoat") +``` diff --git a/unison-src/transcripts/idempotent/propagate.md b/unison-src/transcripts/idempotent/propagate.md new file mode 100644 index 0000000000..c4c24e2634 --- /dev/null +++ b/unison-src/transcripts/idempotent/propagate.md @@ -0,0 +1,175 @@ +# Propagating type edits + +``` ucm :hide +scratch/main> builtins.merge lib.builtins +``` + +We introduce a type `Foo` with a function dependent `fooToInt`. + +``` unison +unique type Foo = Foo + +fooToInt : Foo -> Int +fooToInt _ = +42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + fooToInt : Foo -> Int +``` + +And then we add it. + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + fooToInt : Foo -> Int + +scratch/main> find.verbose + + 1. -- #j743idicb1sf7udts85812agaml4rkfi3iss6lstvmvgufibd40blq5qtmoh9ndrtkvkaqkurn7npgc61ob8j2louj04j8slkppsl90 + type Foo + + 2. -- #j743idicb1sf7udts85812agaml4rkfi3iss6lstvmvgufibd40blq5qtmoh9ndrtkvkaqkurn7npgc61ob8j2louj04j8slkppsl90#0 + Foo.Foo : Foo + + 3. -- #sd7apvqbpk3vl2aassq4gcckovohqrs05ne1g9ol0fb6gd227bp388osj7bg40kttt2o9f1kit9avlb94ep8q1ho3g284ursrplb4l0 + fooToInt : Foo -> Int + + +scratch/main> view fooToInt + + fooToInt : Foo -> Int + fooToInt _ = +42 +``` + +Then if we change the type `Foo`... + +``` unison +unique type Foo = Foo | Bar +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +and update the codebase to use the new type `Foo`... + +``` ucm +scratch/main> update.old + + ⍟ I've updated these names to your new definition: + + type Foo +``` + +... it should automatically propagate the type to `fooToInt`. + +``` ucm +scratch/main> view fooToInt + + fooToInt : Foo -> Int + fooToInt _ = +42 +``` + +### Preserving user type variables + +We make a term that has a dependency on another term and also a non-redundant +user-provided type signature. + +``` unison +preserve.someTerm : Optional foo -> Optional foo +preserve.someTerm x = x + +preserve.otherTerm : Optional baz -> Optional baz +preserve.otherTerm y = someTerm y +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + preserve.otherTerm : Optional baz -> Optional baz + preserve.someTerm : Optional foo -> Optional foo +``` + +Add that to the codebase: + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + preserve.otherTerm : Optional baz -> Optional baz + preserve.someTerm : Optional foo -> Optional foo +``` + +Let's now edit the dependency: + +``` unison +preserve.someTerm : Optional x -> Optional x +preserve.someTerm _ = None +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + preserve.someTerm : Optional x -> Optional x +``` + +Update... + +``` ucm +scratch/main> update.old + + ⍟ I've updated these names to your new definition: + + preserve.someTerm : Optional x -> Optional x +``` + +Now the type of `someTerm` should be `Optional x -> Optional x` and the +type of `otherTerm` should remain the same. + +``` ucm +scratch/main> view preserve.someTerm + + preserve.someTerm : Optional x -> Optional x + preserve.someTerm _ = None + +scratch/main> view preserve.otherTerm + + preserve.otherTerm : Optional baz -> Optional baz + preserve.otherTerm y = someTerm y +``` diff --git a/unison-src/transcripts/idempotent/pull-errors.md b/unison-src/transcripts/idempotent/pull-errors.md new file mode 100644 index 0000000000..bb1746e231 --- /dev/null +++ b/unison-src/transcripts/idempotent/pull-errors.md @@ -0,0 +1,42 @@ +``` ucm :error +test/main> pull @aryairani/test-almost-empty/main lib.base_latest + + The use of `pull` to install libraries is now deprecated. + Going forward, you can use + `lib.install @aryairani/test-almost-empty/main`. + + Downloaded 2 entities. + + I installed @aryairani/test-almost-empty/main as + aryairani_test_almost_empty_main. + +test/main> pull @aryairani/test-almost-empty/main a.b + + ⚠️ + + Sorry, I wasn’t sure how to process your request: + + I think you want to merge @aryairani/test-almost-empty/main + into the a.b namespace, but the `pull` command only supports + merging into the top level of a local project branch. + + You can run `help pull` for more information on using `pull`. + +test/main> pull @aryairani/test-almost-empty/main a + + I think you want to merge @aryairani/test-almost-empty/main + into the a branch, but it doesn't exist. If you want, you can + create it with `branch.empty a`, and then `pull` again. + +test/main> pull @aryairani/test-almost-empty/main .a + + ⚠️ + + Sorry, I wasn’t sure how to process your request: + + I think you want to merge @aryairani/test-almost-empty/main + into the .a namespace, but the `pull` command only supports + merging into the top level of a local project branch. + + You can run `help pull` for more information on using `pull`. +``` diff --git a/unison-src/transcripts/idempotent/records.md b/unison-src/transcripts/idempotent/records.md new file mode 100644 index 0000000000..40ab77e278 --- /dev/null +++ b/unison-src/transcripts/idempotent/records.md @@ -0,0 +1,205 @@ +Ensure that Records keep their syntax after being added to the codebase + +``` ucm :hide +scratch/main> builtins.merge + +scratch/main> load unison-src/transcripts-using-base/base.u +``` + +## Record with 1 field + +``` unison :hide +unique type Record1 = { a : Text } +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view Record1 + + type Record1 = { a : Text } +``` + +## Record with 2 fields + +``` unison :hide +unique type Record2 = { a : Text, b : Int } +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view Record2 + + type Record2 = { a : Text, b : Int } +``` + +## Record with 3 fields + +``` unison :hide +unique type Record3 = { a : Text, b : Int, c : Nat } +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view Record3 + + type Record3 = { a : Text, b : Int, c : Nat } +``` + +## Record with many fields + +``` unison :hide +unique type Record4 = + { a : Text + , b : Int + , c : Nat + , d : Bytes + , e : Text + , f : Nat + , g : [Nat] + } +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view Record4 + + type Record4 + = { a : Text, + b : Int, + c : Nat, + d : Bytes, + e : Text, + f : Nat, + g : [Nat] } +``` + +## Record with many many fields + +``` unison :hide +unique type Record5 = { + zero : Nat, + one : [Nat], + two : [[Nat]], + three: [[[Nat]]], + four: [[[[Nat]]]], + five: [[[[[Nat]]]]], + six: [[[[[[Nat]]]]]], + seven: [[[[[[[Nat]]]]]]], + eight: [[[[[[[[Nat]]]]]]]], + nine: [[[[[[[[[Nat]]]]]]]]], + ten: [[[[[[[[[[Nat]]]]]]]]]], + eleven: [[[[[[[[[[[Nat]]]]]]]]]]], + twelve: [[[[[[[[[[[[Nat]]]]]]]]]]]], + thirteen: [[[[[[[[[[[[[Nat]]]]]]]]]]]]], + fourteen: [[[[[[[[[[[[[[Nat]]]]]]]]]]]]]], + fifteen: [[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]], + sixteen: [[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]], + seventeen: [[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]], + eighteen: [[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]], + nineteen: [[[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]]], + twenty: [[[[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]]]] +} +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> view Record5 + + type Record5 + = { zero : Nat, + one : [Nat], + two : [[Nat]], + three : [[[Nat]]], + four : [[[[Nat]]]], + five : [[[[[Nat]]]]], + six : [[[[[[Nat]]]]]], + seven : [[[[[[[Nat]]]]]]], + eight : [[[[[[[[Nat]]]]]]]], + nine : [[[[[[[[[Nat]]]]]]]]], + ten : [[[[[[[[[[Nat]]]]]]]]]], + eleven : [[[[[[[[[[[Nat]]]]]]]]]]], + twelve : [[[[[[[[[[[[Nat]]]]]]]]]]]], + thirteen : [[[[[[[[[[[[[Nat]]]]]]]]]]]]], + fourteen : [[[[[[[[[[[[[[Nat]]]]]]]]]]]]]], + fifteen : [[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]], + sixteen : [[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]], + seventeen : [[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]], + eighteen : [[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]], + nineteen : [[[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]]], + twenty : [[[[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]]]] } +``` + +## Record with user-defined type fields + +This record type has two fields whose types are user-defined (`Record4` and `UserType`). + +``` unison :hide +unique type UserType = UserType Nat + +unique type RecordWithUserType = { a : Text, b : Record4, c : UserType } +``` + +``` ucm :hide +scratch/main> add +``` + +If you `view` or `edit` it, it *should* be treated as a record type, but it does not (which is a bug) + +``` ucm +scratch/main> view RecordWithUserType + + type RecordWithUserType + = { a : Text, b : Record4, c : UserType } +``` + +## Syntax + +Trailing commas are allowed. + +``` unison +unique type Record5 = + { a : Text, + b : Int, + } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Record5.a : Record5 -> Text + Record5.a.modify : (Text ->{g} Text) + -> Record5 + ->{g} Record5 + Record5.a.set : Text -> Record5 -> Record5 + Record5.b : Record5 -> Int + Record5.b.modify : (Int ->{g} Int) + -> Record5 + ->{g} Record5 + Record5.b.set : Int -> Record5 -> Record5 + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Record5 +``` diff --git a/unison-src/transcripts/idempotent/reflog.md b/unison-src/transcripts/idempotent/reflog.md new file mode 100644 index 0000000000..357ffb6200 --- /dev/null +++ b/unison-src/transcripts/idempotent/reflog.md @@ -0,0 +1,136 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtins +``` + +First we make some changes to the codebase so there's data in the reflog. + +``` unison +x = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + x : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + x : Nat +``` + +``` unison +y = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + y : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + y : Nat + +scratch/main> branch /other + + Done. I've created the other branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /other`. + +scratch/other> alias.term y z + + Done. + +newproject/main> builtins.merge lib.builtins + + Done. + +newproject/main> alias.type lib.builtins.Nat MyNat + + Done. +``` + +Should see reflog entries from the current branch + +``` ucm +scratch/main> reflog + + Below is a record of recent changes, you can use + `reset #abcdef` to reset the current branch to a previous + state. + + Tip: Use `diff.namespace 1 7` to compare between points in + history. + + Branch Hash Description + 1. scratch/main #6mdl5gruh5 add + 2. scratch/main #3rqf1hbev7 add + 3. scratch/main #ms9lggs2rg builtins.merge scratch/main:lib.builtins + 4. scratch/main #sg60bvjo91 Project Created +``` + +Should see reflog entries from the current project + +``` ucm +scratch/main> project.reflog + + Below is a record of recent changes, you can use + `reset #abcdef` to reset the current branch to a previous + state. + + Tip: Use `diff.namespace 1 7` to compare between points in + history. + + Branch Hash Description + 1. scratch/other #148flqs4b1 alias.term scratch/other:.y scratch/other:z + 2. scratch/other #6mdl5gruh5 Branch created from scratch/main + 3. scratch/main #6mdl5gruh5 add + 4. scratch/main #3rqf1hbev7 add + 5. scratch/main #ms9lggs2rg builtins.merge scratch/main:lib.builtins + 6. scratch/main #sg60bvjo91 Project Created +``` + +Should see reflog entries from all projects + +``` ucm +scratch/main> reflog.global + + Below is a record of recent changes, you can use + `reset #abcdef` to reset the current branch to a previous + state. + + Tip: Use `diff.namespace 1 7` to compare between points in + history. + + Branch Hash Description + 1. newproject/main #2rjhs2vq43 alias.term newproject/main:lib.builtins.Nat newproject/main:... + 2. newproject/main #ms9lggs2rg builtins.merge newproject/main:lib.builtins + 3. newproject/main #sg60bvjo91 Branch Created + 4. scratch/other #148flqs4b1 alias.term scratch/other:.y scratch/other:z + 5. scratch/other #6mdl5gruh5 Branch created from scratch/main + 6. scratch/main #6mdl5gruh5 add + 7. scratch/main #3rqf1hbev7 add + 8. scratch/main #ms9lggs2rg builtins.merge scratch/main:lib.builtins + 9. scratch/main #sg60bvjo91 Project Created +``` diff --git a/unison-src/transcripts/idempotent/release-draft-command.md b/unison-src/transcripts/idempotent/release-draft-command.md new file mode 100644 index 0000000000..db40f0a607 --- /dev/null +++ b/unison-src/transcripts/idempotent/release-draft-command.md @@ -0,0 +1,62 @@ +The `release.draft` command drafts a release from the current branch. + +``` ucm :hide +foo/main> builtins.merge +``` + +Some setup: + +``` unison +someterm = 18 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + someterm : Nat +``` + +``` ucm +foo/main> add + + ⍟ I've added these definitions: + + someterm : Nat +``` + +Now, the `release.draft` demo: + +`release.draft` accepts a single semver argument. + +``` ucm +foo/main> release.draft 1.2.3 + + 😎 Great! I've created a draft release for you at + /releases/drafts/1.2.3. + + You can create a `ReleaseNotes : Doc` in this branch to give + an overview of the release. It'll automatically show up on + Unison Share when you publish. + + When ready to release 1.2.3 to the world, `push` the release + to Unison Share, navigate to the release, and click "Publish". + + Tip: if you get pulled away from drafting your release, you + can always get back to it with + `switch /releases/drafts/1.2.3`. +``` + +It's an error to try to create a `releases/drafts/x.y.z` branch that already exists. + +``` ucm :error +foo/main> release.draft 1.2.3 + + foo/releases/drafts/1.2.3 already exists. You can switch to it + with `switch foo/releases/drafts/1.2.3`. +``` diff --git a/unison-src/transcripts/idempotent/reset.md b/unison-src/transcripts/idempotent/reset.md new file mode 100644 index 0000000000..2cd116f87c --- /dev/null +++ b/unison-src/transcripts/idempotent/reset.md @@ -0,0 +1,205 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +def = "first value" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + def : Text +``` + +``` ucm :hide +scratch/main> update +``` + +``` unison :hide +def = "second value" +``` + +Can reset to a value from history by number. + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #5vq851j3hg + + + Adds / updates: + + def + + ⊙ 2. #ujvq6e87kp + + + Adds / updates: + + def + + □ 3. #4bigcpnl7t (start of history) + +scratch/main> reset 2 + + Done. + +scratch/main> view def + + def : Text + def = "first value" + +scratch/main> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #ujvq6e87kp + + + Adds / updates: + + def + + □ 2. #4bigcpnl7t (start of history) +``` + +Can reset to a value from reflog by number. + +``` ucm +scratch/main> reflog + + Below is a record of recent changes, you can use + `reset #abcdef` to reset the current branch to a previous + state. + + Tip: Use `diff.namespace 1 7` to compare between points in + history. + + Branch Hash Description + 1. scratch/main #ujvq6e87kp reset ujvq6e87kp4288eq3al9v5luctic0ocd7ug1fu0go5bicrr2vfnrb0... + 2. scratch/main #5vq851j3hg update + 3. scratch/main #ujvq6e87kp update + 4. scratch/main #4bigcpnl7t builtins.merge + 5. scratch/main #sg60bvjo91 Project Created + +-- Reset the current branch to the first history element + +scratch/main> reset 2 + + Done. + +scratch/main> view def + + def : Text + def = "second value" + +scratch/main> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #5vq851j3hg + + + Adds / updates: + + def + + ⊙ 2. #ujvq6e87kp + + + Adds / updates: + + def + + □ 3. #4bigcpnl7t (start of history) +``` + +# reset branch + +``` ucm +foo/main> history + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #sg60bvjo91 (start of history) +``` + +``` unison :hide +a = 5 +``` + +``` ucm +foo/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +foo/empty> reset /main: + + Done. + +foo/empty> view a + + a : ##Nat + a = 5 + +foo/empty> history + + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #5l94rduvel (start of history) +``` + +## second argument is always interpreted as a branch + +``` unison :hide +main.a = 3 +``` + +``` ucm +foo/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +foo/main> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #0i64kpfccl + + + Adds / updates: + + main.a + + □ 2. #5l94rduvel (start of history) + +foo/main> reset 2 main + + Done. +``` diff --git a/unison-src/transcripts/idempotent/resolution-failures.md b/unison-src/transcripts/idempotent/resolution-failures.md new file mode 100644 index 0000000000..0dfba8378c --- /dev/null +++ b/unison-src/transcripts/idempotent/resolution-failures.md @@ -0,0 +1,121 @@ +# Resolution Errors + +This transcript tests the errors printed to the user when a name cannot be resolved. + +## Codebase Setup + +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. +``` + +First we define differing types with the same name in different namespaces: + +``` unison +unique type one.AmbiguousType = one.AmbiguousType +unique type two.AmbiguousType = two.AmbiguousType + +one.ambiguousTerm = "term one" +two.ambiguousTerm = "term two" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type one.AmbiguousType + type two.AmbiguousType + one.ambiguousTerm : Text + two.ambiguousTerm : Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type one.AmbiguousType + type two.AmbiguousType + one.ambiguousTerm : Text + two.ambiguousTerm : Text +``` + +## Tests + +Now we introduce code which isn't sufficiently qualified. +It is ambiguous which type from which namespace we mean. + +We expect the output to: + +1. Print all ambiguous usage sites separately +2. Print possible disambiguation suggestions for each unique ambiguity + +``` unison :error +-- We intentionally avoid using a constructor to ensure the constructor doesn't +-- affect type resolution. +useAmbiguousType : AmbiguousType -> () +useAmbiguousType _ = () + +useUnknownType : UnknownType -> () +useUnknownType _ = () + +-- Despite being a duplicate disambiguation, this should still be included in the annotations printout +separateAmbiguousTypeUsage : AmbiguousType -> () +separateAmbiguousTypeUsage _ = () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + ❓ + + I couldn't resolve any of these symbols: + + 3 | useAmbiguousType : AmbiguousType -> () + 4 | useAmbiguousType _ = () + 5 | + 6 | useUnknownType : UnknownType -> () + 7 | useUnknownType _ = () + 8 | + 9 | -- Despite being a duplicate disambiguation, this should still be included in the annotations printout + 10 | separateAmbiguousTypeUsage : AmbiguousType -> () + + + Symbol Suggestions + + AmbiguousType one.AmbiguousType + two.AmbiguousType + + UnknownType No matches +``` + +Currently, ambiguous terms are caught and handled by type directed name resolution, +but expect it to eventually be handled by the above machinery. + +``` unison :error +useAmbiguousTerm = ambiguousTerm +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I couldn't figure out what ambiguousTerm refers to here: + + 1 | useAmbiguousTerm = ambiguousTerm + + The name ambiguousTerm is ambiguous. I couldn't narrow it down + by type, as any type would work here. + + I found some terms in scope that have matching names and + types. Maybe you meant one of these: + + one.ambiguousTerm : Text + two.ambiguousTerm : Text +``` diff --git a/unison-src/transcripts/idempotent/rsa.md b/unison-src/transcripts/idempotent/rsa.md new file mode 100644 index 0000000000..900838394f --- /dev/null +++ b/unison-src/transcripts/idempotent/rsa.md @@ -0,0 +1,72 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison + +up = 0xs0123456789abcdef +down = 0xsfedcba9876543210 + +-- | Generated with: +-- openssl genrsa -out private_key.pem 1024 +-- openssl rsa -in private_key.pem -outform DER | xxd -p +secret = 0xs30820276020100300d06092a864886f70d0101010500048202603082025c02010002818100a7104b2f20725896076e629ccedbcd6907b16694c6e3d8768b5e0e685670b49616e796c588e5aafb92ef986c1a42c021fed0bdc99212c969cdab98087a0ee4c2f4acd4b6049a87a96afc45668329a3cf21a86fb13b488bbe9fefa1cd5a459014f0d0101378e9661e11b73acf54c8a91141ac90309e7fb6ed69b4e63230ab291502030100010281807cdc23a4fc3619d93f8293b728af848d0c0fdd603269d5bd7b99f760a9c22065d08693dbdcddf1f5863306133d694819e04d789aef4e95343b601507b8d9eac4492e6d7031b035c5d84eceaa9686b292712632d33b3303af84314d7920bc3d45f90d7818fc2587b129196d378ee4ed3e6b8d9010d504bb6470ff53e7c5fb17a1024100d67cbcf113d24325fcef12a778dc47c7060055290b68287649ef092558daccb61c4e7bc290740b75a29d4356dcbd66d18b0860dbff394cc8ff3d94d57617adbd024100c765d8261dd3d8e0d3caf11ab7b212eed181354215687ca6387283e4f0be16e79c8f298be0a70c7734dea78ea65128517d693cabfa4c0ff5328f2abb85d2023902403ca41dc347285e65c22251b2d9bfe5e7463217e1b7e0e5f7b3a58a7f6da4c6d60220ca6ad2ee8c42e10bf77afa83ee2af6551315800e52404db1ba7fb398b43d02410084877d85c0177933ddb12a554eb8edfa8b872c85d2c2d2ee8be019280696e19469ab81bab5c371f69d4e4be1f54b45d7fbda017870f1333e0eafb78051ee8689024061f694c12e934c44b7734f62d1b2a3d3624a4980e1b8e066d78dbabd2436654fbb9d9701425900daaafa1e031310e8a580520bb9e1c1288c669fce252bad1e65 + +-- | Generated with: +-- openssl rsa -in private_key.pem -outform DER -pubout | xxd -p +publicKey = 0xs30819f300d06092a864886f70d010101050003818d0030818902818100a7104b2f20725896076e629ccedbcd6907b16694c6e3d8768b5e0e685670b49616e796c588e5aafb92ef986c1a42c021fed0bdc99212c969cdab98087a0ee4c2f4acd4b6049a87a96afc45668329a3cf21a86fb13b488bbe9fefa1cd5a459014f0d0101378e9661e11b73acf54c8a91141ac90309e7fb6ed69b4e63230ab29150203010001 + +incorrectPublicKey = 0xs30819f300d06092a864886f70d010101050003818d0030818902818100a7104b2f20725896076e629ccedbcd6907b16694c6e3d8768b5e0e685670b49616e796c588e5aafb92ef986c1a42c021fed0bdc99212c969cdab98087a0ee4c2f4acd4b6049a87a96afc45668329a3cf21a86fb13b488bbe9fefa1cd5a459014f0d0101378e9661e11b73acf54c8a91141ac90309e7fb6ed69b4e63230ab29150203010002 + +message = up ++ down ++ up ++ down ++ down ++ up ++ down ++ up + +signature = crypto.Rsa.sign.impl secret message + +sigOkay = match signature with + Left err -> Left err + Right sg -> crypto.Rsa.verify.impl publicKey message sg + +sigKo = match signature with + Left err -> Left err + Right sg -> crypto.Rsa.verify.impl incorrectPublicKey message sg + +> signature +> sigOkay +> sigKo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + down : Bytes + incorrectPublicKey : Bytes + message : Bytes + publicKey : Bytes + secret : Bytes + sigKo : Either Failure Boolean + sigOkay : Either Failure Boolean + signature : Either Failure Bytes + up : Bytes + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 28 | > signature + ⧩ + Right + 0xs84b02b6bb0e1196b65378cb12b727f7b4b38e5979f0632e8a51cfab088827f6d3da4221788029f75a0a5f4d740372cfa590462888a1189bbd9de9b084f26116640e611af5a1a17229beec7fb2570887181bbdced8f0ebfec6cad6bdd318a616ba4f01c90e1436efe44b18417d18ce712a0763be834f8c76e0c39b2119b061373 + + 29 | > sigOkay + ⧩ + Right true + + 30 | > sigKo + ⧩ + Right false +``` diff --git a/unison-src/transcripts/idempotent/runtime-tests.md b/unison-src/transcripts/idempotent/runtime-tests.md new file mode 100644 index 0000000000..0ac9a0c13e --- /dev/null +++ b/unison-src/transcripts/idempotent/runtime-tests.md @@ -0,0 +1,183 @@ +# An assortment of regression tests that exercise various interesting cases within the runtime. + +``` ucm :hide +scratch/main> builtins.merge lib.builtins +``` + +``` unison +negativeCaseMatch = match -10 with + +1 -> "bad" + -10 -> "good" + +3 -> "bad" + _ -> "bad" +> negativeCaseMatch + +funcWithMoreThanTwoUnboxedArgs : Nat -> Nat -> Nat -> Nat +funcWithMoreThanTwoUnboxedArgs x y z = + x + y + z + +> funcWithMoreThanTwoUnboxedArgs 1 2 3 + +funcWithMixedArgTypes : Nat -> Text -> Nat -> Text +funcWithMixedArgTypes x y z = + Nat.toText x ++ y ++ Nat.toText z + +> funcWithMixedArgTypes 1 "hello" 2 + +unboxedAndBoxedArgsInSequences = ([1, 2, 3], ["x", "y", "z"]) +> unboxedAndBoxedArgsInSequences + +casting = (Nat.toInt 100, + Float.toRepresentation 3.14, + Float.fromRepresentation 4614253070214989087, + Int.fromRepresentation 100, + Int.toRepresentation +10, + Int.toRepresentation -10) +> casting + + +> 1 Universal.== Int.toRepresentation +1 +> [1, 2, 3] Universal.== [Int.toRepresentation +1, Int.toRepresentation +2, Int.toRepresentation +3] + +-- Float edge cases +> compare 0.0 0.0 +> compare +0.0 (-0.0) +> compare -0.0 (+0.0) +> compare -1.0 1.0 + +-- Currently, the same NaN's are equal, but different NaN's are not... +> (0.0/0.0) == (0.0/0.0) +> (0.0/0.0) == (1.0/0.0) + +> Universal.compare [] [1] +> Universal.compare [1, 2] [2, 3] +> Universal.compare [2, 3] [1, 2] + +-- Values in 'Any' are compared a bit strangely. +-- Currently we have special-cases to compare the values of Nats and Ints directly, ignoring their type, for better or +-- worse. +-- This helps to counter a different issue we have, where `load (save +10)` will load a `Nat` runtime type rather than +-- an Int, since we don't actually store the type of numerics in the ANF.Value type. +> Universal.compare (Any [1, 2]) (Any [+1, +2]) + +-- Regression test for a problem with universalCompare where Nats larger than maxInt would compare incorrectly, but only +-- when nested within other types due to how lists of constructor fields were compared. +> Universal.compare (1,()) (18446744073709551615, ()) + +-- Types in tuples should compare one by one left-to-right +> Universal.compare (1, "", 2) (1, "", 3) +> Universal.compare (1, "", 3) (1, "", 2) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + casting : ( Int, + Nat, + Float, + Int, + Nat, + Nat) + funcWithMixedArgTypes : Nat + -> Text + -> Nat + -> Text + funcWithMoreThanTwoUnboxedArgs : Nat -> Nat -> Nat -> Nat + negativeCaseMatch : Text + unboxedAndBoxedArgsInSequences : ([Nat], [Text]) + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 6 | > negativeCaseMatch + ⧩ + "good" + + 12 | > funcWithMoreThanTwoUnboxedArgs 1 2 3 + ⧩ + 6 + + 18 | > funcWithMixedArgTypes 1 "hello" 2 + ⧩ + "1hello2" + + 21 | > unboxedAndBoxedArgsInSequences + ⧩ + ([1, 2, 3], ["x", "y", "z"]) + + 29 | > casting + ⧩ + ( +100 + , 4614253070214989087 + , 3.14 + , +100 + , 10 + , 18446744073709551606 + ) + + 32 | > 1 Universal.== Int.toRepresentation +1 + ⧩ + true + + 33 | > [1, 2, 3] Universal.== [Int.toRepresentation +1, Int.toRepresentation +2, Int.toRepresentation +3] + ⧩ + true + + 36 | > compare 0.0 0.0 + ⧩ + +0 + + 37 | > compare +0.0 (-0.0) + ⧩ + -1 + + 38 | > compare -0.0 (+0.0) + ⧩ + +1 + + 39 | > compare -1.0 1.0 + ⧩ + -1 + + 42 | > (0.0/0.0) == (0.0/0.0) + ⧩ + true + + 43 | > (0.0/0.0) == (1.0/0.0) + ⧩ + false + + 45 | > Universal.compare [] [1] + ⧩ + -1 + + 46 | > Universal.compare [1, 2] [2, 3] + ⧩ + -1 + + 47 | > Universal.compare [2, 3] [1, 2] + ⧩ + +1 + + 54 | > Universal.compare (Any [1, 2]) (Any [+1, +2]) + ⧩ + +0 + + 58 | > Universal.compare (1,()) (18446744073709551615, ()) + ⧩ + -1 + + 61 | > Universal.compare (1, "", 2) (1, "", 3) + ⧩ + -1 + + 62 | > Universal.compare (1, "", 3) (1, "", 2) + ⧩ + +1 +``` diff --git a/unison-src/transcripts/idempotent/scope-ref.md b/unison-src/transcripts/idempotent/scope-ref.md new file mode 100644 index 0000000000..5d723e9ddc --- /dev/null +++ b/unison-src/transcripts/idempotent/scope-ref.md @@ -0,0 +1,37 @@ +A short script to test mutable references with local scope. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +test = Scope.run 'let + r = Scope.ref 0 + Ref.write r 1 + i = Ref.read r + Ref.write r 2 + j = Ref.read r + Ref.write r 5 + (i, j, Ref.read r) + +> test +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + test : (Nat, Nat, Nat) + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 10 | > test + ⧩ + (1, 2, 5) +``` diff --git a/unison-src/transcripts/idempotent/suffixes.md b/unison-src/transcripts/idempotent/suffixes.md new file mode 100644 index 0000000000..762ffe5448 --- /dev/null +++ b/unison-src/transcripts/idempotent/suffixes.md @@ -0,0 +1,167 @@ +# Suffix-based resolution of names + +``` ucm :hide +scratch/main> builtins.merge +``` + +Any unique name suffix can be used to refer to a definition. For instance: + +``` unison :hide +-- No imports needed even though FQN is `builtin.{Int,Nat}` +foo.bar.a : Int +foo.bar.a = +99 + +-- No imports needed even though FQN is `builtin.Optional.{None,Some}` +optional.isNone = cases + None -> true + Some _ -> false +``` + +This also affects commands like find. Notice lack of qualified names in output: + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo.bar.a : Int + optional.isNone : Optional a -> Boolean + +scratch/main> find take + + 1. builtin.Bytes.take : Nat -> Bytes -> Bytes + 2. builtin.List.take : Nat -> [a] -> [a] + 3. builtin.Text.take : Nat -> Text -> Text + 4. builtin.io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 5. builtin.io2.MVar.tryTake : MVar a ->{IO} Optional a +``` + +The `view` and `display` commands also benefit from this: + +``` ucm +scratch/main> view List.drop + + builtin builtin.List.drop : builtin.Nat -> [a] -> [a] + +scratch/main> display bar.a + + +99 +``` + +In the signature, we don't see `base.Nat`, just `Nat`. The full declaration name is still shown for each search result though. + +Type-based search also benefits from this, we can just say `Nat` rather than `.base.Nat`: + +``` ucm +scratch/main> find : Nat -> [a] -> [a] + + 1. builtin.List.drop : Nat -> [a] -> [a] + 2. builtin.List.take : Nat -> [a] -> [a] +``` + +## Preferring names not in `lib.*.lib.*` + +Suffix-based resolution prefers names that are not in an indirect dependency. + +``` unison +cool.abra.cadabra = "my project" +lib.distributed.abra.cadabra = "direct dependency 1" +lib.distributed.baz.qux = "direct dependency 2" +lib.distributed.lib.baz.qux = "indirect dependency" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + cool.abra.cadabra : Text + lib.distributed.abra.cadabra : Text + lib.distributed.baz.qux : Text + lib.distributed.lib.baz.qux : Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + cool.abra.cadabra : Text + lib.distributed.abra.cadabra : Text + lib.distributed.baz.qux : Text + lib.distributed.lib.baz.qux : Text +``` + +``` unison :error +> abra.cadabra +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I couldn't figure out what abra.cadabra refers to here: + + 1 | > abra.cadabra + + The name abra.cadabra is ambiguous. I couldn't narrow it down + by type, as any type would work here. + + I found some terms in scope that have matching names and + types. Maybe you meant one of these: + + cool.abra.cadabra : Text + distributed.abra.cadabra : Text +``` + +``` unison +> baz.qux +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > baz.qux + ⧩ + "direct dependency 2" +``` + +``` ucm +scratch/main> view abra.cadabra + + cool.abra.cadabra : Text + cool.abra.cadabra = "my project" + + lib.distributed.abra.cadabra : Text + lib.distributed.abra.cadabra = "direct dependency 1" + +scratch/main> view baz.qux + + lib.distributed.baz.qux : Text + lib.distributed.baz.qux = "direct dependency 2" +``` + +Note that we can always still view indirect dependencies by using more name segments: + +``` ucm +scratch/main> view distributed.abra.cadabra + + lib.distributed.abra.cadabra : Text + lib.distributed.abra.cadabra = "direct dependency 1" + +scratch/main> names distributed.lib.baz.qux + + Term + Hash: #nhup096n2s + Names: lib.distributed.lib.baz.qux +``` diff --git a/unison-src/transcripts/idempotent/sum-type-update-conflicts.md b/unison-src/transcripts/idempotent/sum-type-update-conflicts.md new file mode 100644 index 0000000000..467ad27b61 --- /dev/null +++ b/unison-src/transcripts/idempotent/sum-type-update-conflicts.md @@ -0,0 +1,83 @@ +# Regression test for updates which conflict with an existing data constructor + +https://github.com/unisonweb/unison/issues/2786 + +``` ucm :hide +scratch/main> builtins.merge lib.builtins +``` + +First we add a sum-type to the codebase. + +``` unison +structural type X = x +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type X + (also named lib.builtins.Unit) +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type X + (also named lib.builtins.Unit) +``` + +Now we update the type, changing the name of the constructors, *but*, we simultaneously +add a new top-level term with the same name as the old constructor. + +``` unison +structural type X = y | z + +X.x : Text +X.x = "some text that's not in the codebase" + +dependsOnX = Text.size X.x +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + X.x : Text + dependsOnX : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + structural type X + (The old definition is also named lib.builtins.Unit.) +``` + +This update should succeed since the conflicted constructor +is removed in the same update that the new term is being added. + +``` ucm +scratch/main> update.old + + ⍟ I've added these definitions: + + X.x : Text + dependsOnX : Nat + + ⍟ I've updated these names to your new definition: + + structural type X + (The old definition was also named lib.builtins.Unit.) +``` diff --git a/unison-src/transcripts/idempotent/switch-command.md b/unison-src/transcripts/idempotent/switch-command.md new file mode 100644 index 0000000000..2361485802 --- /dev/null +++ b/unison-src/transcripts/idempotent/switch-command.md @@ -0,0 +1,99 @@ +The `switch` command switches to an existing project or branch. + +``` ucm :hide +foo/main> builtins.merge + +bar/main> builtins.merge +``` + +Setup stuff. + +``` unison +someterm = 18 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + someterm : Nat +``` + +``` ucm +foo/main> add + + ⍟ I've added these definitions: + + someterm : Nat + +foo/main> branch bar + + Done. I've created the bar branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /bar`. + +foo/main> branch topic + + Done. I've created the topic branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic`. +``` + +Now, the demo. When unambiguous, `switch` switches to either a project or a branch in the current project. A branch in +the current project can be preceded by a forward slash (which makes it unambiguous). A project can be followed by a +forward slash (which makes it unambiguous). + +``` ucm +scratch/main> switch foo + +scratch/main> switch foo/topic + +foo/main> switch topic + +foo/main> switch /topic + +foo/main> switch bar/ +``` + +It's an error to try to switch to something ambiguous. + +``` ucm :error +foo/main> switch bar + + I'm not sure if you wanted to switch to the branch foo/bar or + the project bar. Could you be more specific? + + 1. /bar (the branch bar in the current project) + 2. bar/ (the project bar, with the branch left unspecified) + + Tip: use `switch 1` or `switch 2` to pick one of these. +``` + +It's an error to try to switch to something that doesn't exist, of course. + +``` ucm :error +scratch/main> switch foo/no-such-branch + + foo/no-such-branch does not exist. +``` + +``` ucm :error +scratch/main> switch no-such-project + + Neither project no-such-project nor branch /no-such-project + exists. +``` + +``` ucm :error +foo/main> switch no-such-project-or-branch + + Neither project no-such-project-or-branch nor branch + /no-such-project-or-branch exists. +``` diff --git a/unison-src/transcripts/idempotent/tab-completion.md b/unison-src/transcripts/idempotent/tab-completion.md new file mode 100644 index 0000000000..83aa787539 --- /dev/null +++ b/unison-src/transcripts/idempotent/tab-completion.md @@ -0,0 +1,240 @@ +# Tab Completion + +Test that tab completion works as expected. + +## Tab Complete Command Names + +``` ucm +scratch/main> debug.tab-complete vi + + view + view.global + +scratch/main> debug.tab-complete delete. + + delete.branch + delete.namespace + delete.namespace.force + delete.project + delete.term + delete.term.verbose + delete.type + delete.type.verbose + delete.verbose +``` + +## Tab complete terms & types + +``` unison +subnamespace.someName = 1 +subnamespace.someOtherName = 2 +subnamespace2.thing = 3 +othernamespace.someName = 4 + +unique type subnamespace.AType = A | B +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type subnamespace.AType + othernamespace.someName : ##Nat + subnamespace.someName : ##Nat + subnamespace.someOtherName : ##Nat + subnamespace2.thing : ##Nat +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +-- Should tab complete namespaces since they may contain terms/types + +scratch/main> debug.tab-complete view sub + + subnamespace. + subnamespace2. + +-- Should not complete things from child namespaces of the current query if there are other completions at this level + +scratch/main> debug.tab-complete view subnamespace + + subnamespace. + subnamespace2. + +-- Should complete things from child namespaces of the current query if it's dot-suffixed + +scratch/main> debug.tab-complete view subnamespace. + + * subnamespace.AType + subnamespace.AType. + * subnamespace.someName + * subnamespace.someOtherName + +-- Should complete things from child namespaces of the current query if there are no more completions at this level. + +scratch/main> debug.tab-complete view subnamespace2 + + subnamespace2. + * subnamespace2.thing + +-- Should prefix-filter by query suffix + +scratch/main> debug.tab-complete view subnamespace.some + + * subnamespace.someName + * subnamespace.someOtherName + +scratch/main> debug.tab-complete view subnamespace.someOther + + * subnamespace.someOtherName +``` + +``` unison :hide +absolute.term = "absolute" +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + absolute.term : ##Text + +-- Should tab complete absolute names + +scratch/main> debug.tab-complete view .absolute.te + + * .absolute.term +``` + +## Tab complete namespaces + +``` ucm +-- Should tab complete namespaces + +scratch/main> debug.tab-complete find-in sub + + subnamespace + subnamespace2 + +scratch/main> debug.tab-complete find-in subnamespace + + subnamespace + subnamespace2 + +scratch/main> debug.tab-complete find-in subnamespace. + + subnamespace.AType + +scratch/main> debug.tab-complete io.test sub + + subnamespace. + subnamespace2. + +scratch/main> debug.tab-complete io.test subnamespace + + subnamespace. + subnamespace2. + +scratch/main> debug.tab-complete io.test subnamespace. + + subnamespace.AType. + * subnamespace.someName + * subnamespace.someOtherName +``` + +Tab Complete Delete Subcommands + +``` unison +unique type Foo = A | B +add : a -> a +add b = b +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + add : a -> a +``` + +``` ucm +scratch/main> update.old + + ⍟ I've added these definitions: + + type Foo + add : a -> a + +scratch/main> debug.tab-complete delete.type Foo + + * Foo + Foo. + +scratch/main> debug.tab-complete delete.term add + + * add +``` + +## Tab complete projects and branches + +``` ucm +myproject/main> branch mybranch + + Done. I've created the mybranch branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /mybranch`. + +myproject/main> debug.tab-complete branch.delete /mybr + + /mybranch + +myproject/main> debug.tab-complete project.rename my + + myproject +``` + +Commands which complete namespaces OR branches should list both + +``` unison +mybranchsubnamespace.term = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + mybranchsubnamespace.term : ##Nat +``` + +``` ucm +myproject/main> add + + ⍟ I've added these definitions: + + mybranchsubnamespace.term : ##Nat + +myproject/main> debug.tab-complete merge mybr + + /mybranch +``` diff --git a/unison-src/transcripts/idempotent/tdnr.md b/unison-src/transcripts/idempotent/tdnr.md new file mode 100644 index 0000000000..1a4f8214b8 --- /dev/null +++ b/unison-src/transcripts/idempotent/tdnr.md @@ -0,0 +1,1134 @@ +TDNR selects local term (in file) that typechecks over local term (in file) that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +good.foo = 17 +bad.foo = "bar" +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bad.foo : Text + good.foo : Nat + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects local term (in file) that typechecks over local term (in namespace) that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bad.foo : Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bad.foo : Text +``` + +``` unison +good.foo = 17 +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + good.foo : Nat + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects local term (in file) that typechecks over local term (shadowing namespace) that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bad.foo : Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bad.foo : Text +``` + +``` unison +good.foo = 17 +bad.foo = "baz" +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + good.foo : Nat + thing : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + bad.foo : Text +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects local term (in namespace) that typechecks over local term (in file) that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +good.foo = 17 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + good.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + good.foo : Nat +``` + +``` unison +bad.foo = "bar" +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bad.foo : Text + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects local term (in namespace) that typechecks over local term (in namespace) that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +good.foo = 17 +bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bad.foo : Text + good.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bad.foo : Text + good.foo : Nat +``` + +``` unison +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects local term (in namespace) that typechecks over local term (shadowing namespace) that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +good.foo = 17 +bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bad.foo : Text + good.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bad.foo : Text + good.foo : Nat +``` + +``` unison +bad.foo = "baz" +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + bad.foo : Text +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects local term (shadowing namespace) that typechecks over local term (in file) that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +good.foo = 17 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + good.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + good.foo : Nat +``` + +``` unison +good.foo = 18 +bad.foo = "bar" +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bad.foo : Text + thing : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + good.foo : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects local term (shadowing namespace) that typechecks over local term (in namespace) that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +good.foo = 17 +bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bad.foo : Text + good.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bad.foo : Text + good.foo : Nat +``` + +``` unison +good.foo = 18 +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + good.foo : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects local term (shadowing namespace) that typechecks over local term (shadowing namespace) that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +good.foo = 17 +bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bad.foo : Text + good.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bad.foo : Text + good.foo : Nat +``` + +``` unison +good.foo = 18 +bad.foo = "baz" +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + bad.foo : Text + good.foo : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +\=== start local over direct dep + +TDNR selects local term (in file) that typechecks over direct dependency that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +lib.bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.bad.foo : Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lib.bad.foo : Text +``` + +``` unison +good.foo = 17 +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + good.foo : Nat + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects local term (in namespace) that typechecks over direct dependency that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +good.foo = 17 +lib.bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + good.foo : Nat + lib.bad.foo : Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + good.foo : Nat + lib.bad.foo : Text +``` + +``` unison +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects local term (shadowing namespace) that typechecks over direct dependency that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +good.foo = 17 +lib.bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + good.foo : Nat + lib.bad.foo : Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + good.foo : Nat + lib.bad.foo : Text +``` + +``` unison +good.foo = 18 +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + good.foo : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR not used to select local term (in file) that typechecks over indirect dependency that also typechecks. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +lib.dep.lib.dep.foo = 217 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.dep.lib.dep.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lib.dep.lib.dep.foo : Nat +``` + +``` unison +good.foo = 17 +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + good.foo : Nat + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR not used to select local term (in namespace) that typechecks over indirect dependency that also typechecks. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +good.foo = 17 +lib.dep.lib.dep.foo = 217 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + good.foo : Nat + lib.dep.lib.dep.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + good.foo : Nat + lib.dep.lib.dep.foo : Nat +``` + +``` unison +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR not used to select local term (shadowing namespace) that typechecks over indirect dependency that also typechecks. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +good.foo = 17 +lib.dep.lib.dep.foo = 217 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + good.foo : Nat + lib.dep.lib.dep.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + good.foo : Nat + lib.dep.lib.dep.foo : Nat +``` + +``` unison +good.foo = 18 +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + good.foo : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects direct dependency that typechecks over local term (in file) that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +lib.good.foo = 17 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.good.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lib.good.foo : Nat +``` + +``` unison +bad.foo = "bar" +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bad.foo : Text + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects direct dependency that typechecks over local term (in namespace) that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +lib.good.foo = 17 +bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bad.foo : Text + lib.good.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bad.foo : Text + lib.good.foo : Nat +``` + +``` unison +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects direct dependency that typechecks over local term (shadowing namespace) that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +lib.good.foo = 17 +bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bad.foo : Text + lib.good.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bad.foo : Text + lib.good.foo : Nat +``` + +``` unison +bad.foo = "baz" +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + bad.foo : Text +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects direct dependency that typechecks over direct dependency that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +lib.good.foo = 17 +lib.bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.bad.foo : Text + lib.good.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lib.bad.foo : Text + lib.good.foo : Nat +``` + +``` unison +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR not used to select direct dependency that typechecks over indirect dependency that also typechecks. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +lib.good.foo = 17 +lib.dep.lib.dep.foo = 217 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.dep.lib.dep.foo : Nat + lib.good.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lib.dep.lib.dep.foo : Nat + lib.good.foo : Nat +``` + +``` unison +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +TDNR selects indirect dependency that typechecks over indirect dependency that doesn't. + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +lib.dep.lib.good.foo = 17 +lib.dep.lib.bad.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.dep.lib.bad.foo : Text + lib.dep.lib.good.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lib.dep.lib.bad.foo : Text + lib.dep.lib.good.foo : Nat +``` + +``` unison +thing = foo Nat.+ foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + thing : Nat +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` diff --git a/unison-src/transcripts/idempotent/test-command.md b/unison-src/transcripts/idempotent/test-command.md new file mode 100644 index 0000000000..3f3c6df0ec --- /dev/null +++ b/unison-src/transcripts/idempotent/test-command.md @@ -0,0 +1,152 @@ +Merge builtins so we get enough names for the testing stuff. + +``` ucm :hide +scratch/main> builtins.merge +``` + +The `test` command should run all of the tests in the current directory. + +``` unison +test1 : [Result] +test1 = [Ok "test1"] + +foo.test2 : [Result] +foo.test2 = [Ok "test2"] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo.test2 : [Result] + test1 : [Result] +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> test + + ✅ + + + + + + New test results: + + 1. foo.test2 ◉ test2 + 2. test1 ◉ test1 + + ✅ 2 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +Tests should be cached if unchanged. + +``` ucm +scratch/main> test + + Cached test results (`help testcache` to learn more) + + 1. foo.test2 ◉ test2 + 2. test1 ◉ test1 + + ✅ 2 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +`test` won't descend into the `lib` namespace, but `test.all` will. + +``` unison +lib.dep.testInLib : [Result] +lib.dep.testInLib = [Ok "testInLib"] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.dep.testInLib : [Result] +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> test + + Cached test results (`help testcache` to learn more) + + 1. foo.test2 ◉ test2 + 2. test1 ◉ test1 + + ✅ 2 test(s) passing + + Tip: Use view 1 to view the source of a test. + +scratch/main> test.all + + + Cached test results (`help testcache` to learn more) + + 1. foo.test2 ◉ test2 + 2. test1 ◉ test1 + + ✅ 2 test(s) passing + + ✅ + + + + New test results: + + 1. lib.dep.testInLib ◉ testInLib + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +`test` WILL run tests within `lib` if specified explicitly. + +``` ucm +scratch/main> test lib.dep + + Cached test results (`help testcache` to learn more) + + 1. lib.dep.testInLib ◉ testInLib + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +`test` can be given a relative path, in which case it will only run tests found somewhere in that namespace. + +``` ucm +scratch/main> test foo + + Cached test results (`help testcache` to learn more) + + 1. foo.test2 ◉ test2 + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` diff --git a/unison-src/transcripts/idempotent/text-literals.md b/unison-src/transcripts/idempotent/text-literals.md new file mode 100644 index 0000000000..de87b7daf4 --- /dev/null +++ b/unison-src/transcripts/idempotent/text-literals.md @@ -0,0 +1,127 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +This transcript shows some syntax for raw text literals. + +``` unison +lit1 = """ +This is a raw text literal. +It can start with 3 or more ", +and is terminated by the same number of quotes. +Nothing is escaped. \n + +The initial newline, if it exists, is ignored. +The last line, if it's just whitespace up to the closing quotes, +is ignored. + +Use an extra blank line if you'd like a trailing newline. Like so: + +""" + +> lit1 +> Some lit1 + +lit2 = """" + This is a raw text literal, indented. + It can start with 3 or more ", + and is terminated by the same number of quotes. + Nothing is escaped. \n + + This doesn't terminate the literal - """ + """" + +> lit2 +> Some lit2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lit1 : Text + lit2 : Text + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 15 | > lit1 + ⧩ + """ + This is a raw text literal. + It can start with 3 or more ", + and is terminated by the same number of quotes. + Nothing is escaped. \n + + The initial newline, if it exists, is ignored. + The last line, if it's just whitespace up to the closing quotes, + is ignored. + + Use an extra blank line if you'd like a trailing newline. Like so: + + """ + + 16 | > Some lit1 + ⧩ + Some + "This is a raw text literal.\nIt can start with 3 or more \",\nand is terminated by the same number of quotes.\nNothing is escaped. \\n\n\nThe initial newline, if it exists, is ignored.\nThe last line, if it's just whitespace up to the closing quotes,\nis ignored.\n\nUse an extra blank line if you'd like a trailing newline. Like so:\n" + + 27 | > lit2 + ⧩ + """" + This is a raw text literal, indented. + It can start with 3 or more ", + and is terminated by the same number of quotes. + Nothing is escaped. \n + + This doesn't terminate the literal - """ + """" + + 28 | > Some lit2 + ⧩ + Some + "This is a raw text literal, indented.\nIt can start with 3 or more \",\nand is terminated by the same number of quotes.\nNothing is escaped. \\n\n\nThis doesn't terminate the literal - \"\"\"" +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lit1 : Text + lit2 : Text + +scratch/main> view lit1 lit2 + + lit1 : Text + lit1 = + """ + This is a raw text literal. + It can start with 3 or more ", + and is terminated by the same number of quotes. + Nothing is escaped. \n + + The initial newline, if it exists, is ignored. + The last line, if it's just whitespace up to the closing quotes, + is ignored. + + Use an extra blank line if you'd like a trailing newline. Like so: + + """ + + lit2 : Text + lit2 = + """" + This is a raw text literal, indented. + It can start with 3 or more ", + and is terminated by the same number of quotes. + Nothing is escaped. \n + + This doesn't terminate the literal - """ + """" +``` diff --git a/unison-src/transcripts/idempotent/textfind.md b/unison-src/transcripts/idempotent/textfind.md new file mode 100644 index 0000000000..96bda8abba --- /dev/null +++ b/unison-src/transcripts/idempotent/textfind.md @@ -0,0 +1,214 @@ +# The `text.find` command + +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +The `text.find` (or `grep`) command can be used to search for text or numeric literals appearing anywhere in your project. Just supply one or more tokens to search for. Unlike regular grep over the text of your code, this ignores local variables and function names that happen to match your search tokens (use `dependents` or `find` for that purpose). It's only searching for text or numeric literals that match. + +``` ucm +scratch/main> help grep + + text.find (or grep) + `text.find token1 "99" token2` finds terms with literals (text + or numeric) containing `token1`, `99`, and `token2`. + + Numeric literals must be quoted (ex: "42") but single words + need not be quoted. + + Use `text.find.all` to include search of `lib`. +``` + +``` ucm +scratch/main> help text.find.all + + text.find.all (or grep.all) + `text.find.all token1 "99" token2` finds terms with literals + (text or numeric) containing `token1`, `99`, and `token2`. + + Numeric literals must be quoted (ex: "42") but single words + need not be quoted. + + Use `text.find` to exclude `lib` from search. +``` + +Here's an example: + +``` unison +foo = + _ = "an interesting constant" + 1 +bar = match "well hi there" with + "ooga" -> 99 + "booga" -> 23 + _ -> 0 +baz = ["an", "quaffle", "tres"] +qux = + quaffle = 99 + quaffle + 1 + +lib.foo = [Any 46, Any "hi", Any "zoink"] +lib.bar = 3 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + baz : [Text] + foo : Nat + lib.bar : Nat + lib.foo : [Any] + qux : Nat +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> grep hi + + 🔎 + + These definitions from the current namespace (excluding `lib`) have matches: + + 1. bar + + Tip: Try `edit 1` to bring this into your scratch file. + +scratch/main> view 1 + + bar : Nat + bar = match "well hi there" with + "ooga" -> 99 + "booga" -> 23 + _ -> 0 + +scratch/main> grep "hi" + + 🔎 + + These definitions from the current namespace (excluding `lib`) have matches: + + 1. bar + + Tip: Try `edit 1` to bring this into your scratch file. + +scratch/main> text.find.all hi + + 🔎 + + These definitions from the current namespace have matches: + + 1. bar + 2. lib.foo + + Tip: Try `edit 1` or `edit 1-2` to bring these into your + scratch file. + +scratch/main> view 1-5 + + bar : Nat + bar = match "well hi there" with + "ooga" -> 99 + "booga" -> 23 + _ -> 0 + + lib.foo : [Any] + lib.foo = [Any 46, Any "hi", Any "zoink"] + +scratch/main> grep oog + + 🔎 + + These definitions from the current namespace (excluding `lib`) have matches: + + 1. bar + + Tip: Try `edit 1` to bring this into your scratch file. + +scratch/main> view 1 + + bar : Nat + bar = match "well hi there" with + "ooga" -> 99 + "booga" -> 23 + _ -> 0 +``` + +``` ucm +scratch/main> grep quaffle + + 🔎 + + These definitions from the current namespace (excluding `lib`) have matches: + + 1. baz + + Tip: Try `edit 1` to bring this into your scratch file. + +scratch/main> view 1-5 + + baz : [Text] + baz = ["an", "quaffle", "tres"] + +scratch/main> text.find "interesting const" + + 🔎 + + These definitions from the current namespace (excluding `lib`) have matches: + + 1. foo + + Tip: Try `edit 1` to bring this into your scratch file. + +scratch/main> view 1-5 + + foo : Nat + foo = + _ = "an interesting constant" + 1 + +scratch/main> text.find "99" "23" + + 🔎 + + These definitions from the current namespace (excluding `lib`) have matches: + + 1. bar + + Tip: Try `edit 1` to bring this into your scratch file. + +scratch/main> view 1 + + bar : Nat + bar = match "well hi there" with + "ooga" -> 99 + "booga" -> 23 + _ -> 0 +``` + +Now some failed searches: + +``` ucm :error +scratch/main> grep lsdkfjlskdjfsd + + 😶 I couldn't find any matches. + + Tip: `text.find.all` will search `lib` as well. +``` + +Notice it gives the tip about `text.find.all`. But not here: + +``` ucm :error +scratch/main> grep.all lsdkfjlskdjfsd + + 😶 I couldn't find any matches. +``` diff --git a/unison-src/transcripts/idempotent/todo-bug-builtins.md b/unison-src/transcripts/idempotent/todo-bug-builtins.md new file mode 100644 index 0000000000..31b375e8fe --- /dev/null +++ b/unison-src/transcripts/idempotent/todo-bug-builtins.md @@ -0,0 +1,101 @@ +# The `todo` and `bug` builtin + +``` ucm :hide +scratch/main> builtins.merge +``` + +`todo` and `bug` have type `a -> b`. They take a message or a value of type `a` and crash during runtime displaying `a` in ucm. + +``` unison :error +> todo "implement me later" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 💔💥 + + I've encountered a call to builtin.todo with the following + value: + + "implement me later" + + Stack trace: + todo + #qe5e1lcfn8 +``` + +``` unison :error +> bug "there's a bug in my code" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 💔💥 + + I've encountered a call to builtin.bug with the following + value: + + "there's a bug in my code" + + Stack trace: + bug + #m67hcdcoda +``` + +## Todo + +`todo` is useful if you want to come back to a piece of code later but you want your project to compile. + +``` unison +complicatedMathStuff x = todo "Come back and to something with x here" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + complicatedMathStuff : x -> r +``` + +## Bug + +`bug` is used to indicate that a particular branch is not expected to execute. + +``` unison +test = match true with + true -> "Yay" + false -> bug "Wow, that's unexpected" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + test : Text +``` diff --git a/unison-src/transcripts/idempotent/todo.md b/unison-src/transcripts/idempotent/todo.md new file mode 100644 index 0000000000..b230464cdf --- /dev/null +++ b/unison-src/transcripts/idempotent/todo.md @@ -0,0 +1,408 @@ +# Nothing to do + +When there's nothing to do, `todo` says this: + +``` ucm +scratch/main> todo + + You have no pending todo items. Good work! ✅ +``` + +# Dependents of `todo` + +The `todo` command shows local (outside `lib`) terms that directly call `todo`. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +foo : Nat +foo = todo "implement foo" + +bar : Nat +bar = foo + foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat + +scratch/main> todo + + These terms call `todo`: + + 1. foo +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +# Direct dependencies without names + +The `todo` command shows hashes of direct dependencies of local (outside `lib`) definitions that don't have names in +the current namespace. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +foo.bar = 15 +baz = foo.bar + foo.bar +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + baz : Nat + foo.bar : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + baz : Nat + foo.bar : Nat + +scratch/main> delete.namespace.force foo + + Done. + + ⚠️ + + Of the things I deleted, the following are still used in the + following definitions. They now contain un-named references. + + Dependency Referenced In + bar 1. baz + +scratch/main> todo + + These terms do not have any names in the current namespace: + + 1. #1jujb8oelv +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +# Conflicted names + +The `todo` command shows conflicted names. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +foo = 16 +bar = 17 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat + +scratch/main> debug.alias.term.force foo bar + + Done. + +scratch/main> todo + + ❓ + + The term bar has conflicting definitions: + + 1. bar#14ibahkll6 + 2. bar#cq22mm4sca + + Tip: Use `move.term` or `delete.term` to resolve the + conflicts. +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +# Definitions in lib + +The `todo` command complains about terms and types directly in `lib`. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +lib.foo = 16 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lib.foo : Nat + +scratch/main> todo + + There's a type or term at the top level of the `lib` + namespace, where I only expect to find subnamespaces + representing library dependencies. Please move or remove it. +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +# Constructor aliases + +The `todo` command complains about constructor aliases. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +type Foo = One +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + +scratch/main> alias.term Foo.One Foo.Two + + Done. + +scratch/main> todo + + The type Foo has a constructor with multiple names. + + 1. Foo.One + 2. Foo.Two + + Please delete all but one name for each constructor. +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +# Missing constructor names + +The `todo` command complains about missing constructor names. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +type Foo = Bar +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + +scratch/main> delete.term Foo.Bar + + Done. + +scratch/main> todo + + These types have some constructors with missing names. + + 1. Foo + + You can use `view 1` and + `alias.term .` to give names + to each unnamed constructor. +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +# Nested decl aliases + +The `todo` command complains about nested decl aliases. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +structural type Foo a = One a | Two a a +structural type Foo.inner.Bar a = Uno a | Dos a a +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type Foo a + structural type Foo.inner.Bar a +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type Foo a + structural type Foo.inner.Bar a + +scratch/main> todo + + These types are aliases, but one is nested under the other. + Please separate them or delete one copy. + + 1. Foo + 2. Foo.inner.Bar +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` + +# Stray constructors + +The `todo` command complains about stray constructors. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +type Foo = Bar +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + +scratch/main> alias.term Foo.Bar Baz + + Done. + +scratch/main> todo + + These constructors are not nested beneath their corresponding + type names: + + 1. Baz + + For each one, please either use `move` to move if, or if it's + an extra copy, you can simply `delete` it. +``` + +``` ucm :hide +scratch/main> delete.project scratch +``` diff --git a/unison-src/transcripts/idempotent/top-level-exceptions.md b/unison-src/transcripts/idempotent/top-level-exceptions.md new file mode 100644 index 0000000000..81c18f8349 --- /dev/null +++ b/unison-src/transcripts/idempotent/top-level-exceptions.md @@ -0,0 +1,104 @@ +A simple transcript to test the use of exceptions that bubble to the top level. + +``` ucm :hide +scratch/main> builtins.merge +``` + +FYI, here are the `Exception` and `Failure` types: + +``` ucm +scratch/main> view Exception Failure + + structural ability builtin.Exception where + raise : Failure ->{builtin.Exception} x + + type builtin.io2.Failure + = Failure Type Text Any +``` + +Here's a sample program just to verify that the typechecker allows `run` to throw exceptions: + +``` unison +use builtin IO Exception Test.Result + +main : '{IO, Exception} () +main _ = () + +mytest : '{IO, Exception} [Test.Result] +mytest _ = [Ok "Great"] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + main : '{IO, Exception} () + mytest : '{IO, Exception} [Result] +``` + +``` ucm +scratch/main> run main + + () + +scratch/main> add + + ⍟ I've added these definitions: + + main : '{IO, Exception} () + mytest : '{IO, Exception} [Result] + +scratch/main> io.test mytest + + New test results: + + 1. mytest ◉ Great + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +Now a test to show the handling of uncaught exceptions: + +``` unison +main2 = '(error "oh noes!" ()) + +error : Text -> a ->{Exception} x +error msg a = + builtin.Exception.raise (Failure (typeLink RuntimeError) msg (Any a)) + +unique type RuntimeError = +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type RuntimeError + error : Text -> a ->{Exception} x + main2 : '{Exception} r +``` + +``` ucm :error +scratch/main> run main2 + + 💔💥 + + The program halted with an unhandled exception: + + Failure (typeLink RuntimeError) "oh noes!" (Any ()) + + Stack trace: + ##raise +``` diff --git a/unison-src/transcripts/idempotent/transcript-parser-commands.md b/unison-src/transcripts/idempotent/transcript-parser-commands.md new file mode 100644 index 0000000000..ddc8e62dd6 --- /dev/null +++ b/unison-src/transcripts/idempotent/transcript-parser-commands.md @@ -0,0 +1,67 @@ +### Transcript parser operations + +``` ucm :hide +scratch/main> builtins.merge +``` + +The transcript parser is meant to parse `ucm` and `unison` blocks. + +``` unison +x = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + x : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + x : Nat +``` + +``` unison :hide :error scratch.u +z +``` + +``` ucm :error +scratch/main> delete foo + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + foo +``` + +``` ucm :error +scratch/main> delete lineToken.call + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + lineToken.call +``` + +However handling of blocks of other languages should be supported. + +``` python +some python code +``` + +``` c_cpp +some C++ code +``` + +``` c9search +some cloud9 code +``` diff --git a/unison-src/transcripts/idempotent/type-deps.md b/unison-src/transcripts/idempotent/type-deps.md new file mode 100644 index 0000000000..57b2cf602a --- /dev/null +++ b/unison-src/transcripts/idempotent/type-deps.md @@ -0,0 +1,65 @@ +# Ensure type dependencies are properly considered in slurping + +https://github.com/unisonweb/unison/pull/2821 + +``` ucm :hide +scratch/main> builtins.merge +``` + +Define a type. + +``` unison :hide +structural type Y = Y +``` + +``` ucm :hide +scratch/main> add +``` + +Now, we update `Y`, and add a new type `Z` which depends on it. + +``` unison +structural type Z = Z Y +structural type Y = Y Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type Z + + ⍟ These names already exist. You can `update` them to your + new definition: + + structural type Y + (The old definition is also named builtin.Unit.) +``` + +Adding should fail for BOTH definitions, `Y` needs an update and `Z` is blocked by `Y`. + +``` ucm :error +scratch/main> add + + x These definitions failed: + + Reason + needs update structural type Y + blocked structural type Z + + Tip: Use `help filestatus` to learn more. + +-- This shouldn't exist, because it should've been blocked. + +scratch/main> view Z + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + Z +``` diff --git a/unison-src/transcripts/idempotent/type-modifier-are-optional.md b/unison-src/transcripts/idempotent/type-modifier-are-optional.md new file mode 100644 index 0000000000..1af19c052b --- /dev/null +++ b/unison-src/transcripts/idempotent/type-modifier-are-optional.md @@ -0,0 +1,35 @@ +# Type modifiers are optional, `unique` is the default. + +``` ucm :hide +scratch/main> builtins.merge +``` + +Types and abilities may be prefixed with either `unique` or `structural`. When left unspecified, `unique` is assumed. + +``` unison +type Abc = Abc +unique type Def = Def +structural type Ghi = Ghi + +ability MyAbility where const : a +unique ability MyAbilityU where const : a +structural ability MyAbilityS where const : a +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Abc + type Def + structural type Ghi + (also named builtin.Unit) + ability MyAbility + structural ability MyAbilityS + ability MyAbilityU +``` diff --git a/unison-src/transcripts/idempotent/undo.md b/unison-src/transcripts/idempotent/undo.md new file mode 100644 index 0000000000..fd250b350c --- /dev/null +++ b/unison-src/transcripts/idempotent/undo.md @@ -0,0 +1,199 @@ +# Undo + +Undo should pop a node off of the history of the current branch. + +``` unison :hide +x = 1 +``` + +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. + +scratch/main> add + + ⍟ I've added these definitions: + + x : Nat + +scratch/main> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + +scratch/main> alias.term x y + + Done. + +scratch/main> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + 3. y (Nat) + +scratch/main> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #nmem6r6no1 + + + Adds / updates: + + y + + = Copies: + + Original name New name(s) + x y + + ⊙ 2. #3rqf1hbev7 + + + Adds / updates: + + x + + □ 3. #ms9lggs2rg (start of history) + +scratch/main> undo + + Here are the changes I undid + + Name changes: + + Original Changes + 1. x 2. y (added) + +scratch/main> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + +scratch/main> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #3rqf1hbev7 + + + Adds / updates: + + x + + □ 2. #ms9lggs2rg (start of history) +``` + +----- + +It should not be affected by changes on other branches. + +``` unison :hide +x = 1 +``` + +``` ucm +scratch/branch1> builtins.merge lib.builtins + + Done. + +scratch/branch1> add + + ⍟ I've added these definitions: + + x : Nat + +scratch/branch1> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + +scratch/branch1> alias.term x y + + Done. + +scratch/branch1> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + 3. y (Nat) + +scratch/branch1> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #nmem6r6no1 + + + Adds / updates: + + y + + = Copies: + + Original name New name(s) + x y + + ⊙ 2. #3rqf1hbev7 + + + Adds / updates: + + x + + □ 3. #ms9lggs2rg (start of history) + +-- Make some changes on an unrelated branch + +scratch/branch2> builtins.merge lib.builtins + + Done. + +scratch/branch2> delete.namespace lib + + Done. + +scratch/branch1> undo + + Here are the changes I undid + + Name changes: + + Original Changes + 1. x 2. y (added) + +scratch/branch1> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + +scratch/branch1> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #3rqf1hbev7 + + + Adds / updates: + + x + + □ 2. #ms9lggs2rg (start of history) +``` + +----- + +Undo should be a no-op on a newly created branch + +``` ucm :error +scratch/main> branch.create-empty new + + Done. I've created an empty branch scratch/new. + + Tip: Use `merge /somebranch` to initialize this branch. + +scratch/new> undo + + ⚠️ + + Nothing more to undo. +``` diff --git a/unison-src/transcripts/idempotent/unique-type-churn.md b/unison-src/transcripts/idempotent/unique-type-churn.md new file mode 100644 index 0000000000..79b8a9684c --- /dev/null +++ b/unison-src/transcripts/idempotent/unique-type-churn.md @@ -0,0 +1,135 @@ +This transcript demonstrates that unique types no longer always get a fresh GUID: they share GUIDs with already-saved +unique types of the same name. + +``` unison +unique type A = A + +unique type B = B C +unique type C = C B +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type A + type B + type C +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type A + type B + type C +``` + +``` unison +unique type A = A + +unique type B = B C +unique type C = C B +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked the definitions in scratch.u. This + file has been previously added to the codebase. +``` + +If the name stays the same, the churn is even prevented if the type is updated and then reverted to the original form. + +``` ucm +scratch/main> names A + + Type + Hash: #j743idicb1 + Names: A + + Term + Hash: #j743idicb1#0 + Names: A.A +``` + +``` unison +unique type A = A () +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type A +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> names A + + Type + Hash: #186m0i6upt + Names: A + + Term + Hash: #186m0i6upt#0 + Names: A.A +``` + +``` unison +unique type A = A +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type A +``` + +Note that `A` is back to its original hash. + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> names A + + Type + Hash: #j743idicb1 + Names: A + + Term + Hash: #j743idicb1#0 + Names: A.A +``` diff --git a/unison-src/transcripts/idempotent/unitnamespace.md b/unison-src/transcripts/idempotent/unitnamespace.md new file mode 100644 index 0000000000..271da4e84f --- /dev/null +++ b/unison-src/transcripts/idempotent/unitnamespace.md @@ -0,0 +1,35 @@ +``` unison +`()`.foo = "bar" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + `()`.foo : ##Text +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + `()`.foo : ##Text + +scratch/main> find + + 1. `()`.foo : ##Text + +scratch/main> find-in `()` + + 1. foo : ##Text + +scratch/main> delete.namespace `()` + + Done. +``` diff --git a/unison-src/transcripts/idempotent/universal-cmp.md b/unison-src/transcripts/idempotent/universal-cmp.md new file mode 100644 index 0000000000..23b14dd6ed --- /dev/null +++ b/unison-src/transcripts/idempotent/universal-cmp.md @@ -0,0 +1,75 @@ +File for test cases making sure that universal equality/comparison +cases exist for built-in types. Just making sure they don't crash. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +unique type A = A + +threadEyeDeez _ = + t1 = forkComp '() + t2 = forkComp '() + (t1 == t2, t1 < t2) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type A + threadEyeDeez : ∀ _. _ ->{IO} (Boolean, Boolean) +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type A + threadEyeDeez : ∀ _. _ ->{IO} (Boolean, Boolean) + +scratch/main> run threadEyeDeez + + (false, true) +``` + +``` unison +> typeLink A == typeLink A +> typeLink Text == typeLink Text +> typeLink Text == typeLink A +> termLink threadEyeDeez == termLink threadEyeDeez +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > typeLink A == typeLink A + ⧩ + true + + 2 | > typeLink Text == typeLink Text + ⧩ + true + + 3 | > typeLink Text == typeLink A + ⧩ + false + + 4 | > termLink threadEyeDeez == termLink threadEyeDeez + ⧩ + true +``` diff --git a/unison-src/transcripts/idempotent/unsafe-coerce.md b/unison-src/transcripts/idempotent/unsafe-coerce.md new file mode 100644 index 0000000000..16fe412eb5 --- /dev/null +++ b/unison-src/transcripts/idempotent/unsafe-coerce.md @@ -0,0 +1,54 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +f : '{} Nat +f _ = 5 + +fc : '{IO, Exception} Nat +fc = unsafe.coerceAbilities f + +main : '{IO, Exception} [Result] +main _ = + n = !fc + if n == 5 then [Ok ""] else [Fail ""] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + f : 'Nat + fc : '{IO, Exception} Nat + main : '{IO, Exception} [Result] +``` + +``` ucm +scratch/main> find unsafe.coerceAbilities + + 1. builtin.unsafe.coerceAbilities : (a ->{e1} b) -> a -> b + +scratch/main> add + + ⍟ I've added these definitions: + + f : 'Nat + fc : '{IO, Exception} Nat + main : '{IO, Exception} [Result] + +scratch/main> io.test main + + New test results: + + 1. main ◉ + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` diff --git a/unison-src/transcripts/idempotent/update-ignores-lib-namespace.md b/unison-src/transcripts/idempotent/update-ignores-lib-namespace.md new file mode 100644 index 0000000000..946fe14ceb --- /dev/null +++ b/unison-src/transcripts/idempotent/update-ignores-lib-namespace.md @@ -0,0 +1,67 @@ +`update` / `patch` (anything that a patch) ignores the namespace named "lib" at the location it's applied. This follows +the project organization convention that dependencies are put in "lib"; it's much easier to apply a patch to all of +one's own code if the "lib" namespace is simply ignored. + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison +foo = 100 +lib.foo = 100 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : Nat + lib.foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : Nat + lib.foo : Nat +``` + +``` unison +foo = 200 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : Nat + (The old definition is also named lib.foo.) +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> names foo + + Term + Hash: #9ntnotdp87 + Names: foo +``` diff --git a/unison-src/transcripts/idempotent/update-on-conflict.md b/unison-src/transcripts/idempotent/update-on-conflict.md new file mode 100644 index 0000000000..3e2392be9f --- /dev/null +++ b/unison-src/transcripts/idempotent/update-on-conflict.md @@ -0,0 +1,67 @@ +# Update on conflict + +Conflicted definitions prevent `update` from succeeding. + +``` ucm :hide +scratch/main> builtins.merge lib.builtins +``` + +``` unison +x = 1 +temp = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + temp : Nat + x : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + temp : Nat + x : Nat + +scratch/main> debug.alias.term.force temp x + + Done. + +scratch/main> delete.term temp + + Done. +``` + +``` unison +x = 3 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + x : Nat +``` + +``` ucm :error +scratch/main> update + + This branch has more than one term with the name `x`. Please + delete or rename all but one of them, then try the update + again. +``` diff --git a/unison-src/transcripts/idempotent/update-suffixifies-properly.md b/unison-src/transcripts/idempotent/update-suffixifies-properly.md new file mode 100644 index 0000000000..f0076b6ac8 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-suffixifies-properly.md @@ -0,0 +1,95 @@ +``` ucm :hide +myproject/main> builtins.merge lib.builtin +``` + +``` unison +a.x.x.x.x = 100 +b.x.x.x.x = 100 +foo = 25 +c.y.y.y.y = foo + 10 +d.y.y.y.y = foo + 10 +bar = a.x.x.x.x + c.y.y.y.y +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + a.x.x.x.x : Nat + b.x.x.x.x : Nat + bar : Nat + c.y.y.y.y : Nat + d.y.y.y.y : Nat + foo : Nat +``` + +``` ucm +myproject/main> add + + ⍟ I've added these definitions: + + a.x.x.x.x : Nat + b.x.x.x.x : Nat + bar : Nat + c.y.y.y.y : Nat + d.y.y.y.y : Nat + foo : Nat +``` + +``` unison +foo = +30 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : Int +``` + +``` ucm :error +myproject/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Typechecking failed. I've updated your scratch file with the + definitions that need fixing. Once the file is compiling, try + `update` again. +``` + +``` unison :added-by-ucm scratch.u +foo = +30 + +-- The definitions below no longer typecheck with the changes above. +-- Please fix the errors and try `update` again. + +bar : Nat +bar = + use Nat + + x + c.y.y.y.y + +c.y.y.y.y : Nat +c.y.y.y.y = + use Nat + + foo + 10 + +d.y.y.y.y : Nat +d.y.y.y.y = + use Nat + + foo + 10 + +``` diff --git a/unison-src/transcripts/idempotent/update-term-aliases-in-different-ways.md b/unison-src/transcripts/idempotent/update-term-aliases-in-different-ways.md new file mode 100644 index 0000000000..edb264cb96 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-term-aliases-in-different-ways.md @@ -0,0 +1,76 @@ +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +foo : Nat +foo = 5 + +bar : Nat +bar = 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat +``` + +``` unison +foo : Nat +foo = 6 + +bar : Nat +bar = 7 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + bar : Nat + (The old definition is also named foo.) + foo : Nat + (The old definition is also named bar.) +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> view foo bar + + bar : Nat + bar = 7 + + foo : Nat + foo = 6 +``` diff --git a/unison-src/transcripts/idempotent/update-term-to-different-type.md b/unison-src/transcripts/idempotent/update-term-to-different-type.md new file mode 100644 index 0000000000..668492cc63 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-term-to-different-type.md @@ -0,0 +1,62 @@ +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +foo : Nat +foo = 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : Nat +``` + +``` unison +foo : Int +foo = +5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : Int +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> view foo + + foo : Int + foo = +5 +``` diff --git a/unison-src/transcripts/idempotent/update-term-with-alias.md b/unison-src/transcripts/idempotent/update-term-with-alias.md new file mode 100644 index 0000000000..53a7e0b426 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-term-with-alias.md @@ -0,0 +1,71 @@ +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +foo : Nat +foo = 5 + +bar : Nat +bar = 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat +``` + +``` unison +foo : Nat +foo = 6 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : Nat + (The old definition is also named bar.) +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> view foo bar + + bar : Nat + bar = 5 + + foo : Nat + foo = 6 +``` diff --git a/unison-src/transcripts/idempotent/update-term-with-dependent-to-different-type.md b/unison-src/transcripts/idempotent/update-term-with-dependent-to-different-type.md new file mode 100644 index 0000000000..46f4430d0c --- /dev/null +++ b/unison-src/transcripts/idempotent/update-term-with-dependent-to-different-type.md @@ -0,0 +1,80 @@ +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +foo : Nat +foo = 5 + +bar : Nat +bar = foo + 10 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat +``` + +``` unison +foo : Int +foo = +5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : Int +``` + +``` ucm :error +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Typechecking failed. I've updated your scratch file with the + definitions that need fixing. Once the file is compiling, try + `update` again. +``` + +``` unison :added-by-ucm scratch.u +foo : Int +foo = +5 + +-- The definitions below no longer typecheck with the changes above. +-- Please fix the errors and try `update` again. + +bar : Nat +bar = + use Nat + + foo + 10 + +``` diff --git a/unison-src/transcripts/idempotent/update-term-with-dependent.md b/unison-src/transcripts/idempotent/update-term-with-dependent.md new file mode 100644 index 0000000000..0fb5cba6d6 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-term-with-dependent.md @@ -0,0 +1,73 @@ +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +foo : Nat +foo = 5 + +bar : Nat +bar = foo + 10 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat +``` + +``` unison +foo : Nat +foo = 6 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : Nat +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +scratch/main> view bar + + bar : Nat + bar = + use Nat + + foo + 10 +``` diff --git a/unison-src/transcripts/idempotent/update-term.md b/unison-src/transcripts/idempotent/update-term.md new file mode 100644 index 0000000000..05ed53fd95 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-term.md @@ -0,0 +1,62 @@ +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +foo : Nat +foo = 5 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : Nat +``` + +``` unison +foo : Nat +foo = 6 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : Nat +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> view foo + + foo : Nat + foo = 6 +``` diff --git a/unison-src/transcripts/idempotent/update-test-to-non-test.md b/unison-src/transcripts/idempotent/update-test-to-non-test.md new file mode 100644 index 0000000000..6735428e6a --- /dev/null +++ b/unison-src/transcripts/idempotent/update-test-to-non-test.md @@ -0,0 +1,75 @@ +``` ucm +scratch/main> builtins.merge + + Done. +``` + +``` unison +test> foo = [] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : [Result] + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | test> foo = [] + +``` + +After adding the test `foo`, we expect `view` to render it like a test. (Bug: It doesn't.) + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : [Result] + +scratch/main> view foo + + foo : [Result] + foo = [] +``` + +``` unison +foo = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : Nat +``` + +After updating `foo` to not be a test, we expect `view` to not render it like a test. + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> view foo + + foo : Nat + foo = 1 +``` diff --git a/unison-src/transcripts/idempotent/update-test-watch-roundtrip.md b/unison-src/transcripts/idempotent/update-test-watch-roundtrip.md new file mode 100644 index 0000000000..93eb6e5d47 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-test-watch-roundtrip.md @@ -0,0 +1,66 @@ +``` ucm :hide +scratch/main> builtins.merge +``` + +Given a test that depends on another definition, + +``` unison :hide +foo n = n + 1 + +test> mynamespace.foo.test = + n = 2 + if (foo n) == 2 then [ Ok "passed" ] else [ Fail "wat" ] +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : Nat -> Nat + mynamespace.foo.test : [Result] +``` + +if we change the type of the dependency, the test should show in the scratch file as a test watch. + +``` unison +foo n = "hello, world!" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : n -> Text +``` + +``` ucm :error +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Typechecking failed. I've updated your scratch file with the + definitions that need fixing. Once the file is compiling, try + `update` again. +``` + +``` unison :added-by-ucm scratch.u +foo n = "hello, world!" + +-- The definitions below no longer typecheck with the changes above. +-- Please fix the errors and try `update` again. + +test> mynamespace.foo.test = + n = 2 + if foo n == 2 then [Ok "passed"] else [Fail "wat"] + +``` diff --git a/unison-src/transcripts/idempotent/update-type-add-constructor.md b/unison-src/transcripts/idempotent/update-type-add-constructor.md new file mode 100644 index 0000000000..df8e58f663 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-add-constructor.md @@ -0,0 +1,72 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo + = Bar Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo +``` + +``` unison +unique type Foo + = Bar Nat + | Baz Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> view Foo + + type Foo = Baz Nat Nat | Bar Nat + +scratch/main> find.verbose + + 1. -- #id3p6do8f7ssln9npa3gs3c2i8uors25ffts92pr4nsh9k9bn3no50e4d1b053c2d0vei64pbtcpdld9gk6drsvptnpfqr6tp8v4qh0 + type Foo + + 2. -- #id3p6do8f7ssln9npa3gs3c2i8uors25ffts92pr4nsh9k9bn3no50e4d1b053c2d0vei64pbtcpdld9gk6drsvptnpfqr6tp8v4qh0#1 + Foo.Bar : Nat -> Foo + + 3. -- #id3p6do8f7ssln9npa3gs3c2i8uors25ffts92pr4nsh9k9bn3no50e4d1b053c2d0vei64pbtcpdld9gk6drsvptnpfqr6tp8v4qh0#0 + Foo.Baz : Nat -> Nat -> Foo + +``` diff --git a/unison-src/transcripts/idempotent/update-type-add-field.md b/unison-src/transcripts/idempotent/update-type-add-field.md new file mode 100644 index 0000000000..83773a6e03 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-add-field.md @@ -0,0 +1,66 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = Bar Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo +``` + +``` unison +unique type Foo = Bar Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> view Foo + + type Foo = Bar Nat Nat + +scratch/main> find.verbose + + 1. -- #hlhjq1lf1cvfevkvb9d441kkubn0f6s43gvrd4gcff0r739vomehjnov4b3qe8506fb5bm8m5ba0sol9mbljgkk3gb2qt2u02v6i2vo + type Foo + + 2. -- #hlhjq1lf1cvfevkvb9d441kkubn0f6s43gvrd4gcff0r739vomehjnov4b3qe8506fb5bm8m5ba0sol9mbljgkk3gb2qt2u02v6i2vo#0 + Foo.Bar : Nat -> Nat -> Foo + +``` diff --git a/unison-src/transcripts/idempotent/update-type-add-new-record.md b/unison-src/transcripts/idempotent/update-type-add-new-record.md new file mode 100644 index 0000000000..b6373bd0d9 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-add-new-record.md @@ -0,0 +1,35 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtins +``` + +``` unison +unique type Foo = { bar : Nat } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + Foo.bar : Foo -> Nat + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.bar.set : Nat -> Foo -> Foo +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> view Foo + + type Foo = { bar : Nat } +``` diff --git a/unison-src/transcripts/idempotent/update-type-add-record-field.md b/unison-src/transcripts/idempotent/update-type-add-record-field.md new file mode 100644 index 0000000000..173d29b30d --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-add-record-field.md @@ -0,0 +1,99 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = { bar : Nat } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + Foo.bar : Foo -> Nat + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.bar.set : Nat -> Foo -> Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + Foo.bar : Foo -> Nat + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.bar.set : Nat -> Foo -> Foo +``` + +``` unison +unique type Foo = { bar : Nat, baz : Int } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Foo.baz : Foo -> Int + Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo + Foo.baz.set : Int -> Foo -> Foo + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo + Foo.bar : Foo -> Nat + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.bar.set : Nat -> Foo -> Foo +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> view Foo + + type Foo = { bar : Nat, baz : Int } + +scratch/main> find.verbose + + 1. -- #m0tpa159pbsdld5ea0marnq9614dnmjjc72n1evi4bsk45a1hl84qprt6vdvejuuiuc3f5o23olc1t19tk1dt8mjobmr0chqc3svij8 + type Foo + + 2. -- #16o21u2lli7rd8f3h4epnblpfk3h68gag99d5gicihcpk15dkv4m9601picg37ncsbg2e8j63tu7ebs40jrcoifs7f6nqrus3qnfgv0 + Foo.bar : Foo -> Nat + + 3. -- #64v4pv4rvmnts82gbsb1u2dvgdu4eqq8leq37anqjrkq8s9c7ogrjahdotc36nrodva6ok1rs4ah5k09i7sb0clvcap2773k1t7thb8 + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + + 4. -- #bkfjhnu5jqv2m49hosd8g6m4e5u9ju4b1du90cji8s8hnaendvnep2a5cd085ejtu27c4lm3u7slamk52p86rubp211jc5c0qcut2l0 + Foo.bar.set : Nat -> Foo -> Foo + + 5. -- #u394ule3vr1ab8q5nit6miktgpki9gj4nft5jfjsho6cflg94kf953mdhjj8s18e9j1525iv8l5ebjhebnuc01q51fl8ni5n9j0gs28 + Foo.baz : Foo -> Int + + 6. -- #cbbi7mqcaqdlcl41uajb608b8fi5dfvc654rmd47mk9okpn1t3jltrf8psnn3g2tnr1ftctj753fjhco3ku1oapc664upo1h6eodfrg + Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo + + 7. -- #hhi45ik1245qq3g93586f998di8j5afvjamqr2m08auqq8ogqt4d01rejrse4qsl27381vnqnt8uffhgvnc0nk22o5uabimjhji4868 + Foo.baz.set : Int -> Foo -> Foo + + 8. -- #m0tpa159pbsdld5ea0marnq9614dnmjjc72n1evi4bsk45a1hl84qprt6vdvejuuiuc3f5o23olc1t19tk1dt8mjobmr0chqc3svij8#0 + Foo.Foo : Nat -> Int -> Foo + +``` diff --git a/unison-src/transcripts/idempotent/update-type-constructor-alias.md b/unison-src/transcripts/idempotent/update-type-constructor-alias.md new file mode 100644 index 0000000000..044772b2db --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-constructor-alias.md @@ -0,0 +1,63 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = Bar Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + +scratch/main> alias.term Foo.Bar Foo.BarAlias + + Done. +``` + +``` unison +unique type Foo = Bar Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm :error +scratch/main> update + + Sorry, I wasn't able to perform the update: + + The type Foo has a constructor with multiple names, and I + can't perform an update in this situation: + + * Foo.Bar + * Foo.BarAlias + + Please delete all but one name for each constructor, and then + try updating again. +``` diff --git a/unison-src/transcripts/idempotent/update-type-delete-constructor-with-dependent.md b/unison-src/transcripts/idempotent/update-type-delete-constructor-with-dependent.md new file mode 100644 index 0000000000..8c11024b9c --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-delete-constructor-with-dependent.md @@ -0,0 +1,80 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo + = Bar Nat + | Baz Nat Nat + +foo : Foo -> Nat +foo = cases + Bar n -> n + Baz n m -> n + m +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + foo : Foo -> Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + foo : Foo -> Nat +``` + +``` unison +unique type Foo + = Bar Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm :error +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Typechecking failed. I've updated your scratch file with the + definitions that need fixing. Once the file is compiling, try + `update` again. +``` + +``` unison :added-by-ucm scratch.u +type Foo = Bar Nat + +-- The definitions below no longer typecheck with the changes above. +-- Please fix the errors and try `update` again. + +foo : Foo -> Nat +foo = cases + Bar n -> n + Baz n m -> n Nat.+ m + +``` diff --git a/unison-src/transcripts/idempotent/update-type-delete-constructor.md b/unison-src/transcripts/idempotent/update-type-delete-constructor.md new file mode 100644 index 0000000000..0457b42d0d --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-delete-constructor.md @@ -0,0 +1,69 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo + = Bar Nat + | Baz Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo +``` + +``` unison +unique type Foo + = Bar Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> view Foo + + type Foo = Bar Nat + +scratch/main> find.verbose + + 1. -- #h88o5sirfn0a8f4o81sb012p2rha5h8r73n8bloc8qq94kqmltjq94iiep2e6dj7ppuulc8jce2f0vmddqp76nm0hqs9jh53s502v4g + type Foo + + 2. -- #h88o5sirfn0a8f4o81sb012p2rha5h8r73n8bloc8qq94kqmltjq94iiep2e6dj7ppuulc8jce2f0vmddqp76nm0hqs9jh53s502v4g#0 + Foo.Bar : Nat -> Foo + +``` diff --git a/unison-src/transcripts/idempotent/update-type-delete-record-field.md b/unison-src/transcripts/idempotent/update-type-delete-record-field.md new file mode 100644 index 0000000000..c15cd9122b --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-delete-record-field.md @@ -0,0 +1,122 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = { bar : Nat, baz : Int } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + Foo.bar : Foo -> Nat + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.bar.set : Nat -> Foo -> Foo + Foo.baz : Foo -> Int + Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo + Foo.baz.set : Int -> Foo -> Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + Foo.bar : Foo -> Nat + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.bar.set : Nat -> Foo -> Foo + Foo.baz : Foo -> Int + Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo + Foo.baz.set : Int -> Foo -> Foo +``` + +``` unison +unique type Foo = { bar : Nat } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo + Foo.bar : Foo -> Nat + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.bar.set : Nat -> Foo -> Foo +``` + +We want the field accessors to go away; but for now they are here, causing the update to fail. + +``` ucm :error +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Typechecking failed. I've updated your scratch file with the + definitions that need fixing. Once the file is compiling, try + `update` again. + +scratch/main> view Foo + + type Foo = { bar : Nat, baz : Int } + +scratch/main> find.verbose + + 1. -- #m0tpa159pbsdld5ea0marnq9614dnmjjc72n1evi4bsk45a1hl84qprt6vdvejuuiuc3f5o23olc1t19tk1dt8mjobmr0chqc3svij8 + type Foo + + 2. -- #16o21u2lli7rd8f3h4epnblpfk3h68gag99d5gicihcpk15dkv4m9601picg37ncsbg2e8j63tu7ebs40jrcoifs7f6nqrus3qnfgv0 + Foo.bar : Foo -> Nat + + 3. -- #64v4pv4rvmnts82gbsb1u2dvgdu4eqq8leq37anqjrkq8s9c7ogrjahdotc36nrodva6ok1rs4ah5k09i7sb0clvcap2773k1t7thb8 + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + + 4. -- #bkfjhnu5jqv2m49hosd8g6m4e5u9ju4b1du90cji8s8hnaendvnep2a5cd085ejtu27c4lm3u7slamk52p86rubp211jc5c0qcut2l0 + Foo.bar.set : Nat -> Foo -> Foo + + 5. -- #u394ule3vr1ab8q5nit6miktgpki9gj4nft5jfjsho6cflg94kf953mdhjj8s18e9j1525iv8l5ebjhebnuc01q51fl8ni5n9j0gs28 + Foo.baz : Foo -> Int + + 6. -- #cbbi7mqcaqdlcl41uajb608b8fi5dfvc654rmd47mk9okpn1t3jltrf8psnn3g2tnr1ftctj753fjhco3ku1oapc664upo1h6eodfrg + Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo + + 7. -- #hhi45ik1245qq3g93586f998di8j5afvjamqr2m08auqq8ogqt4d01rejrse4qsl27381vnqnt8uffhgvnc0nk22o5uabimjhji4868 + Foo.baz.set : Int -> Foo -> Foo + + 8. -- #m0tpa159pbsdld5ea0marnq9614dnmjjc72n1evi4bsk45a1hl84qprt6vdvejuuiuc3f5o23olc1t19tk1dt8mjobmr0chqc3svij8#0 + Foo.Foo : Nat -> Int -> Foo + +``` + +``` unison :added-by-ucm scratch.u +type Foo = { bar : Nat } + +-- The definitions below no longer typecheck with the changes above. +-- Please fix the errors and try `update` again. + +Foo.baz : Foo -> Int +Foo.baz = cases Foo _ baz -> baz + +Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo +Foo.baz.modify f = cases Foo bar baz -> Foo bar (f baz) + +Foo.baz.set : Int -> Foo -> Foo +Foo.baz.set baz1 = cases Foo bar _ -> Foo bar baz1 + +``` diff --git a/unison-src/transcripts/idempotent/update-type-missing-constructor.md b/unison-src/transcripts/idempotent/update-type-missing-constructor.md new file mode 100644 index 0000000000..e7198191bd --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-missing-constructor.md @@ -0,0 +1,67 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = Bar Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + +scratch/main> delete.term Foo.Bar + + Done. +``` + +Now we've set up a situation where the original constructor missing. + +``` unison +unique type Foo = Bar Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm :error +scratch/main> view Foo + + type Foo = #5mod0n8ps2#0 Nat + +scratch/main> update + + Sorry, I wasn't able to perform the update: + + The type Foo has some constructors with missing names, and I + can't perform an update in this situation. + + You can use `view Foo` and + `alias.term Foo.` to give names to + each unnamed constructor, and then try the update again. +``` diff --git a/unison-src/transcripts/idempotent/update-type-nested-decl-aliases.md b/unison-src/transcripts/idempotent/update-type-nested-decl-aliases.md new file mode 100644 index 0000000000..5ce5ee0fea --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-nested-decl-aliases.md @@ -0,0 +1,60 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = Bar Nat + +structural type A.B = OneAlias Foo +structural type A = B.TheOtherAlias Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type A + structural type A.B + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + structural type A + structural type A.B + type Foo +``` + +``` unison +unique type Foo = Bar Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm :error +scratch/main> update + + The type A.B is an alias of A. I'm not able to perform an + update when a type exists nested under an alias of itself. + Please separate them or delete one copy, and then try updating + again. +``` diff --git a/unison-src/transcripts/idempotent/update-type-no-op-record.md b/unison-src/transcripts/idempotent/update-type-no-op-record.md new file mode 100644 index 0000000000..0b8888835c --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-no-op-record.md @@ -0,0 +1,44 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = { bar : Nat } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + Foo.bar : Foo -> Nat + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.bar.set : Nat -> Foo -> Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + Foo.bar : Foo -> Nat + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.bar.set : Nat -> Foo -> Foo +``` + +Bug: this no-op update should (of course) succeed. + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` diff --git a/unison-src/transcripts/idempotent/update-type-stray-constructor-alias.md b/unison-src/transcripts/idempotent/update-type-stray-constructor-alias.md new file mode 100644 index 0000000000..8e29e089ba --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-stray-constructor-alias.md @@ -0,0 +1,61 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = Bar Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + +scratch/main> alias.term Foo.Bar Stray.BarAlias + + Done. +``` + +``` unison +unique type Foo = Bar Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm :error +scratch/main> update + + Sorry, I wasn't able to perform the update, because I need all + constructor names to be nested somewhere beneath the + corresponding type name. + + The constructor Stray.BarAlias is not nested beneath the + corresponding type name. Please either use `move` to move it, + or if it's an extra copy, you can simply `delete` it. Then try + the update again. +``` diff --git a/unison-src/transcripts/idempotent/update-type-stray-constructor.md b/unison-src/transcripts/idempotent/update-type-stray-constructor.md new file mode 100644 index 0000000000..8e5aaa91cb --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-stray-constructor.md @@ -0,0 +1,69 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = Bar Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + +scratch/main> move.term Foo.Bar Stray.Bar + + Done. +``` + +Now we've set up a situation where the constructor is not where it's supposed to be; it's somewhere else. + +``` unison +unique type Foo = Bar Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +Note that the constructor name shown here (implied to be called `Foo.Stray.Bar`) doesn't really exist, it's just showing up due to a pretty-printer bug. + +``` ucm :error +scratch/main> view Foo + + type Foo = Stray.Bar Nat + +scratch/main> update + + Sorry, I wasn't able to perform the update: + + The type Foo has some constructors with missing names, and I + can't perform an update in this situation. + + You can use `view Foo` and + `alias.term Foo.` to give names to + each unnamed constructor, and then try the update again. +``` diff --git a/unison-src/transcripts/idempotent/update-type-turn-constructor-into-smart-constructor.md b/unison-src/transcripts/idempotent/update-type-turn-constructor-into-smart-constructor.md new file mode 100644 index 0000000000..b96ea2bc1d --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-turn-constructor-into-smart-constructor.md @@ -0,0 +1,85 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = Bar Nat + +makeFoo : Nat -> Foo +makeFoo n = Bar (n+10) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + makeFoo : Nat -> Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + makeFoo : Nat -> Foo +``` + +``` unison +unique type Foo = internal.Bar Nat + +Foo.Bar : Nat -> Foo +Foo.Bar n = internal.Bar n +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⊡ Previously added definitions will be ignored: Foo + + ⍟ These new definitions are ok to `add`: + + Foo.Bar : Nat -> Foo +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +scratch/main> view Foo + + type Foo = internal.Bar Nat + +scratch/main> find.verbose + + 1. -- #oebc8v8v9lob5bnq7go1pjhfjbtnh8dmfhontua90t3mji0cl91t1dqaece9quofrk1vsbq6g0ukfigoi0vmvc01v8roceppejlgbs8 + type Foo + + 2. -- #gl18p1lnbeari67ohdt9n46usnvsl59a6up1lhd9r808pqb7tt5edsf65o98bqcvb529mfm7q631ciuv2t5nqnde1i7b9t5mlu1drto + Foo.Bar : Nat -> Foo + + 3. -- #oebc8v8v9lob5bnq7go1pjhfjbtnh8dmfhontua90t3mji0cl91t1dqaece9quofrk1vsbq6g0ukfigoi0vmvc01v8roceppejlgbs8#0 + Foo.internal.Bar : Nat -> Foo + + 4. -- #td96hudai64mf0qgtusc70ehv98krs10jghdipjluc6cp4j8ac65msrt3tji18enpm2tm8d8h2qcf3parke19g7s17ipkd925m3061g + makeFoo : Nat -> Foo + +``` diff --git a/unison-src/transcripts/idempotent/update-type-turn-non-record-into-record.md b/unison-src/transcripts/idempotent/update-type-turn-non-record-into-record.md new file mode 100644 index 0000000000..1801932fa7 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-turn-non-record-into-record.md @@ -0,0 +1,81 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo +``` + +``` unison +unique type Foo = { bar : Nat } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Foo.bar : Foo -> Nat + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + Foo.bar.set : Nat -> Foo -> Foo + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> view Foo + + type Foo = { bar : Nat } + +scratch/main> find.verbose + + 1. -- #5mod0n8ps2emue478fdroo6adp4ovt41qogtmduta8vgv1v8mi8ep2ho0rc1mg699j1feojmv0oe9ndbul5t64menchhnklpgji45o0 + type Foo + + 2. -- #pshsb3s03nqe194ks3ap3kid0gpb13d68u83gss8vtmbfqma97f84b4vqf362r8gieulqnbfidvh9idkgp6k7mllmss92bh9ebqmolo + Foo.bar : Foo -> Nat + + 3. -- #184mc2vauvn8197ecedvus5ubj787dgav6cjkvqqnohej8f997ku7iicurnkvlcqtlv29mjad0mjr3td241q7b0b0kg0i9v4n3qq7vo + Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo + + 4. -- #sc08708c9s5mhtg6r1obh2mckvjhc5pf2e83lafrkrjrpkikh9kn09vag7kbugcnit50ak8vgr1100am6iqo4ln75uq4dck9pasvnv8 + Foo.bar.set : Nat -> Foo -> Foo + + 5. -- #5mod0n8ps2emue478fdroo6adp4ovt41qogtmduta8vgv1v8mi8ep2ho0rc1mg699j1feojmv0oe9ndbul5t64menchhnklpgji45o0#0 + Foo.Foo : Nat -> Foo + +``` diff --git a/unison-src/transcripts/idempotent/update-type-with-dependent-term.md b/unison-src/transcripts/idempotent/update-type-with-dependent-term.md new file mode 100644 index 0000000000..c59e3bef59 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-with-dependent-term.md @@ -0,0 +1,73 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = Bar Nat + +incrFoo : Foo -> Foo +incrFoo = cases Bar n -> Bar (n+1) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + incrFoo : Foo -> Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + incrFoo : Foo -> Foo +``` + +``` unison +unique type Foo = Bar Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm :error +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Typechecking failed. I've updated your scratch file with the + definitions that need fixing. Once the file is compiling, try + `update` again. +``` + +``` unison :added-by-ucm scratch.u +type Foo = Bar Nat Nat + +-- The definitions below no longer typecheck with the changes above. +-- Please fix the errors and try `update` again. + +incrFoo : Foo -> Foo +incrFoo = cases Bar n -> Bar (n Nat.+ 1) + +``` diff --git a/unison-src/transcripts/idempotent/update-type-with-dependent-type-to-different-kind.md b/unison-src/transcripts/idempotent/update-type-with-dependent-type-to-different-kind.md new file mode 100644 index 0000000000..e1b257cf7c --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-with-dependent-type-to-different-kind.md @@ -0,0 +1,70 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = Bar Nat +unique type Baz = Qux Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Baz + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Baz + type Foo +``` + +``` unison +unique type Foo a = Bar Nat a +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo a +``` + +``` ucm :error +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Typechecking failed. I've updated your scratch file with the + definitions that need fixing. Once the file is compiling, try + `update` again. +``` + +``` unison :added-by-ucm scratch.u +type Foo a = Bar Nat a + +-- The definitions below no longer typecheck with the changes above. +-- Please fix the errors and try `update` again. + +type Baz = Qux Foo + +``` diff --git a/unison-src/transcripts/idempotent/update-type-with-dependent-type.md b/unison-src/transcripts/idempotent/update-type-with-dependent-type.md new file mode 100644 index 0000000000..83c8812f72 --- /dev/null +++ b/unison-src/transcripts/idempotent/update-type-with-dependent-type.md @@ -0,0 +1,83 @@ +``` ucm :hide +scratch/main> builtins.merge lib.builtin +``` + +``` unison +unique type Foo = Bar Nat +unique type Baz = Qux Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Baz + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Baz + type Foo +``` + +``` unison +unique type Foo = Bar Nat Nat +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +scratch/main> view Foo + + type Foo = Bar Nat Nat + +scratch/main> view Baz + + type Baz = Qux Foo + +scratch/main> find.verbose + + 1. -- #1uosg6rv85ql7rbohtfvqqacgjl5pp2faj0t3k3dkrtn0t3jqdh2m2om8earv0jh8m8j86vv6bv1h17jl8a2lfa857pm6n27hnisi1g + type Baz + + 2. -- #1uosg6rv85ql7rbohtfvqqacgjl5pp2faj0t3k3dkrtn0t3jqdh2m2om8earv0jh8m8j86vv6bv1h17jl8a2lfa857pm6n27hnisi1g#0 + Baz.Qux : Foo -> Baz + + 3. -- #hlhjq1lf1cvfevkvb9d441kkubn0f6s43gvrd4gcff0r739vomehjnov4b3qe8506fb5bm8m5ba0sol9mbljgkk3gb2qt2u02v6i2vo + type Foo + + 4. -- #hlhjq1lf1cvfevkvb9d441kkubn0f6s43gvrd4gcff0r739vomehjnov4b3qe8506fb5bm8m5ba0sol9mbljgkk3gb2qt2u02v6i2vo#0 + Foo.Bar : Nat -> Nat -> Foo + +``` diff --git a/unison-src/transcripts/idempotent/update-watch.md b/unison-src/transcripts/idempotent/update-watch.md new file mode 100644 index 0000000000..6772cf521b --- /dev/null +++ b/unison-src/transcripts/idempotent/update-watch.md @@ -0,0 +1,27 @@ +``` unison +> 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > 1 + ⧩ + 1 +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` diff --git a/unison-src/transcripts/idempotent/upgrade-happy-path.md b/unison-src/transcripts/idempotent/upgrade-happy-path.md new file mode 100644 index 0000000000..dcc674be5a --- /dev/null +++ b/unison-src/transcripts/idempotent/upgrade-happy-path.md @@ -0,0 +1,73 @@ +``` ucm :hide +proj/main> builtins.merge lib.builtin +``` + +``` unison +lib.old.foo = 17 +lib.new.foo = 18 +thingy = lib.old.foo + 10 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.new.foo : Nat + lib.old.foo : Nat + thingy : Nat +``` + +``` ucm +proj/main> add + + ⍟ I've added these definitions: + + lib.new.foo : Nat + lib.old.foo : Nat + thingy : Nat +``` + +Test tab completion and fzf options of upgrade command. + +``` ucm +proj/main> debug.tab-complete upgrade ol + + old + +proj/main> debug.fuzzy-options upgrade _ + + Select a dependency to upgrade: + * builtin + * new + * old + +proj/main> debug.fuzzy-options upgrade old _ + + Select a dependency to upgrade to: + * builtin + * new + * old +``` + +``` ucm +proj/main> upgrade old new + + I upgraded old to new, and removed old. + +proj/main> ls lib + + 1. builtin/ (469 terms, 74 types) + 2. new/ (1 term) + +proj/main> view thingy + + thingy : Nat + thingy = + use Nat + + foo + 10 +``` diff --git a/unison-src/transcripts/idempotent/upgrade-sad-path.md b/unison-src/transcripts/idempotent/upgrade-sad-path.md new file mode 100644 index 0000000000..2c56bf72d8 --- /dev/null +++ b/unison-src/transcripts/idempotent/upgrade-sad-path.md @@ -0,0 +1,109 @@ +``` ucm :hide +proj/main> builtins.merge lib.builtin +``` + +``` unison +lib.old.foo = 17 +lib.new.foo = +18 +thingy = lib.old.foo + 10 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + lib.new.foo : Int + lib.old.foo : Nat + thingy : Nat +``` + +``` ucm +proj/main> add + + ⍟ I've added these definitions: + + lib.new.foo : Int + lib.old.foo : Nat + thingy : Nat +``` + +``` ucm :error +proj/main> upgrade old new + + I couldn't automatically upgrade old to new. However, I've + added the definitions that need attention to the top of + scratch.u. + + When you're done, you can run + + upgrade.commit + + to merge your changes back into main and delete the temporary + branch. Or, if you decide to cancel the upgrade instead, you + can run + + delete.branch /upgrade-old-to-new + + to delete the temporary branch and switch back to main. +``` + +``` unison :added-by-ucm scratch.u +thingy : Nat +thingy = + use Nat + + foo + 10 +``` + +Resolve the error and commit the upgrade. + +``` unison +thingy = foo + +10 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + thingy : Int +``` + +``` ucm +proj/upgrade-old-to-new> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +proj/upgrade-old-to-new> upgrade.commit + + I fast-forward merged proj/upgrade-old-to-new into proj/main. + +proj/main> view thingy + + thingy : Int + thingy = + use Int + + foo + +10 + +proj/main> ls lib + + 1. builtin/ (469 terms, 74 types) + 2. new/ (1 term) + +proj/main> branches + + Branch Remote branch + 1. main +``` diff --git a/unison-src/transcripts/idempotent/upgrade-suffixifies-properly.md b/unison-src/transcripts/idempotent/upgrade-suffixifies-properly.md new file mode 100644 index 0000000000..96bee848b0 --- /dev/null +++ b/unison-src/transcripts/idempotent/upgrade-suffixifies-properly.md @@ -0,0 +1,82 @@ +``` ucm :hide +myproject/main> builtins.merge lib.builtin +``` + +``` unison +lib.old.foo = 25 +lib.new.foo = +30 +a.x.x.x.x = 100 +b.x.x.x.x = 100 +c.y.y.y.y = lib.old.foo + 10 +d.y.y.y.y = lib.old.foo + 10 +bar = a.x.x.x.x + c.y.y.y.y +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + a.x.x.x.x : Nat + b.x.x.x.x : Nat + bar : Nat + c.y.y.y.y : Nat + d.y.y.y.y : Nat + lib.new.foo : Int + lib.old.foo : Nat +``` + +``` ucm +myproject/main> add + + ⍟ I've added these definitions: + + a.x.x.x.x : Nat + b.x.x.x.x : Nat + bar : Nat + c.y.y.y.y : Nat + d.y.y.y.y : Nat + lib.new.foo : Int + lib.old.foo : Nat +``` + +``` ucm :error +myproject/main> upgrade old new + + I couldn't automatically upgrade old to new. However, I've + added the definitions that need attention to the top of + scratch.u. + + When you're done, you can run + + upgrade.commit + + to merge your changes back into main and delete the temporary + branch. Or, if you decide to cancel the upgrade instead, you + can run + + delete.branch /upgrade-old-to-new + + to delete the temporary branch and switch back to main. +``` + +``` unison :added-by-ucm scratch.u +bar : Nat +bar = + use Nat + + x + c.y.y.y.y + +c.y.y.y.y : Nat +c.y.y.y.y = + use Nat + + foo + 10 + +d.y.y.y.y : Nat +d.y.y.y.y = + use Nat + + foo + 10 +``` diff --git a/unison-src/transcripts/idempotent/upgrade-with-old-alias.md b/unison-src/transcripts/idempotent/upgrade-with-old-alias.md new file mode 100644 index 0000000000..4038b3df88 --- /dev/null +++ b/unison-src/transcripts/idempotent/upgrade-with-old-alias.md @@ -0,0 +1,50 @@ +``` ucm :hide +myproject/main> builtins.merge lib.builtin +``` + +``` unison +lib.old.foo = 141 +lib.new.foo = 142 +bar = 141 +mything = lib.old.foo + 100 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + lib.new.foo : Nat + lib.old.foo : Nat + mything : Nat +``` + +``` ucm +myproject/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +myproject/main> upgrade old new + + I upgraded old to new, and removed old. + +myproject/main> view mything + + mything : Nat + mything = + use Nat + + foo + 100 + +myproject/main> view bar + + bar : Nat + bar = 141 +``` diff --git a/unison-src/transcripts/idempotent/view.md b/unison-src/transcripts/idempotent/view.md new file mode 100644 index 0000000000..05ed7f006e --- /dev/null +++ b/unison-src/transcripts/idempotent/view.md @@ -0,0 +1,42 @@ +# View commands + +``` ucm :hide +scratch/main> builtins.merge +``` + +``` unison :hide +a.thing = "a" +b.thing = "b" +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +-- Should suffix-search and find values in sub-namespaces + +scratch/main> view thing + + a.thing : Text + a.thing = "a" + + b.thing : Text + b.thing = "b" + +-- Should support absolute paths + +scratch/main> view .b.thing + + .b.thing : Text + .b.thing = "b" +``` + +TODO: swap this back to a 'ucm' block when view.global is re-implemented + +``` +-- view.global should search globally and be absolutely qualified +scratch/other> view.global thing +-- Should support branch relative paths +scratch/other> view /main:a.thing +``` diff --git a/unison-src/transcripts/idempotent/watch-expressions.md b/unison-src/transcripts/idempotent/watch-expressions.md new file mode 100644 index 0000000000..dffa25f89f --- /dev/null +++ b/unison-src/transcripts/idempotent/watch-expressions.md @@ -0,0 +1,94 @@ +``` ucm +scratch/main> builtins.mergeio + + Done. +``` + +``` unison +test> pass = [Ok "Passed"] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + pass : [Result] + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | test> pass = [Ok "Passed"] + + ✅ Passed Passed +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + pass : [Result] +``` + +``` unison +test> pass = [Ok "Passed"] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked the definitions in scratch.u. This + file has been previously added to the codebase. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | test> pass = [Ok "Passed"] + + ✅ Passed Passed (cached) +``` + +``` ucm +scratch/main> add + + ⊡ Ignored previously added definitions: pass + +scratch/main> test + + Cached test results (`help testcache` to learn more) + + 1. pass ◉ Passed + + ✅ 1 test(s) passing + + Tip: Use view 1 to view the source of a test. +``` + +``` unison +> ImmutableArray.fromList [?a, ?b, ?c] +> ImmutableByteArray.fromBytes 0xs123456 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + ✅ + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > ImmutableArray.fromList [?a, ?b, ?c] + ⧩ + ImmutableArray.fromList [?a, ?b, ?c] + + 2 | > ImmutableByteArray.fromBytes 0xs123456 + ⧩ + fromBytes 0xs123456 +``` diff --git a/unison-src/transcripts/io-test-command.md b/unison-src/transcripts/io-test-command.md deleted file mode 100644 index 98d55a3da3..0000000000 --- a/unison-src/transcripts/io-test-command.md +++ /dev/null @@ -1,43 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -The `io.test` command should run all of the tests within the current namespace, excluding libs. - -```unison:hide --- We manually specify types so we don't need to pull in base to run IO and such -ioAndExceptionTest : '{IO, Exception} [Result] -ioAndExceptionTest = do - [Ok "Success"] - -ioTest : '{IO} [Result] -ioTest = do - [Ok "Success"] - -lib.ioAndExceptionTestInLib : '{IO, Exception} [Result] -lib.ioAndExceptionTestInLib = do - [Ok "Success"] -``` - -```ucm:hide -.> add -``` - -Run a IO tests one by one - -```ucm -.> io.test ioAndExceptionTest -.> io.test ioTest -``` - -`io.test` doesn't cache results - -```ucm -.> io.test ioAndExceptionTest -``` - -`io.test.all` will run all matching tests except those in the `lib` namespace. - -```ucm -.> io.test.all -``` diff --git a/unison-src/transcripts/io-test-command.output.md b/unison-src/transcripts/io-test-command.output.md deleted file mode 100644 index 840d72b4f7..0000000000 --- a/unison-src/transcripts/io-test-command.output.md +++ /dev/null @@ -1,78 +0,0 @@ -The `io.test` command should run all of the tests within the current namespace, excluding libs. - -```unison --- We manually specify types so we don't need to pull in base to run IO and such -ioAndExceptionTest : '{IO, Exception} [Result] -ioAndExceptionTest = do - [Ok "Success"] - -ioTest : '{IO} [Result] -ioTest = do - [Ok "Success"] - -lib.ioAndExceptionTestInLib : '{IO, Exception} [Result] -lib.ioAndExceptionTestInLib = do - [Ok "Success"] -``` - -Run a IO tests one by one - -```ucm -.> io.test ioAndExceptionTest - - New test results: - - ◉ ioAndExceptionTest Success - - ✅ 1 test(s) passing - - Tip: Use view ioAndExceptionTest to view the source of a test. - -.> io.test ioTest - - New test results: - - ◉ ioTest Success - - ✅ 1 test(s) passing - - Tip: Use view ioTest to view the source of a test. - -``` -`io.test` doesn't cache results - -```ucm -.> io.test ioAndExceptionTest - - New test results: - - ◉ ioAndExceptionTest Success - - ✅ 1 test(s) passing - - Tip: Use view ioAndExceptionTest to view the source of a test. - -``` -`io.test.all` will run all matching tests except those in the `lib` namespace. - -```ucm -.> io.test.all - - - - - - - - - - New test results: - - ◉ ioAndExceptionTest Success - ◉ ioTest Success - - ✅ 2 test(s) passing - - Tip: Use view ioAndExceptionTest to view the source of a test. - -``` diff --git a/unison-src/transcripts/io.md b/unison-src/transcripts/io.md deleted file mode 100644 index 4caedaef05..0000000000 --- a/unison-src/transcripts/io.md +++ /dev/null @@ -1,422 +0,0 @@ -# tests for built-in IO functions - -```ucm:hide -.> builtins.merge -.> builtins.mergeio -.> load unison-src/transcripts-using-base/base.u -.> add -``` - -Tests for IO builtins which wired to foreign haskell calls. - -## Setup - -You can skip the section which is just needed to make the transcript self-contained. - -TempDirs/autoCleaned is an ability/hanlder which allows you to easily -create a scratch directory which will automatically get cleaned up. - -```ucm:hide -.> add -``` - -## Basic File Functions - -### Creating/Deleting/Renaming Directories - -Tests: createDirectory, - isDirectory, - fileExists, - renameDirectory, - deleteDirectory - -```unison -testCreateRename : '{io2.IO} [Result] -testCreateRename _ = - test = 'let - tempDir = newTempDir "fileio" - fooDir = tempDir ++ "/foo" - barDir = tempDir ++ "/bar" - void x = () - void (createDirectory.impl fooDir) - check "create a foo directory" (isDirectory fooDir) - check "directory should exist" (fileExists fooDir) - renameDirectory fooDir barDir - check "foo should no longer exist" (not (fileExists fooDir)) - check "directory should no longer exist" (not (fileExists fooDir)) - check "bar should now exist" (fileExists barDir) - - bazDir = barDir ++ "/baz" - void (createDirectory.impl bazDir) - void (removeDirectory.impl barDir) - - check "removeDirectory works recursively" (not (isDirectory barDir)) - check "removeDirectory works recursively" (not (isDirectory bazDir)) - - runTest test -``` - -```ucm -.> add -.> io.test testCreateRename -``` - -### Opening / Closing files - -Tests: openFile - closeFile - isFileOpen - -```unison -testOpenClose : '{io2.IO} [Result] -testOpenClose _ = - test = 'let - tempDir = (newTempDir "seek") - fooFile = tempDir ++ "/foo" - handle1 = openFile fooFile FileMode.Write - check "file should be open" (isFileOpen handle1) - setBuffering handle1 (SizedBlockBuffering 1024) - check "file handle buffering should match what we just set." (getBuffering handle1 == SizedBlockBuffering 1024) - setBuffering handle1 (getBuffering handle1) - putBytes handle1 0xs01 - setBuffering handle1 NoBuffering - setBuffering handle1 (getBuffering handle1) - putBytes handle1 0xs23 - setBuffering handle1 BlockBuffering - setBuffering handle1 (getBuffering handle1) - putBytes handle1 0xs45 - setBuffering handle1 LineBuffering - setBuffering handle1 (getBuffering handle1) - putBytes handle1 0xs67 - closeFile handle1 - check "file should be closed" (not (isFileOpen handle1)) - - -- make sure the bytes have been written - handle2 = openFile fooFile FileMode.Read - check "bytes have been written" (getBytes handle2 4 == 0xs01234567) - closeFile handle2 - - -- checking that ReadWrite mode works fine - handle3 = openFile fooFile FileMode.ReadWrite - check "bytes have been written" (getBytes handle3 4 == 0xs01234567) - closeFile handle3 - - check "file should be closed" (not (isFileOpen handle1)) - - runTest test -``` - -```ucm -.> add -.> io.test testOpenClose -``` - -### Reading files with getSomeBytes - -Tests: getSomeBytes - putBytes - isFileOpen - seekHandle - -```unison -testGetSomeBytes : '{io2.IO} [Result] -testGetSomeBytes _ = - test = 'let - tempDir = (newTempDir "getSomeBytes") - fooFile = tempDir ++ "/foo" - - testData = "0123456789" - testSize = size testData - - chunkSize = 7 - check "chunk size splits data into 2 uneven sides" ((chunkSize > (testSize / 2)) && (chunkSize < testSize)) - - - -- write testData to a temporary file - fooWrite = openFile fooFile Write - putBytes fooWrite (toUtf8 testData) - closeFile fooWrite - check "file should be closed" (not (isFileOpen fooWrite)) - - -- reopen for reading back the data in chunks - fooRead = openFile fooFile Read - - -- read first part of file - chunk1 = getSomeBytes fooRead chunkSize |> fromUtf8 - check "first chunk matches first part of testData" (chunk1 == take chunkSize testData) - - -- read rest of file - chunk2 = getSomeBytes fooRead chunkSize |> fromUtf8 - check "second chunk matches rest of testData" (chunk2 == drop chunkSize testData) - - check "should be at end of file" (isFileEOF fooRead) - - readAtEOF = getSomeBytes fooRead chunkSize - check "reading at end of file results in Bytes.empty" (readAtEOF == Bytes.empty) - - -- request many bytes from the start of the file - seekHandle fooRead AbsoluteSeek +0 - bigRead = getSomeBytes fooRead (testSize * 999) |> fromUtf8 - check "requesting many bytes results in what's available" (bigRead == testData) - - closeFile fooRead - check "file should be closed" (not (isFileOpen fooRead)) - - runTest test -``` - -```ucm -.> add -.> io.test testGetSomeBytes -``` - -### Seeking in open files - -Tests: openFile - putBytes - closeFile - isSeekable - isFileEOF - seekHandle - getBytes - getLine - -```unison -testSeek : '{io2.IO} [Result] -testSeek _ = - test = 'let - tempDir = newTempDir "seek" - emit (Ok "seeked") - fooFile = tempDir ++ "/foo" - handle1 = openFile fooFile FileMode.Append - putBytes handle1 (toUtf8 "12345678") - closeFile handle1 - - handle3 = openFile fooFile FileMode.Read - check "readable file should be seekable" (isSeekable handle3) - check "shouldn't be the EOF" (not (isFileEOF handle3)) - expectU "we should be at position 0" 0 (handlePosition handle3) - - seekHandle handle3 AbsoluteSeek +1 - expectU "we should be at position 1" 1 (handlePosition handle3) - bytes3a = getBytes handle3 1000 - text3a = Text.fromUtf8 bytes3a - expectU "should be able to read our temporary file after seeking" "2345678" text3a - closeFile handle3 - - barFile = tempDir ++ "/bar" - handle4 = openFile barFile FileMode.Append - putBytes handle4 (toUtf8 "foobar\n") - closeFile handle4 - - handle5 = openFile barFile FileMode.Read - expectU "getLine should get a line" "foobar" (getLine handle5) - closeFile handle5 - - runTest test - -testAppend : '{io2.IO} [Result] -testAppend _ = - test = 'let - tempDir = newTempDir "openFile" - fooFile = tempDir ++ "/foo" - handle1 = openFile fooFile FileMode.Write - putBytes handle1 (toUtf8 "test1") - closeFile handle1 - - handle2 = openFile fooFile FileMode.Append - putBytes handle2 (toUtf8 "test2") - closeFile handle2 - - handle3 = openFile fooFile FileMode.Read - bytes3 = getBytes handle3 1000 - text3 = Text.fromUtf8 bytes3 - - expectU "should be able to read our temporary file" "test1test2" text3 - - closeFile handle3 - - runTest test -``` - -```ucm -.> add -.> io.test testSeek -.> io.test testAppend -``` - -### SystemTime -```unison -testSystemTime : '{io2.IO} [Result] -testSystemTime _ = - test = 'let - t = !systemTime - check "systemTime should be sane" ((t > 1600000000) && (t < 2000000000)) - - runTest test -``` - -```ucm -.> add -.> io.test testSystemTime -``` - -### Get temp directory - -```unison:hide -testGetTempDirectory : '{io2.IO} [Result] -testGetTempDirectory _ = - test = 'let - tempDir = reraise !getTempDirectory.impl - check "Temp directory is directory" (isDirectory tempDir) - check "Temp directory should exist" (fileExists tempDir) - runTest test -``` - -```ucm -.> add -.> io.test testGetTempDirectory -``` - -### Get current directory - -```unison:hide -testGetCurrentDirectory : '{io2.IO} [Result] -testGetCurrentDirectory _ = - test = 'let - currentDir = reraise !getCurrentDirectory.impl - check "Current directory is directory" (isDirectory currentDir) - check "Current directory should exist" (fileExists currentDir) - runTest test -``` - -```ucm -.> add -.> io.test testGetCurrentDirectory -``` - -### Get directory contents - -```unison:hide -testDirContents : '{io2.IO} [Result] -testDirContents _ = - test = 'let - tempDir = newTempDir "dircontents" - c = reraise (directoryContents.impl tempDir) - check "directory size should be" (size c == 2) - check "directory contents should have current directory and parent" let - (c == [".", ".."]) || (c == ["..", "."]) - runTest test -``` - -```ucm -.> add -.> io.test testDirContents -``` - -### Read environment variables - -```unison:hide -testGetEnv : '{io2.IO} [Result] -testGetEnv _ = - test = 'let - path = reraise (getEnv.impl "PATH") -- PATH exists on windows, mac and linux. - check "PATH environent variable should be set" (size path > 0) - match getEnv.impl "DOESNTEXIST" with - Right _ -> emit (Fail "env var shouldn't exist") - Left _ -> emit (Ok "DOESNTEXIST didn't exist") - runTest test -``` -```ucm -.> add -.> io.test testGetEnv -``` - -### Read command line args - -`runMeWithNoArgs`, `runMeWithOneArg`, and `runMeWithTwoArgs` raise exceptions -unless they called with the right number of arguments. - -```unison:hide -testGetArgs.fail : Text -> Failure -testGetArgs.fail descr = Failure (typeLink IOFailure) descr !Any - -testGetArgs.runMeWithNoArgs : '{io2.IO, Exception} () -testGetArgs.runMeWithNoArgs = 'let - args = reraise !getArgs.impl - match args with - [] -> printLine "called with no args" - _ -> raise (fail "called with args") - -testGetArgs.runMeWithOneArg : '{io2.IO, Exception} () -testGetArgs.runMeWithOneArg = 'let - args = reraise !getArgs.impl - match args with - [] -> raise (fail "called with no args") - [_] -> printLine "called with one arg" - _ -> raise (fail "called with too many args") - -testGetArgs.runMeWithTwoArgs : '{io2.IO, Exception} () -testGetArgs.runMeWithTwoArgs = 'let - args = reraise !getArgs.impl - match args with - [] -> raise (fail "called with no args") - [_] -> raise (fail "called with one arg") - [_, _] -> printLine "called with two args" - _ -> raise (fail "called with too many args") -``` - -Test that they can be run with the right number of args. -```ucm -.> add -.> run runMeWithNoArgs -.> run runMeWithOneArg foo -.> run runMeWithTwoArgs foo bar -``` - -Calling our examples with the wrong number of args will error. - -```ucm:error -.> run runMeWithNoArgs foo -``` - -```ucm:error -.> run runMeWithOneArg -``` -```ucm:error -.> run runMeWithOneArg foo bar -``` - -```ucm:error -.> run runMeWithTwoArgs -``` - -### Get the time zone - -```unison:hide -testTimeZone = do - (offset, summer, name) = Clock.internals.systemTimeZone +0 - _ = (offset : Int, summer : Nat, name : Text) - () -``` - -```ucm -.> add -.> run testTimeZone -``` - -### Get some random bytes - -```unison:hide -testRandom : '{io2.IO} [Result] -testRandom = do - test = do - bytes = IO.randomBytes 10 - check "randomBytes returns the right number of bytes" (size bytes == 10) - runTest test -``` - -```ucm -.> add -.> io.test testGetEnv -``` diff --git a/unison-src/transcripts/io.output.md b/unison-src/transcripts/io.output.md deleted file mode 100644 index 3a7d44d4db..0000000000 --- a/unison-src/transcripts/io.output.md +++ /dev/null @@ -1,711 +0,0 @@ -# tests for built-in IO functions - -Tests for IO builtins which wired to foreign haskell calls. - -## Setup - -You can skip the section which is just needed to make the transcript self-contained. - -TempDirs/autoCleaned is an ability/hanlder which allows you to easily -create a scratch directory which will automatically get cleaned up. - -## Basic File Functions - -### Creating/Deleting/Renaming Directories - -Tests: createDirectory, - isDirectory, - fileExists, - renameDirectory, - deleteDirectory - -```unison -testCreateRename : '{io2.IO} [Result] -testCreateRename _ = - test = 'let - tempDir = newTempDir "fileio" - fooDir = tempDir ++ "/foo" - barDir = tempDir ++ "/bar" - void x = () - void (createDirectory.impl fooDir) - check "create a foo directory" (isDirectory fooDir) - check "directory should exist" (fileExists fooDir) - renameDirectory fooDir barDir - check "foo should no longer exist" (not (fileExists fooDir)) - check "directory should no longer exist" (not (fileExists fooDir)) - check "bar should now exist" (fileExists barDir) - - bazDir = barDir ++ "/baz" - void (createDirectory.impl bazDir) - void (removeDirectory.impl barDir) - - check "removeDirectory works recursively" (not (isDirectory barDir)) - check "removeDirectory works recursively" (not (isDirectory bazDir)) - - runTest test -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - testCreateRename : '{IO} [Result] - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - testCreateRename : '{IO} [Result] - -.> io.test testCreateRename - - New test results: - - ◉ testCreateRename create a foo directory - ◉ testCreateRename directory should exist - ◉ testCreateRename foo should no longer exist - ◉ testCreateRename directory should no longer exist - ◉ testCreateRename bar should now exist - ◉ testCreateRename removeDirectory works recursively - ◉ testCreateRename removeDirectory works recursively - - ✅ 7 test(s) passing - - Tip: Use view testCreateRename to view the source of a test. - -``` -### Opening / Closing files - -Tests: openFile - closeFile - isFileOpen - -```unison -testOpenClose : '{io2.IO} [Result] -testOpenClose _ = - test = 'let - tempDir = (newTempDir "seek") - fooFile = tempDir ++ "/foo" - handle1 = openFile fooFile FileMode.Write - check "file should be open" (isFileOpen handle1) - setBuffering handle1 (SizedBlockBuffering 1024) - check "file handle buffering should match what we just set." (getBuffering handle1 == SizedBlockBuffering 1024) - setBuffering handle1 (getBuffering handle1) - putBytes handle1 0xs01 - setBuffering handle1 NoBuffering - setBuffering handle1 (getBuffering handle1) - putBytes handle1 0xs23 - setBuffering handle1 BlockBuffering - setBuffering handle1 (getBuffering handle1) - putBytes handle1 0xs45 - setBuffering handle1 LineBuffering - setBuffering handle1 (getBuffering handle1) - putBytes handle1 0xs67 - closeFile handle1 - check "file should be closed" (not (isFileOpen handle1)) - - -- make sure the bytes have been written - handle2 = openFile fooFile FileMode.Read - check "bytes have been written" (getBytes handle2 4 == 0xs01234567) - closeFile handle2 - - -- checking that ReadWrite mode works fine - handle3 = openFile fooFile FileMode.ReadWrite - check "bytes have been written" (getBytes handle3 4 == 0xs01234567) - closeFile handle3 - - check "file should be closed" (not (isFileOpen handle1)) - - runTest test -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - testOpenClose : '{IO} [Result] - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - testOpenClose : '{IO} [Result] - -.> io.test testOpenClose - - New test results: - - ◉ testOpenClose file should be open - ◉ testOpenClose file handle buffering should match what we just set. - ◉ testOpenClose file should be closed - ◉ testOpenClose bytes have been written - ◉ testOpenClose bytes have been written - ◉ testOpenClose file should be closed - - ✅ 6 test(s) passing - - Tip: Use view testOpenClose to view the source of a test. - -``` -### Reading files with getSomeBytes - -Tests: getSomeBytes - putBytes - isFileOpen - seekHandle - -```unison -testGetSomeBytes : '{io2.IO} [Result] -testGetSomeBytes _ = - test = 'let - tempDir = (newTempDir "getSomeBytes") - fooFile = tempDir ++ "/foo" - - testData = "0123456789" - testSize = size testData - - chunkSize = 7 - check "chunk size splits data into 2 uneven sides" ((chunkSize > (testSize / 2)) && (chunkSize < testSize)) - - - -- write testData to a temporary file - fooWrite = openFile fooFile Write - putBytes fooWrite (toUtf8 testData) - closeFile fooWrite - check "file should be closed" (not (isFileOpen fooWrite)) - - -- reopen for reading back the data in chunks - fooRead = openFile fooFile Read - - -- read first part of file - chunk1 = getSomeBytes fooRead chunkSize |> fromUtf8 - check "first chunk matches first part of testData" (chunk1 == take chunkSize testData) - - -- read rest of file - chunk2 = getSomeBytes fooRead chunkSize |> fromUtf8 - check "second chunk matches rest of testData" (chunk2 == drop chunkSize testData) - - check "should be at end of file" (isFileEOF fooRead) - - readAtEOF = getSomeBytes fooRead chunkSize - check "reading at end of file results in Bytes.empty" (readAtEOF == Bytes.empty) - - -- request many bytes from the start of the file - seekHandle fooRead AbsoluteSeek +0 - bigRead = getSomeBytes fooRead (testSize * 999) |> fromUtf8 - check "requesting many bytes results in what's available" (bigRead == testData) - - closeFile fooRead - check "file should be closed" (not (isFileOpen fooRead)) - - runTest test -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - testGetSomeBytes : '{IO} [Result] - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - testGetSomeBytes : '{IO} [Result] - -.> io.test testGetSomeBytes - - New test results: - - ◉ testGetSomeBytes chunk size splits data into 2 uneven sides - ◉ testGetSomeBytes file should be closed - ◉ testGetSomeBytes first chunk matches first part of testData - ◉ testGetSomeBytes second chunk matches rest of testData - ◉ testGetSomeBytes should be at end of file - ◉ testGetSomeBytes reading at end of file results in Bytes.empty - ◉ testGetSomeBytes requesting many bytes results in what's available - ◉ testGetSomeBytes file should be closed - - ✅ 8 test(s) passing - - Tip: Use view testGetSomeBytes to view the source of a test. - -``` -### Seeking in open files - -Tests: openFile - putBytes - closeFile - isSeekable - isFileEOF - seekHandle - getBytes - getLine - -```unison -testSeek : '{io2.IO} [Result] -testSeek _ = - test = 'let - tempDir = newTempDir "seek" - emit (Ok "seeked") - fooFile = tempDir ++ "/foo" - handle1 = openFile fooFile FileMode.Append - putBytes handle1 (toUtf8 "12345678") - closeFile handle1 - - handle3 = openFile fooFile FileMode.Read - check "readable file should be seekable" (isSeekable handle3) - check "shouldn't be the EOF" (not (isFileEOF handle3)) - expectU "we should be at position 0" 0 (handlePosition handle3) - - seekHandle handle3 AbsoluteSeek +1 - expectU "we should be at position 1" 1 (handlePosition handle3) - bytes3a = getBytes handle3 1000 - text3a = Text.fromUtf8 bytes3a - expectU "should be able to read our temporary file after seeking" "2345678" text3a - closeFile handle3 - - barFile = tempDir ++ "/bar" - handle4 = openFile barFile FileMode.Append - putBytes handle4 (toUtf8 "foobar\n") - closeFile handle4 - - handle5 = openFile barFile FileMode.Read - expectU "getLine should get a line" "foobar" (getLine handle5) - closeFile handle5 - - runTest test - -testAppend : '{io2.IO} [Result] -testAppend _ = - test = 'let - tempDir = newTempDir "openFile" - fooFile = tempDir ++ "/foo" - handle1 = openFile fooFile FileMode.Write - putBytes handle1 (toUtf8 "test1") - closeFile handle1 - - handle2 = openFile fooFile FileMode.Append - putBytes handle2 (toUtf8 "test2") - closeFile handle2 - - handle3 = openFile fooFile FileMode.Read - bytes3 = getBytes handle3 1000 - text3 = Text.fromUtf8 bytes3 - - expectU "should be able to read our temporary file" "test1test2" text3 - - closeFile handle3 - - runTest test -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - testAppend : '{IO} [Result] - testSeek : '{IO} [Result] - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - testAppend : '{IO} [Result] - testSeek : '{IO} [Result] - -.> io.test testSeek - - New test results: - - ◉ testSeek seeked - ◉ testSeek readable file should be seekable - ◉ testSeek shouldn't be the EOF - ◉ testSeek we should be at position 0 - ◉ testSeek we should be at position 1 - ◉ testSeek should be able to read our temporary file after seeking - ◉ testSeek getLine should get a line - - ✅ 7 test(s) passing - - Tip: Use view testSeek to view the source of a test. - -.> io.test testAppend - - New test results: - - ◉ testAppend should be able to read our temporary file - - ✅ 1 test(s) passing - - Tip: Use view testAppend to view the source of a test. - -``` -### SystemTime -```unison -testSystemTime : '{io2.IO} [Result] -testSystemTime _ = - test = 'let - t = !systemTime - check "systemTime should be sane" ((t > 1600000000) && (t < 2000000000)) - - runTest test -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - testSystemTime : '{IO} [Result] - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - testSystemTime : '{IO} [Result] - -.> io.test testSystemTime - - New test results: - - ◉ testSystemTime systemTime should be sane - - ✅ 1 test(s) passing - - Tip: Use view testSystemTime to view the source of a test. - -``` -### Get temp directory - -```unison -testGetTempDirectory : '{io2.IO} [Result] -testGetTempDirectory _ = - test = 'let - tempDir = reraise !getTempDirectory.impl - check "Temp directory is directory" (isDirectory tempDir) - check "Temp directory should exist" (fileExists tempDir) - runTest test -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - testGetTempDirectory : '{IO} [Result] - -.> io.test testGetTempDirectory - - New test results: - - ◉ testGetTempDirectory Temp directory is directory - ◉ testGetTempDirectory Temp directory should exist - - ✅ 2 test(s) passing - - Tip: Use view testGetTempDirectory to view the source of a - test. - -``` -### Get current directory - -```unison -testGetCurrentDirectory : '{io2.IO} [Result] -testGetCurrentDirectory _ = - test = 'let - currentDir = reraise !getCurrentDirectory.impl - check "Current directory is directory" (isDirectory currentDir) - check "Current directory should exist" (fileExists currentDir) - runTest test -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - testGetCurrentDirectory : '{IO} [Result] - -.> io.test testGetCurrentDirectory - - New test results: - - ◉ testGetCurrentDirectory Current directory is directory - ◉ testGetCurrentDirectory Current directory should exist - - ✅ 2 test(s) passing - - Tip: Use view testGetCurrentDirectory to view the source of a - test. - -``` -### Get directory contents - -```unison -testDirContents : '{io2.IO} [Result] -testDirContents _ = - test = 'let - tempDir = newTempDir "dircontents" - c = reraise (directoryContents.impl tempDir) - check "directory size should be" (size c == 2) - check "directory contents should have current directory and parent" let - (c == [".", ".."]) || (c == ["..", "."]) - runTest test -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - testDirContents : '{IO} [Result] - -.> io.test testDirContents - - New test results: - - ◉ testDirContents directory size should be - ◉ testDirContents directory contents should have current directory and parent - - ✅ 2 test(s) passing - - Tip: Use view testDirContents to view the source of a test. - -``` -### Read environment variables - -```unison -testGetEnv : '{io2.IO} [Result] -testGetEnv _ = - test = 'let - path = reraise (getEnv.impl "PATH") -- PATH exists on windows, mac and linux. - check "PATH environent variable should be set" (size path > 0) - match getEnv.impl "DOESNTEXIST" with - Right _ -> emit (Fail "env var shouldn't exist") - Left _ -> emit (Ok "DOESNTEXIST didn't exist") - runTest test -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - testGetEnv : '{IO} [Result] - -.> io.test testGetEnv - - New test results: - - ◉ testGetEnv PATH environent variable should be set - ◉ testGetEnv DOESNTEXIST didn't exist - - ✅ 2 test(s) passing - - Tip: Use view testGetEnv to view the source of a test. - -``` -### Read command line args - -`runMeWithNoArgs`, `runMeWithOneArg`, and `runMeWithTwoArgs` raise exceptions -unless they called with the right number of arguments. - -```unison -testGetArgs.fail : Text -> Failure -testGetArgs.fail descr = Failure (typeLink IOFailure) descr !Any - -testGetArgs.runMeWithNoArgs : '{io2.IO, Exception} () -testGetArgs.runMeWithNoArgs = 'let - args = reraise !getArgs.impl - match args with - [] -> printLine "called with no args" - _ -> raise (fail "called with args") - -testGetArgs.runMeWithOneArg : '{io2.IO, Exception} () -testGetArgs.runMeWithOneArg = 'let - args = reraise !getArgs.impl - match args with - [] -> raise (fail "called with no args") - [_] -> printLine "called with one arg" - _ -> raise (fail "called with too many args") - -testGetArgs.runMeWithTwoArgs : '{io2.IO, Exception} () -testGetArgs.runMeWithTwoArgs = 'let - args = reraise !getArgs.impl - match args with - [] -> raise (fail "called with no args") - [_] -> raise (fail "called with one arg") - [_, _] -> printLine "called with two args" - _ -> raise (fail "called with too many args") -``` - -Test that they can be run with the right number of args. -```ucm -.> add - - ⍟ I've added these definitions: - - testGetArgs.fail : Text -> Failure - testGetArgs.runMeWithNoArgs : '{IO, Exception} () - testGetArgs.runMeWithOneArg : '{IO, Exception} () - testGetArgs.runMeWithTwoArgs : '{IO, Exception} () - -.> run runMeWithNoArgs - - () - -.> run runMeWithOneArg foo - - () - -.> run runMeWithTwoArgs foo bar - - () - -``` -Calling our examples with the wrong number of args will error. - -```ucm -.> run runMeWithNoArgs foo - - 💔💥 - - The program halted with an unhandled exception: - - Failure (typeLink IOFailure) "called with args" (Any ()) - - Stack trace: - ##raise - -``` -```ucm -.> run runMeWithOneArg - - 💔💥 - - The program halted with an unhandled exception: - - Failure (typeLink IOFailure) "called with no args" (Any ()) - - Stack trace: - ##raise - -``` -```ucm -.> run runMeWithOneArg foo bar - - 💔💥 - - The program halted with an unhandled exception: - - Failure - (typeLink IOFailure) "called with too many args" (Any ()) - - Stack trace: - ##raise - -``` -```ucm -.> run runMeWithTwoArgs - - 💔💥 - - The program halted with an unhandled exception: - - Failure (typeLink IOFailure) "called with no args" (Any ()) - - Stack trace: - ##raise - -``` -### Get the time zone - -```unison -testTimeZone = do - (offset, summer, name) = Clock.internals.systemTimeZone +0 - _ = (offset : Int, summer : Nat, name : Text) - () -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - testTimeZone : '{IO} () - -.> run testTimeZone - - () - -``` -### Get some random bytes - -```unison -testRandom : '{io2.IO} [Result] -testRandom = do - test = do - bytes = IO.randomBytes 10 - check "randomBytes returns the right number of bytes" (size bytes == 10) - runTest test -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - testRandom : '{IO} [Result] - -.> io.test testGetEnv - - New test results: - - ◉ testGetEnv PATH environent variable should be set - ◉ testGetEnv DOESNTEXIST didn't exist - - ✅ 2 test(s) passing - - Tip: Use view testGetEnv to view the source of a test. - -``` diff --git a/unison-src/transcripts/keyword-identifiers.output.md b/unison-src/transcripts/keyword-identifiers.output.md deleted file mode 100644 index 03ed3e919e..0000000000 --- a/unison-src/transcripts/keyword-identifiers.output.md +++ /dev/null @@ -1,272 +0,0 @@ -Regression tests to make sure keywords are allowed to start identifiers in terms and types. - -In particular, following a keyword with a `wordyIdChar` should be a valid identifier. - -Related issues: - -- https://github.com/unisonweb/unison/issues/2091 -- https://github.com/unisonweb/unison/issues/2727 - -## Keyword list - -Checks the following keywords: - -- `type` -- `ability` -- `structural` -- `unique` -- `if` -- `then` -- `else` -- `forall` -- `handle` -- `with` -- `where` -- `use` -- `true` -- `false` -- `alias` -- `typeLink` -- `termLink` -- `let` -- `namespace` -- `match` -- `cases` - -Note that although `∀` is a keyword, it cannot actually appear at the start of -identifier. - -## Tests - -`type`: - -```unison -typeFoo = 99 -type1 = "I am a variable" -type_ = 292 -type! = 3943 -type' = 238448 --- this type is the same as `structural type Optional a = Some a | None`, but with very confusing names -structural type type! type_ = type' type_ | type'' -``` - -`ability`: - -```unison -abilityFoo = 99 -ability1 = "I am a variable" -ability_ = 292 -ability! = 3943 -ability' = 238448 -structural type ability! ability_ = ability' ability_ | ability'' -``` - -`structural` - -```unison -structuralFoo = 99 -structural1 = "I am a variable" -structural_ = 292 -structural! = 3943 -structural' = 238448 -structural type structural! structural_ = structural' structural_ | structural'' -``` - -`unique` - -```unison -uniqueFoo = 99 -unique1 = "I am a variable" -unique_ = 292 -unique! = 3943 -unique' = 238448 -structural type unique! unique_ = unique' unique_ | unique'' -``` - -`if` - -```unison -ifFoo = 99 -if1 = "I am a variable" -if_ = 292 -if! = 3943 -if' = 238448 -structural type if! if_ = if' if_ | if'' -``` - -`then` - -```unison -thenFoo = 99 -then1 = "I am a variable" -then_ = 292 -then! = 3943 -then' = 238448 -structural type then! then_ = then' then_ | then'' -``` - -`else` - -```unison -elseFoo = 99 -else1 = "I am a variable" -else_ = 292 -else! = 3943 -else' = 238448 -structural type else! else_ = else' else_ | else'' -``` - -`forall` - -```unison -forallFoo = 99 -forall1 = "I am a variable" -forall_ = 292 -forall! = 3943 -forall' = 238448 -structural type forall! forall_ = forall' forall_ | forall'' -``` - -`handle` - -```unison -handleFoo = 99 -handle1 = "I am a variable" -handle_ = 292 -handle! = 3943 -handle' = 238448 -structural type handle! handle_ = handle' handle_ | handle'' -``` - -`with` - -```unison -withFoo = 99 -with1 = "I am a variable" -with_ = 292 -with! = 3943 -with' = 238448 -structural type with! with_ = with' with_ | with'' -``` - -`where` - -```unison -whereFoo = 99 -where1 = "I am a variable" -where_ = 292 -where! = 3943 -where' = 238448 -structural type where! where_ = where' where_ | where'' -``` - -`use` - -```unison -useFoo = 99 -use1 = "I am a variable" -use_ = 292 -use! = 3943 -use' = 238448 -structural type use! use_ = use' use_ | use'' -``` - -`true` - -```unison -trueFoo = 99 -true1 = "I am a variable" -true_ = 292 -true! = 3943 -true' = 238448 -structural type true! true_ = true' true_ | true'' -``` - -`false` - -```unison -falseFoo = 99 -false1 = "I am a variable" -false_ = 292 -false! = 3943 -false' = 238448 -structural type false! false_ = false' false_ | false'' -``` - -`alias` - -```unison -aliasFoo = 99 -alias1 = "I am a variable" -alias_ = 292 -alias! = 3943 -alias' = 238448 -structural type alias! alias_ = alias' alias_ | alias'' -``` - -`typeLink` - -```unison -typeLinkFoo = 99 -typeLink1 = "I am a variable" -typeLink_ = 292 -typeLink! = 3943 -typeLink' = 238448 -structural type typeLink! typeLink_ = typeLink' typeLink_ | typeLink'' -``` - -`termLink` - -```unison -termLinkFoo = 99 -termLink1 = "I am a variable" -termLink_ = 292 -termLink! = 3943 -termLink' = 238448 -structural type termLink! termLink_ = termLink' termLink_ | termLink'' -``` - -`let` - -```unison -letFoo = 99 -let1 = "I am a variable" -let_ = 292 -let! = 3943 -let' = 238448 -structural type let! let_ = let' let_ | let'' -``` - -`namespace` - -```unison -namespaceFoo = 99 -namespace1 = "I am a variable" -namespace_ = 292 -namespace! = 3943 -namespace' = 238448 -structural type namespace! namespace_ = namespace' namespace_ | namespace'' -``` - -`match` - -```unison -matchFoo = 99 -match1 = "I am a variable" -match_ = 292 -match! = 3943 -match' = 238448 -structural type match! match_ = match' match_ | match'' -``` - -`cases` - -```unison -casesFoo = 99 -cases1 = "I am a variable" -cases_ = 292 -cases! = 3943 -cases' = 238448 -structural type cases! cases_ = cases' cases_ | cases'' -``` - diff --git a/unison-src/transcripts/kind-inference.md b/unison-src/transcripts/kind-inference.md deleted file mode 100644 index f81a3bf95c..0000000000 --- a/unison-src/transcripts/kind-inference.md +++ /dev/null @@ -1,137 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -## A type param cannot have conflicting kind constraints within a single decl - -conflicting constraints on the kind of `a` in a product -```unison:error -unique type T a = T a (a Nat) -``` - -conflicting constraints on the kind of `a` in a sum -```unison:error -unique type T a - = Star a - | StarStar (a Nat) -``` - -## Kinds are inferred by decl component - -Successfully infer `a` in `Ping a` to be of kind `* -> *` by -inspecting its component-mate `Pong`. -```unison -unique type Ping a = Ping Pong -unique type Pong = Pong (Ping Optional) -``` - -Catch the conflict on the kind of `a` in `Ping a`. `Ping` restricts -`a` to `*`, whereas `Pong` restricts `a` to `* -> *`. -```unison:error -unique type Ping a = Ping a Pong -unique type Pong = Pong (Ping Optional) -``` - -Successful example between mutually recursive type and ability -```unison -unique type Ping a = Ping (a Nat -> {Pong Nat} ()) -unique ability Pong a where - pong : Ping Optional -> () -``` - -Catch conflict between mutually recursive type and ability -```unison:error -unique type Ping a = Ping (a -> {Pong Nat} ()) -unique ability Pong a where - pong : Ping Optional -> () -``` - -Consistent instantiation of `T`'s `a` parameter in `S` -```unison -unique type T a = T a - -unique type S = S (T Nat) -``` - -Delay kind defaulting until all components are processed. Here `S` -constrains the kind of `T`'s `a` parameter, although `S` is not in -the same component as `T`. -```unison -unique type T a = T - -unique type S = S (T Optional) -``` - -Catch invalid instantiation of `T`'s `a` parameter in `S` -```unison:error -unique type T a = T a - -unique type S = S (T Optional) -``` - -## Checking annotations - -Catch kind error in type annotation -```unison:error -test : Nat Nat -test = 0 -``` - -Catch kind error in annotation example 2 -```unison:error -test : Optional -> () -test _ = () -``` - -Catch kind error in annotation example 3 -```unison:error -unique type T a = T (a Nat) - -test : T Nat -> () -test _ = () -``` - -Catch kind error in scoped type variable annotation -```unison:error -unique type StarStar a = StarStar (a Nat) -unique type Star a = Star a - -test : StarStar a -> () -test _ = - buggo : Star a - buggo = bug "" - () -``` - -## Effect/type mismatch - -Effects appearing where types are expected -```unison:error -unique ability Foo where - foo : () - -test : Foo -> () -test _ = () -``` - -Types appearing where effects are expected -```unison:error -test : {Nat} () -test _ = () -``` - -## Cyclic kinds - -```unison:error -unique type T a = T (a a) -``` - -```unison:error -unique type T a b = T (a b) (b a) -``` - -```unison:error -unique type Ping a = Ping (a Pong) -unique type Pong a = Pong (a Ping) -``` diff --git a/unison-src/transcripts/kind-inference.output.md b/unison-src/transcripts/kind-inference.output.md deleted file mode 100644 index 73fb41d2d1..0000000000 --- a/unison-src/transcripts/kind-inference.output.md +++ /dev/null @@ -1,347 +0,0 @@ - -## A type param cannot have conflicting kind constraints within a single decl - -conflicting constraints on the kind of `a` in a product -```unison -unique type T a = T a (a Nat) -``` - -```ucm - - Loading changes detected in scratch.u. - - Kind mismatch arising from - 1 | unique type T a = T a (a Nat) - - a doesn't expect an argument; however, it is applied to Nat. - -``` -conflicting constraints on the kind of `a` in a sum -```unison -unique type T a - = Star a - | StarStar (a Nat) -``` - -```ucm - - Loading changes detected in scratch.u. - - Kind mismatch arising from - 3 | | StarStar (a Nat) - - a doesn't expect an argument; however, it is applied to Nat. - -``` -## Kinds are inferred by decl component - -Successfully infer `a` in `Ping a` to be of kind `* -> *` by -inspecting its component-mate `Pong`. -```unison -unique type Ping a = Ping Pong -unique type Pong = Pong (Ping Optional) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Ping a - type Pong - -``` -Catch the conflict on the kind of `a` in `Ping a`. `Ping` restricts -`a` to `*`, whereas `Pong` restricts `a` to `* -> *`. -```unison -unique type Ping a = Ping a Pong -unique type Pong = Pong (Ping Optional) -``` - -```ucm - - Loading changes detected in scratch.u. - - Kind mismatch arising from - 1 | unique type Ping a = Ping a Pong - - The arrow type (->) expects arguments of kind Type; however, - it is applied to a which has kind: Type -> Type. - -``` -Successful example between mutually recursive type and ability -```unison -unique type Ping a = Ping (a Nat -> {Pong Nat} ()) -unique ability Pong a where - pong : Ping Optional -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Ping a - ability Pong a - -``` -Catch conflict between mutually recursive type and ability -```unison -unique type Ping a = Ping (a -> {Pong Nat} ()) -unique ability Pong a where - pong : Ping Optional -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Kind mismatch arising from - 3 | pong : Ping Optional -> () - - Ping expects an argument of kind: Type; however, it is - applied to Optional which has kind: Type -> Type. - -``` -Consistent instantiation of `T`'s `a` parameter in `S` -```unison -unique type T a = T a - -unique type S = S (T Nat) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type S - type T a - -``` -Delay kind defaulting until all components are processed. Here `S` -constrains the kind of `T`'s `a` parameter, although `S` is not in -the same component as `T`. -```unison -unique type T a = T - -unique type S = S (T Optional) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type S - type T a - -``` -Catch invalid instantiation of `T`'s `a` parameter in `S` -```unison -unique type T a = T a - -unique type S = S (T Optional) -``` - -```ucm - - Loading changes detected in scratch.u. - - Kind mismatch arising from - 3 | unique type S = S (T Optional) - - T expects an argument of kind: Type; however, it is applied - to Optional which has kind: Type -> Type. - -``` -## Checking annotations - -Catch kind error in type annotation -```unison -test : Nat Nat -test = 0 -``` - -```ucm - - Loading changes detected in scratch.u. - - Kind mismatch arising from - 1 | test : Nat Nat - - Nat doesn't expect an argument; however, it is applied to - Nat. - -``` -Catch kind error in annotation example 2 -```unison -test : Optional -> () -test _ = () -``` - -```ucm - - Loading changes detected in scratch.u. - - Kind mismatch arising from - 1 | test : Optional -> () - - The arrow type (->) expects arguments of kind Type; however, - it is applied to Optional which has kind: Type -> Type. - -``` -Catch kind error in annotation example 3 -```unison -unique type T a = T (a Nat) - -test : T Nat -> () -test _ = () -``` - -```ucm - - Loading changes detected in scratch.u. - - Kind mismatch arising from - 3 | test : T Nat -> () - - T expects an argument of kind: Type -> Type; however, it is - applied to Nat which has kind: Type. - -``` -Catch kind error in scoped type variable annotation -```unison -unique type StarStar a = StarStar (a Nat) -unique type Star a = Star a - -test : StarStar a -> () -test _ = - buggo : Star a - buggo = bug "" - () -``` - -```ucm - - Loading changes detected in scratch.u. - - Kind mismatch arising from - 6 | buggo : Star a - - Star expects an argument of kind: Type; however, it is - applied to a which has kind: Type -> Type. - -``` -## Effect/type mismatch - -Effects appearing where types are expected -```unison -unique ability Foo where - foo : () - -test : Foo -> () -test _ = () -``` - -```ucm - - Loading changes detected in scratch.u. - - Kind mismatch arising from - 4 | test : Foo -> () - - The arrow type (->) expects arguments of kind Type; however, - it is applied to Foo which has kind: Ability. - -``` -Types appearing where effects are expected -```unison -test : {Nat} () -test _ = () -``` - -```ucm - - Loading changes detected in scratch.u. - - Kind mismatch arising from - 1 | test : {Nat} () - - An ability list must consist solely of abilities; however, - this list contains Nat which has kind Type. Abilities are of - kind Ability. - -``` -## Cyclic kinds - -```unison -unique type T a = T (a a) -``` - -```ucm - - Loading changes detected in scratch.u. - - Cannot construct infinite kind - 1 | unique type T a = T (a a) - - The above application constrains the kind of a to be - infinite, generated by the constraint k = k -> Type where k - is the kind of a. - -``` -```unison -unique type T a b = T (a b) (b a) -``` - -```ucm - - Loading changes detected in scratch.u. - - Cannot construct infinite kind - 1 | unique type T a b = T (a b) (b a) - - The above application constrains the kind of b to be - infinite, generated by the constraint - k = (k -> Type) -> Type where k is the kind of b. - -``` -```unison -unique type Ping a = Ping (a Pong) -unique type Pong a = Pong (a Ping) -``` - -```ucm - - Loading changes detected in scratch.u. - - Cannot construct infinite kind - 1 | unique type Ping a = Ping (a Pong) - - The above application constrains the kind of a to be - infinite, generated by the constraint - k = (((k -> Type) -> Type) -> Type) -> Type where k is the - kind of a. - -``` diff --git a/unison-src/transcripts/lambdacase.md b/unison-src/transcripts/lambdacase.md deleted file mode 100644 index e2e3a557ef..0000000000 --- a/unison-src/transcripts/lambdacase.md +++ /dev/null @@ -1,119 +0,0 @@ -# Lambda case syntax - -```ucm:hide -.> builtins.merge -``` - -This function takes a single argument and immediately pattern matches on it. As we'll see below, it can be written using `cases` syntax: - -```unison -isEmpty x = match x with - [] -> true - _ -> false -``` - -```ucm:hide -.> add -``` - -Here's the same function written using `cases` syntax: - -```unison -isEmpty2 = cases - [] -> true - _ -> false -``` - -Notice that Unison detects this as an alias of `isEmpty`, and if we view `isEmpty` - -```ucm -.> view isEmpty -``` - -it shows the definition using `cases` syntax opportunistically, even though the code was originally written without that syntax. - -## Multi-argument cases - -Functions that take multiple arguments and immediately match on a tuple of arguments can also be rewritten to use `cases`. Here's a version using regular `match` syntax on a tuple: - -```unison:hide -merge : [a] -> [a] -> [a] -merge xs ys = match (xs, ys) with - ([], ys) -> ys - (xs, []) -> xs - (h +: t, h2 +: t2) -> - if h <= h2 then h +: merge t (h2 +: t2) - else h2 +: merge (h +: t) t2 -``` - -```ucm -.> add -``` - -And here's a version using `cases`. The patterns are separated by commas: - -```unison -merge2 : [a] -> [a] -> [a] -merge2 = cases - [], ys -> ys - xs, [] -> xs - h +: t, h2 +: t2 -> - if h <= h2 then h +: merge2 t (h2 +: t2) - else h2 +: merge2 (h +: t) t2 -``` - -Notice that Unison detects this as an alias of `merge`, and if we view `merge` - -```ucm -.> view merge -``` - -it again shows the definition using the multi-argument `cases` syntax opportunistically, even though the code was originally written without that syntax. - -Here's another example: - -```unison -structural type B = T | F - -blah : B -> B -> Text -blah = cases - T, x -> "hi" - x, y -> "bye" - -blorf = cases - x, T -> x - x, y -> y - -> blah T F -> blah F F -> blorf T F -``` - -## Patterns with multiple guards - -```unison -merge3 : [a] -> [a] -> [a] -merge3 = cases - [], ys -> ys - xs, [] -> xs - h +: t, h2 +: t2 | h <= h2 -> h +: merge3 t (h2 +: t2) - | otherwise -> h2 +: merge3 (h +: t) t2 -``` - -```ucm -.> add -.> view merge3 -``` - -This is the same definition written with multiple patterns and not using the `cases` syntax; notice it is considered an alias of `merge3` above. - -```unison -merge4 : [a] -> [a] -> [a] -merge4 a b = match (a,b) with - [], ys -> ys - xs, [] -> xs - h +: t, h2 +: t2 | h <= h2 -> h +: merge4 t (h2 +: t2) - h +: t, h2 +: t2 | otherwise -> h2 +: merge4 (h +: t) t2 -``` - - diff --git a/unison-src/transcripts/lambdacase.output.md b/unison-src/transcripts/lambdacase.output.md deleted file mode 100644 index efb41cdce8..0000000000 --- a/unison-src/transcripts/lambdacase.output.md +++ /dev/null @@ -1,238 +0,0 @@ -# Lambda case syntax - -This function takes a single argument and immediately pattern matches on it. As we'll see below, it can be written using `cases` syntax: - -```unison -isEmpty x = match x with - [] -> true - _ -> false -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - isEmpty : [t] -> Boolean - -``` -Here's the same function written using `cases` syntax: - -```unison -isEmpty2 = cases - [] -> true - _ -> false -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - isEmpty2 : [t] -> Boolean - (also named isEmpty) - -``` -Notice that Unison detects this as an alias of `isEmpty`, and if we view `isEmpty` - -```ucm -.> view isEmpty - - isEmpty : [t] -> Boolean - isEmpty = cases - [] -> true - _ -> false - -``` -it shows the definition using `cases` syntax opportunistically, even though the code was originally written without that syntax. - -## Multi-argument cases - -Functions that take multiple arguments and immediately match on a tuple of arguments can also be rewritten to use `cases`. Here's a version using regular `match` syntax on a tuple: - -```unison -merge : [a] -> [a] -> [a] -merge xs ys = match (xs, ys) with - ([], ys) -> ys - (xs, []) -> xs - (h +: t, h2 +: t2) -> - if h <= h2 then h +: merge t (h2 +: t2) - else h2 +: merge (h +: t) t2 -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - merge : [a] -> [a] -> [a] - -``` -And here's a version using `cases`. The patterns are separated by commas: - -```unison -merge2 : [a] -> [a] -> [a] -merge2 = cases - [], ys -> ys - xs, [] -> xs - h +: t, h2 +: t2 -> - if h <= h2 then h +: merge2 t (h2 +: t2) - else h2 +: merge2 (h +: t) t2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - merge2 : [a] -> [a] -> [a] - (also named merge) - -``` -Notice that Unison detects this as an alias of `merge`, and if we view `merge` - -```ucm -.> view merge - - merge : [a] -> [a] -> [a] - merge = cases - [], ys -> ys - xs, [] -> xs - h +: t, h2 +: t2 -> - if h <= h2 then h +: merge t (h2 +: t2) - else h2 +: merge (h +: t) t2 - -``` -it again shows the definition using the multi-argument `cases` syntax opportunistically, even though the code was originally written without that syntax. - -Here's another example: - -```unison -structural type B = T | F - -blah : B -> B -> Text -blah = cases - T, x -> "hi" - x, y -> "bye" - -blorf = cases - x, T -> x - x, y -> y - -> blah T F -> blah F F -> blorf T F -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type B - blah : B -> B -> Text - blorf : B -> B -> B - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 12 | > blah T F - ⧩ - "hi" - - 13 | > blah F F - ⧩ - "bye" - - 14 | > blorf T F - ⧩ - F - -``` -## Patterns with multiple guards - -```unison -merge3 : [a] -> [a] -> [a] -merge3 = cases - [], ys -> ys - xs, [] -> xs - h +: t, h2 +: t2 | h <= h2 -> h +: merge3 t (h2 +: t2) - | otherwise -> h2 +: merge3 (h +: t) t2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - merge3 : [a] -> [a] -> [a] - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - merge3 : [a] -> [a] -> [a] - -.> view merge3 - - merge3 : [a] -> [a] -> [a] - merge3 = cases - [], ys -> ys - xs, [] -> xs - h +: t, h2 +: t2 - | h <= h2 -> h +: merge3 t (h2 +: t2) - | otherwise -> h2 +: merge3 (h +: t) t2 - -``` -This is the same definition written with multiple patterns and not using the `cases` syntax; notice it is considered an alias of `merge3` above. - -```unison -merge4 : [a] -> [a] -> [a] -merge4 a b = match (a,b) with - [], ys -> ys - xs, [] -> xs - h +: t, h2 +: t2 | h <= h2 -> h +: merge4 t (h2 +: t2) - h +: t, h2 +: t2 | otherwise -> h2 +: merge4 (h +: t) t2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - merge4 : [a] -> [a] -> [a] - (also named merge3) - -``` diff --git a/unison-src/transcripts/ls-pretty-print-scope-bug.md b/unison-src/transcripts/ls-pretty-print-scope-bug.md deleted file mode 100644 index a8d4cf5ed4..0000000000 --- a/unison-src/transcripts/ls-pretty-print-scope-bug.md +++ /dev/null @@ -1,44 +0,0 @@ -```unison -unique type Foo = Foo -``` - -```ucm -.a.b> add -.> fork .a.b .c.d.f -.c.g.f> -``` - -```unison -unique type Foo = Foo -``` - -```ucm -.c.g.f> add -.c> -``` - -```unison -foo = .d.f.Foo.Foo -``` - -```ucm -.c> add -``` - -At this point we have: -`.a.b.Foo` -`.c.d.f.Foo` which is equal to `.a.b.Foo` -`.c.g.f.Foo` which is distinct from the other `Foo` types - -```ucm -.> delete .c.d.f.Foo -``` -Once `.c.d.f.Foo` is deleted `.c.foo` should have the type `.a.b.Foo` -when viewed from `.>`, but an unnamed type when viewed from `.c>`, -since referencing `.a.b.Foo` would reference names outside of the -namespace rooted at `.c`. - -```ucm -.> ls c -.c> ls -``` diff --git a/unison-src/transcripts/ls-pretty-print-scope-bug.output.md b/unison-src/transcripts/ls-pretty-print-scope-bug.output.md deleted file mode 100644 index 567a176b64..0000000000 --- a/unison-src/transcripts/ls-pretty-print-scope-bug.output.md +++ /dev/null @@ -1,113 +0,0 @@ -```unison -unique type Foo = Foo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - -``` -```ucm - ☝️ The namespace .a.b is empty. - -.a.b> add - - ⍟ I've added these definitions: - - type Foo - -.> fork .a.b .c.d.f - - Done. - - ☝️ The namespace .c.g.f is empty. - -``` -```unison -unique type Foo = Foo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - -``` -```ucm -.c.g.f> add - - ⍟ I've added these definitions: - - type Foo - -``` -```unison -foo = .d.f.Foo.Foo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo : d.f.Foo - -``` -```ucm -.c> add - - ⍟ I've added these definitions: - - foo : d.f.Foo - -``` -At this point we have: -`.a.b.Foo` -`.c.d.f.Foo` which is equal to `.a.b.Foo` -`.c.g.f.Foo` which is distinct from the other `Foo` types - -```ucm -.> delete .c.d.f.Foo - - Done. - -``` -Once `.c.d.f.Foo` is deleted `.c.foo` should have the type `.a.b.Foo` -when viewed from `.>`, but an unnamed type when viewed from `.c>`, -since referencing `.a.b.Foo` would reference names outside of the -namespace rooted at `.c`. - -```ucm -.> ls c - - 1. d/ (1 term) - 2. foo (b.Foo) - 3. g/ (1 term, 1 type) - -.c> ls - - 1. d/ (1 term) - 2. foo (#uj8oalgadr) - 3. g/ (1 term, 1 type) - -``` diff --git a/unison-src/transcripts/lsp-fold-ranges.md b/unison-src/transcripts/lsp-fold-ranges.md deleted file mode 100644 index 377c9170dd..0000000000 --- a/unison-src/transcripts/lsp-fold-ranges.md +++ /dev/null @@ -1,33 +0,0 @@ -```ucm:hide -.> builtins.mergeio -``` - -```unison:hide - -{{ Type doc }} -structural type Optional a = - None - | Some a - -{{ - Multi line - - Term doc -}} -List.map : - (a -> b) - -> [a] - -> [b] -List.map f = cases - (x +: xs) -> f x +: List.map f xs - [] -> [] - -test> z = let - x = "hello" - y = "world" - [Ok (x ++ y)] -``` - -```ucm -.> debug.lsp.fold-ranges -``` diff --git a/unison-src/transcripts/lsp-fold-ranges.output.md b/unison-src/transcripts/lsp-fold-ranges.output.md deleted file mode 100644 index 51f8b4ae9e..0000000000 --- a/unison-src/transcripts/lsp-fold-ranges.output.md +++ /dev/null @@ -1,52 +0,0 @@ -```unison -{{ Type doc }} -structural type Optional a = - None - | Some a - -{{ - Multi line - - Term doc -}} -List.map : - (a -> b) - -> [a] - -> [b] -List.map f = cases - (x +: xs) -> f x +: List.map f xs - [] -> [] - -test> z = let - x = "hello" - y = "world" - [Ok (x ++ y)] -``` - -```ucm -.> debug.lsp.fold-ranges - - 《{{ Type doc }}》 - 《structural type Optional a = - None - | Some a》 - - 《{{ - Multi line - - Term doc - }}》 - 《List.map : - (a -> b) - -> [a] - -> [b] - List.map f = cases - (x +: xs) -> f x +: List.map f xs - [] -> []》 - - 《test> z = let - x = "hello" - y = "world" - [Ok (x ++ y)]》 - -``` diff --git a/unison-src/transcripts/merge.md b/unison-src/transcripts/merge.md index 9808153561..7bbbd16cf6 100644 --- a/unison-src/transcripts/merge.md +++ b/unison-src/transcripts/merge.md @@ -3,9 +3,9 @@ The `merge` command merges together two branches in the same project: the current branch (unspecificed), and the target branch. For example, to merge `topic` into `main`, switch to `main` and run `merge topic`: -```ucm:error -.> help merge -.> help merge.commit +``` ucm +scratch/main> help merge +scratch/main> help merge.commit ``` Let's see a simple unconflicted merge in action: Alice (us) and Bob (them) add different terms. The merged result @@ -13,136 +13,136 @@ contains both additions. ## Basic merge: two unconflicted adds -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` -```ucm:hide -project/main> branch alice +``` ucm :hide +scratch/main> branch alice ``` Alice's adds: -```unison:hide +``` unison :hide foo : Text foo = "alices foo" ``` -```ucm:hide -project/alice> add -project/main> branch bob +``` ucm :hide +scratch/alice> add +scratch/main> branch bob ``` Bob's adds: -```unison:hide +``` unison :hide bar : Text bar = "bobs bar" ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` Merge result: -```ucm -project/alice> merge /bob -project/alice> view foo bar +``` ucm +scratch/alice> merge /bob +scratch/alice> view foo bar ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Basic merge: two identical adds If Alice and Bob also happen to add the same definition, that's not a conflict. -```ucm:hide -project/main> builtins.mergeio -project/main> branch alice +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +scratch/main> branch alice ``` Alice's adds: -```unison:hide +``` unison :hide foo : Text foo = "alice and bobs foo" ``` -```ucm:hide -project/alice> add -project/main> branch bob +``` ucm :hide +scratch/alice> add +scratch/main> branch bob ``` Bob's adds: -```unison:hide +``` unison :hide foo : Text foo = "alice and bobs foo" bar : Text bar = "bobs bar" ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` Merge result: -```ucm -project/alice> merge /bob -project/alice> view foo bar +``` ucm +scratch/alice> merge /bob +scratch/alice> view foo bar ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Simple update propagation Updates that occur in one branch are propagated to the other. In this example, Alice updates `foo`, while Bob adds a new dependent `bar` of the original `foo`. When Bob's branch is merged into Alice's, her update to `foo` is propagated to his `bar`. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide foo : Text foo = "old foo" ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice's updates: -```unison:hide +``` unison :hide foo : Text foo = "new foo" ``` -```ucm:hide -project/alice> update -project/main> branch bob +``` ucm :hide +scratch/alice> update +scratch/main> branch bob ``` Bob's adds: -```unison:hide +``` unison :hide bar : Text bar = foo ++ " - " ++ foo ``` -```ucm -project/bob> display bar +``` ucm +scratch/bob> display bar ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` Merge result: -```ucm -project/alice> merge /bob -project/alice> view foo bar -project/alice> display bar +``` ucm +scratch/alice> merge /bob +scratch/alice> view foo bar +scratch/alice> display bar ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Update propagation with common dependent @@ -151,12 +151,12 @@ We classify something as an update if its "syntactic hash"—not its normal Unis Let's see an example. We have `foo`, which depends on `bar` and `baz`. Alice updates `bar` (propagating to `foo`), and Bob updates `baz` (propagating to `foo`). When we merge their updates, both updates will be reflected in the final `foo`. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide foo : Text foo = "foo" ++ " - " ++ bar ++ " - " ++ baz @@ -167,60 +167,60 @@ baz : Text baz = "old baz" ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice's updates: -```unison:hide +``` unison :hide bar : Text bar = "alices bar" ``` -```ucm:hide -project/alice> update +``` ucm :hide +scratch/alice> update ``` -```ucm -project/alice> display foo +``` ucm +scratch/alice> display foo ``` -```ucm:hide -project/main> branch bob +``` ucm :hide +scratch/main> branch bob ``` Bob's updates: -```unison:hide +``` unison :hide baz : Text baz = "bobs baz" ``` -```ucm:hide -project/bob> update +``` ucm :hide +scratch/bob> update ``` -```ucm -project/bob> display foo +``` ucm +scratch/bob> display foo ``` Merge result: -```ucm -project/alice> merge /bob -project/alice> view foo bar baz -project/alice> display foo +``` ucm +scratch/alice> merge /bob +scratch/alice> view foo bar baz +scratch/alice> display foo ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Propagating an update to an update Of course, it's also possible for Alice's update to propagate to one of Bob's updates. In this example, `foo` depends on `bar` which depends on `baz`. Alice updates `baz`, propagating to `bar` and `foo`, while Bob updates `bar` (to something that still depends on `foo`), propagating to `baz`. The merged result will have Alice's update to `foo` incorporated into Bob's updated `bar`, and both updates will propagate to `baz`. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide foo : Text foo = "old foo" ++ " - " ++ bar @@ -231,99 +231,99 @@ baz : Text baz = "old baz" ``` -```ucm:hide -project/main> add +``` ucm :hide +scratch/main> add ``` -```ucm -project/main> display foo +``` ucm +scratch/main> display foo ``` -```ucm:hide -project/main> branch alice +``` ucm :hide +scratch/main> branch alice ``` Alice's updates: -```unison:hide +``` unison :hide baz : Text baz = "alices baz" ``` -```ucm:hide -project/alice> update +``` ucm :hide +scratch/alice> update ``` -```ucm -project/alice> display foo +``` ucm +scratch/alice> display foo ``` -```ucm:hide -project/main> branch bob +``` ucm :hide +scratch/main> branch bob ``` Bob's updates: -```unison:hide +``` unison :hide bar : Text bar = "bobs bar" ++ " - " ++ baz ``` -```ucm:hide -project/bob> update +``` ucm :hide +scratch/bob> update ``` -```ucm -project/bob> display foo +``` ucm +scratch/bob> display foo ``` Merge result: -```ucm -project/alice> merge /bob -project/alice> view foo bar baz -project/alice> display foo +``` ucm +scratch/alice> merge /bob +scratch/alice> view foo bar baz +scratch/alice> display foo ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Update + delete isn't (currently) a conflict We don't currently consider "update + delete" a conflict like Git does. In this situation, the delete is just ignored, allowing the update to proceed. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide foo : Text foo = "old foo" ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice's updates: -```unison:hide +``` unison :hide foo : Text foo = "alices foo" ``` -```ucm:hide -project/alice> update -project/main> branch bob +``` ucm :hide +scratch/alice> update +scratch/main> branch bob ``` Bob's changes: -```ucm -project/bob> delete.term foo +``` ucm +scratch/bob> delete.term foo ``` Merge result: -```ucm -project/alice> merge /bob -project/alice> view foo +``` ucm +scratch/alice> merge /bob +scratch/alice> view foo ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` In a future version, we'd like to give the user a warning at least. @@ -332,16 +332,16 @@ In a future version, we'd like to give the user a warning at least. Library dependencies don't cause merge conflicts, the library dependencies are just unioned together. If two library dependencies have the same name but different namespace hashes, then the merge algorithm makes up two fresh names. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Alice's adds: -```ucm:hide -project/main> branch alice +``` ucm :hide +scratch/main> branch alice ``` -```unison:hide +``` unison :hide lib.alice.foo : Nat lib.alice.foo = 17 @@ -352,13 +352,13 @@ lib.bothDifferent.baz : Nat lib.bothDifferent.baz = 19 ``` -```ucm:hide -project/alice> add -project/main> branch bob +``` ucm :hide +scratch/alice> add +scratch/main> branch bob ``` Bob's adds: -```unison:hide +``` unison :hide lib.bob.foo : Nat lib.bob.foo = 20 @@ -369,91 +369,102 @@ lib.bothDifferent.baz : Nat lib.bothDifferent.baz = 21 ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` Merge result: -```ucm -project/alice> merge bob -project/alice> view foo bar baz +``` ucm +scratch/alice> merge bob +scratch/alice> view foo bar baz ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## No-op merge (Bob = Alice) If Bob is equals Alice, then merging Bob into Alice looks like this. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` -```ucm -project/main> branch alice -project/main> branch bob -project/alice> merge /bob +``` ucm +scratch/main> branch alice +scratch/main> branch bob +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## No-op merge (Bob < Alice) If Bob is behind Alice, then merging Bob into Alice looks like this. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` -```ucm -project/main> branch alice -project/main> branch bob +``` ucm +scratch/main> branch alice +scratch/main> branch bob ``` Alice's addition: -```unison:hide +``` unison :hide foo : Text foo = "foo" ``` -```ucm -project/alice> add -project/alice> merge /bob +``` ucm +scratch/alice> add +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Fast-forward merge (Bob > Alice) If Bob is ahead of Alice, then merging Bob into Alice looks like this. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` -```ucm -project/main> branch alice -project/main> branch bob +``` ucm +scratch/main> branch alice +scratch/main> branch bob ``` Bob's addition: -```unison:hide +``` unison :hide foo : Text foo = "foo" ``` -```ucm -project/bob> add -project/alice> merge /bob +``` ucm +scratch/bob> add +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch +``` + +## No-op merge: merge empty namespace into empty namespace + +``` ucm +scratch/main> branch topic +scratch/main> merge /topic +``` + +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: someone deleted something @@ -464,41 +475,41 @@ This can cause merge failures due to out-of-scope identifiers, and the user may In this example, Alice deletes `foo`, while Bob adds a new dependent of `foo`. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide foo : Text foo = "foo" ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice's delete: -```ucm -project/alice> delete.term foo +``` ucm +scratch/alice> delete.term foo ``` -```ucm:hide -project/main> branch bob +``` ucm :hide +scratch/main> branch bob ``` Bob's new code that depends on `foo`: -```unison:hide +``` unison :hide bar : Text bar = foo ++ " - " ++ foo ``` -```ucm:error -project/bob> add -project/alice> merge /bob +``` ucm :error +scratch/bob> add +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: type error @@ -507,48 +518,48 @@ It may be Alice's and Bob's changes merge together cleanly in the sense that the In this example, Alice updates a `Text` to a `Nat`, while Bob adds a new dependent of the `Text`. Upon merging, propagating Alice's update to Bob's dependent causes a typechecking failure. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide foo : Text foo = "foo" ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice's update: -```unison:hide +``` unison :hide foo : Nat foo = 100 ``` -```ucm:hide -project/alice> update -project/main> branch bob +``` ucm :hide +scratch/alice> update +scratch/main> branch bob ``` Bob's new definition: -```unison:hide +``` unison :hide bar : Text bar = foo ++ " - " ++ foo ``` -```ucm:hide -project/bob> update +``` ucm :hide +scratch/bob> update ``` -```ucm:error -project/alice> merge /bob +``` ucm :error +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: simple term conflict @@ -556,12 +567,12 @@ project/alice> merge /bob Alice and Bob may disagree about the definition of a term. In this case, the conflicted term and all of its dependents are presented to the user to resolve. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide foo : Text foo = "old foo" @@ -569,13 +580,13 @@ bar : Text bar = "old bar" ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice's changes: -```unison:hide +``` unison :hide foo : Text foo = "alices foo" @@ -586,14 +597,14 @@ qux : Text qux = "alices qux depends on alices foo" ++ foo ``` -```ucm:hide -project/alice> update -project/main> branch bob +``` ucm :hide +scratch/alice> update +scratch/main> branch bob ``` Bob's changes: -```unison:hide +``` unison :hide foo : Text foo = "bobs foo" @@ -601,246 +612,243 @@ baz : Text baz = "bobs baz" ``` -```ucm:hide -project/bob> update +``` ucm :hide +scratch/bob> update ``` -```ucm:error -project/alice> merge /bob +``` ucm :error +scratch/alice> merge /bob ``` -```ucm -project/merge-bob-into-alice> view bar baz +``` ucm +scratch/merge-bob-into-alice> view bar baz ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: simple type conflict Ditto for types; if the hashes don't match, it's a conflict. In this example, Alice and Bob do different things to the same constructor. However, any explicit changes to the same type will result in a conflict, including changes that could concievably be merged (e.g. Alice and Bob both add a new constructor, or edit different constructors). -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide unique type Foo = MkFoo Nat ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice's changes: -```unison:hide +``` unison :hide unique type Foo = MkFoo Nat Nat ``` -```ucm:hide -project/alice> update -project/main> branch bob +``` ucm :hide +scratch/alice> update +scratch/main> branch bob ``` Bob's changes: -```unison:hide +``` unison :hide unique type Foo = MkFoo Nat Text ``` -```ucm:hide -project/bob> update +``` ucm :hide +scratch/bob> update ``` -```ucm:error -project/alice> merge /bob +``` ucm :error +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: type-update + constructor-rename conflict We model the renaming of a type's constructor as an update, so if Alice updates a type and Bob renames one of its constructors (even without changing its structure), we consider it a conflict. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide unique type Foo = Baz Nat | Qux Text ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice's changes `Baz Nat` to `Baz Nat Nat` -```unison:hide +``` unison :hide unique type Foo = Baz Nat Nat | Qux Text ``` -```ucm:hide -project/alice> update -project/main> branch bob +``` ucm :hide +scratch/alice> update +scratch/main> branch bob ``` Bob's renames `Qux` to `BobQux`: -```unison:hide -unique type Foo = Baz Nat | BobQux Text +``` ucm +scratch/bob> move.term Foo.Qux Foo.BobQux ``` -```ucm:hide -project/bob> update -``` -```ucm:error -project/alice> merge /bob +``` ucm :error +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: constructor-rename conflict Here is another example demonstrating that constructor renames are modeled as updates. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide unique type Foo = Baz Nat | Qux Text ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice's rename: -```ucm -project/alice> move.term Foo.Baz Foo.Alice +``` ucm +scratch/alice> move.term Foo.Baz Foo.Alice ``` -```ucm:hide -project/main> branch bob +``` ucm :hide +scratch/main> branch bob ``` Bob's rename: -```ucm -project/bob> move.term Foo.Qux Foo.Bob +``` ucm +scratch/bob> move.term Foo.Qux Foo.Bob ``` -```ucm:error -project/alice> merge bob +``` ucm :error +scratch/alice> merge bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: non-constructor/constructor conflict A constructor on one side can conflict with a regular term definition on the other. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` -```ucm:hide -project/main> branch alice +``` ucm :hide +scratch/main> branch alice ``` Alice's additions: -```unison:hide +``` unison :hide my.cool.thing : Nat my.cool.thing = 17 ``` -```ucm:hide -project/alice> add -project/main> branch bob +``` ucm :hide +scratch/alice> add +scratch/main> branch bob ``` Bob's additions: -```unison:hide +``` unison :hide unique ability my.cool where thing : Nat -> Nat ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` -```ucm:error -project/alice> merge bob +``` ucm :error +scratch/alice> merge bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: type/type conflict with term/constructor conflict Here's a subtle situation where a new type is added on each side of the merge, and an existing term is replaced with a constructor of one of the types. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide Foo.Bar : Nat Foo.Bar = 17 ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice adds this type `Foo` with constructor `Foo.Alice`: -```unison:hide +``` unison :hide unique type Foo = Alice Nat ``` -```ucm:hide -project/alice> add -project/main> branch bob +``` ucm :hide +scratch/alice> add +scratch/main> branch bob ``` Bob adds the type `Foo` with constructor `Foo.Bar`, replacing the original `Foo.Bar` term: -```ucm -project/bob> delete.term Foo.Bar +``` ucm +scratch/bob> delete.term Foo.Bar ``` -```unison:hide +``` unison :hide unique type Foo = Bar Nat Nat ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` These won't cleanly merge. -```ucm:error -project/alice> merge bob +``` ucm :error +scratch/alice> merge bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` Here's a more involved example that demonstrates the same idea. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` In the LCA, we have a type with two constructors, and some term. -```unison:hide +``` unison :hide unique type Foo = Bar.Baz Nat | Bar.Qux Nat Nat @@ -849,20 +857,20 @@ Foo.Bar.Hello : Nat Foo.Bar.Hello = 17 ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice deletes this type entirely, and repurposes its constructor names for other terms. She also updates the term. -```ucm:hide -project/alice> delete.type Foo -project/alice> delete.term Foo.Bar.Baz -project/alice> delete.term Foo.Bar.Qux +``` ucm :hide +scratch/alice> delete.type Foo +scratch/alice> delete.term Foo.Bar.Baz +scratch/alice> delete.term Foo.Bar.Qux ``` -```unison:hide:all +``` unison :hide-all Foo.Bar.Baz : Nat Foo.Bar.Baz = 100 @@ -873,36 +881,36 @@ Foo.Bar.Hello : Nat Foo.Bar.Hello = 18 ``` -```ucm:hide -project/alice> update +``` ucm :hide +scratch/alice> update ``` -```ucm -project/alice> view Foo.Bar.Baz Foo.Bar.Qux Foo.Bar.Hello +``` ucm +scratch/alice> view Foo.Bar.Baz Foo.Bar.Qux Foo.Bar.Hello ``` Bob, meanwhile, first deletes the term, then sort of deletes the type and re-adds it under another name, but one constructor's fully qualified names doesn't actually change. The other constructor reuses the name of the deleted term. -```ucm:hide -project/main> branch bob -project/bob> delete.term Foo.Bar.Hello -project/bob> move.type Foo Foo.Bar -project/bob> move.term Foo.Bar.Qux Foo.Bar.Hello +``` ucm :hide +scratch/main> branch bob +scratch/bob> delete.term Foo.Bar.Hello +scratch/bob> move.type Foo Foo.Bar +scratch/bob> move.term Foo.Bar.Qux Foo.Bar.Hello ``` -```ucm -project/bob> view Foo.Bar +``` ucm +scratch/bob> view Foo.Bar ``` At this point, Bob and alice have both updated the name `Foo.Bar.Hello` in different ways, so that's a conflict. Therefore, Bob's entire type (`Foo.Bar` with constructors `Foo.Bar.Baz` and `Foo.Bar.Hello`) gets rendered into the scratch file. Notably, Alice's "unconflicted" update on the name "Foo.Bar.Baz" (because she changed its hash and Bob didn't touch it) is nonetheless considered conflicted with Bob's "Foo.Bar.Baz". -```ucm:error -project/alice> merge bob +``` ucm :error +scratch/alice> merge bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge algorithm quirk: add/add unique types @@ -913,45 +921,45 @@ which is a parse error. We will resolve this situation automatically in a future version. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` -```ucm:hide -project/main> branch alice +``` ucm :hide +scratch/main> branch alice ``` Alice's additions: -```unison:hide +``` unison :hide unique type Foo = Bar alice : Foo -> Nat alice _ = 18 ``` -```ucm:hide -project/alice> add -project/main> branch bob +``` ucm :hide +scratch/alice> add +scratch/main> branch bob ``` Bob's additions: -```unison:hide +``` unison :hide unique type Foo = Bar bob : Foo -> Nat bob _ = 19 ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` -```ucm:error -project/alice> merge bob +``` ucm :error +scratch/alice> merge bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## `merge.commit` example (success) @@ -959,86 +967,84 @@ project/alice> merge bob After merge conflicts are resolved, you can use `merge.commit` rather than `switch` + `merge` + `branch.delete` to "commit" your changes. -```ucm:hide -.> project.create-empty project -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide foo : Text foo = "old foo" ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice's changes: -```unison:hide +``` unison :hide foo : Text foo = "alices foo" ``` -```ucm:hide -project/alice> update -project/main> branch bob +``` ucm :hide +scratch/alice> update +scratch/main> branch bob ``` Bob's changes: -```unison:hide +``` unison :hide foo : Text foo = "bobs foo" ``` Attempt to merge: -```ucm:hide -project/bob> update +``` ucm :hide +scratch/bob> update ``` -```ucm:error -project/alice> merge /bob +``` ucm :error +scratch/alice> merge /bob ``` Resolve conflicts and commit: -```unison +``` unison foo : Text foo = "alice and bobs foo" ``` -```ucm -project/merge-bob-into-alice> update -project/merge-bob-into-alice> merge.commit -project/alice> view foo -project/alice> branches +``` ucm +scratch/merge-bob-into-alice> update +scratch/merge-bob-into-alice> merge.commit +scratch/alice> view foo +scratch/alice> branches ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## `merge.commit` example (failure) `merge.commit` can only be run on a "merge branch". -```ucm:hide -.> project.create-empty project -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` -```ucm -project/main> branch topic +``` ucm +scratch/main> branch topic ``` -```ucm:error -project/topic> merge.commit +``` ucm :error +scratch/topic> merge.commit ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` @@ -1050,12 +1056,12 @@ There are a number of conditions under which we can't perform a merge, and the u If `foo` and `bar` are aliases in the nearest common ancestor, but not in Alice's branch, then we don't know whether to update Bob's dependents to Alice's `foo` or Alice's `bar` (and vice-versa). -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Original branch: -```unison:hide +``` unison :hide foo : Nat foo = 100 @@ -1063,13 +1069,13 @@ bar : Nat bar = 100 ``` -```ucm:hide -project/main> add -project/main> branch alice +``` ucm :hide +scratch/main> add +scratch/main> branch alice ``` Alice's updates: -```unison:hide +``` unison :hide foo : Nat foo = 200 @@ -1077,27 +1083,27 @@ bar : Nat bar = 300 ``` -```ucm:hide -project/alice> update -project/main> branch bob +``` ucm :hide +scratch/alice> update +scratch/main> branch bob ``` Bob's addition: -```unison:hide +``` unison :hide baz : Text baz = "baz" ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` -```ucm:error -project/alice> merge /bob +``` ucm :error +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ### Conflict involving builtin @@ -1107,264 +1113,264 @@ conflict involving a builtin, we can't perform a merge. One way to fix this in the future would be to introduce a syntax for defining aliases in the scratch file. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` -```ucm:hide -project/main> branch alice +``` ucm :hide +scratch/main> branch alice ``` Alice's branch: -```ucm -project/alice> alias.type builtin.Nat MyNat +``` ucm +scratch/alice> alias.type lib.builtins.Nat MyNat ``` Bob's branch: -```ucm:hide -project/main> branch bob +``` ucm :hide +scratch/main> branch bob ``` -```unison:hide +``` unison :hide unique type MyNat = MyNat Nat ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` -```ucm:error -project/alice> merge /bob +``` ucm :error +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ### Constructor alias Each naming of a decl may not have more than one name for each constructor, within the decl's namespace. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` -```ucm:hide -project/main> branch alice +``` ucm :hide +scratch/main> branch alice ``` Alice's branch: -```unison:hide +``` unison :hide unique type Foo = Bar ``` -```ucm:hide -project/alice> add +``` ucm :hide +scratch/alice> add ``` -```ucm -project/alice> alias.term Foo.Bar Foo.some.other.Alias +``` ucm +scratch/alice> alias.term Foo.Bar Foo.some.other.Alias ``` Bob's branch: -```ucm:hide -project/main> branch bob +``` ucm :hide +scratch/main> branch bob ``` -```unison:hide +``` unison :hide bob : Nat bob = 100 ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` -```ucm:error -project/alice> merge /bob +``` ucm :error +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ### Missing constructor name Each naming of a decl must have a name for each constructor, within the decl's namespace. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Alice's branch: -```ucm:hide -project/main> branch alice +``` ucm :hide +scratch/main> branch alice ``` -```unison:hide +``` unison :hide unique type Foo = Bar ``` -```ucm:hide -project/alice> add +``` ucm :hide +scratch/alice> add ``` -```ucm -project/alice> delete.term Foo.Bar +``` ucm +scratch/alice> delete.term Foo.Bar ``` Bob's branch: -```ucm:hide -project/main> branch /bob +``` ucm :hide +scratch/main> branch /bob ``` -```unison:hide +``` unison :hide bob : Nat bob = 100 ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` -```ucm:error -project/alice> merge /bob +``` ucm :error +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ### Nested decl alias A decl cannot be aliased within the namespace of another of its aliased. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Alice's branch: -```ucm:hide -project/main> branch alice +``` ucm :hide +scratch/main> branch alice ``` -```unison:hide +``` unison :hide structural type A = B Nat | C Nat Nat structural type A.inner.X = Y Nat | Z Nat Nat ``` -```ucm:hide -project/alice> add +``` ucm :hide +scratch/alice> add ``` -```ucm -project/alice> names A +``` ucm +scratch/alice> names A ``` Bob's branch: -```ucm:hide -project/main> branch bob +``` ucm :hide +scratch/main> branch bob ``` -```unison:hide +``` unison :hide bob : Nat bob = 100 ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` -```ucm:error -project/alice> merge /bob +``` ucm :error +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ### Stray constructor alias Constructors may only exist within the corresponding decl's namespace. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Alice's branch: -```ucm:hide -project/main> branch alice +``` ucm :hide +scratch/main> branch alice ``` -```unison:hide:all +``` unison :hide-all unique type Foo = Bar ``` -```ucm -project/alice> add -project/alice> alias.term Foo.Bar AliasOutsideFooNamespace +``` ucm +scratch/alice> add +scratch/alice> alias.term Foo.Bar AliasOutsideFooNamespace ``` Bob's branch: -```ucm:hide -project/main> branch bob +``` ucm :hide +scratch/main> branch bob ``` -```unison:hide:all +``` unison :hide-all bob : Nat bob = 101 ``` -```ucm -project/bob> add +``` ucm +scratch/bob> add ``` -```ucm:error -project/alice> merge bob +``` ucm :error +scratch/alice> merge bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ### Term or type in `lib` By convention, `lib` can only namespaces; each of these represents a library dependencies. Individual terms and types are not allowed at the top level of `lib`. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` Alice's branch: -```ucm:hide -project/main> branch alice +``` ucm :hide +scratch/main> branch alice ``` -```unison:hide +``` unison :hide lib.foo : Nat lib.foo = 1 ``` -```ucm:hide -project/alice> add -project/main> branch bob +``` ucm :hide +scratch/alice> add +scratch/main> branch bob ``` Bob's branch: -```unison:hide +``` unison :hide bob : Nat bob = 100 ``` -```ucm:hide -project/bob> add +``` ucm :hide +scratch/bob> add ``` -```ucm:error -project/alice> merge /bob +``` ucm :error +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## LCA precondition violations @@ -1374,63 +1380,63 @@ The LCA is not subject to most precondition violations, which is good, because t Here's an example. We'll delete a constructor name from the LCA and still be able to merge Alice and Bob's stuff together. -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` LCA: -```unison +``` unison structural type Foo = Bar Nat | Baz Nat Nat ``` -```ucm -project/main> add -project/main> delete.term Foo.Baz +``` ucm +scratch/main> add +scratch/main> delete.term Foo.Baz ``` Alice's branch: -```ucm -project/main> branch alice -project/alice> delete.type Foo -project/alice> delete.term Foo.Bar +``` ucm +scratch/main> branch alice +scratch/alice> delete.type Foo +scratch/alice> delete.term Foo.Bar ``` -```unison +``` unison alice : Nat alice = 100 ``` -```ucm -project/alice> add +``` ucm +scratch/alice> add ``` Bob's branch: -```ucm -project/main> branch bob -project/bob> delete.type Foo -project/bob> delete.term Foo.Bar +``` ucm +scratch/main> branch bob +scratch/bob> delete.type Foo +scratch/bob> delete.term Foo.Bar ``` -```unison +``` unison bob : Nat bob = 101 ``` -```ucm -project/bob> add +``` ucm +scratch/bob> add ``` Now we merge: -```ucm -project/alice> merge /bob +``` ucm +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` ## Regression tests @@ -1438,42 +1444,354 @@ project/alice> merge /bob ### Delete one alias and update the other -```ucm:hide -project/main> builtins.mergeio +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins ``` -```unison +``` unison foo = 17 bar = 17 ``` -```ucm -project/main> add -project/main> branch alice -project/alice> delete.term bar +``` ucm +scratch/main> add +scratch/main> branch alice +scratch/alice> delete.term bar ``` -```unison +``` unison foo = 18 ``` -```ucm -project/alice> update -project/main> branch bob +``` ucm +scratch/alice> update +scratch/main> branch bob ``` -```unison +``` unison bob = 101 ``` -```ucm -project/bob> add +``` ucm +scratch/bob> add +``` + +``` ucm +scratch/alice> merge /bob +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + +### Delete a constructor + + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +type Foo = Bar | Baz +``` + +``` ucm +scratch/main> add +scratch/main> branch topic +``` + +``` unison +boop = "boop" ``` -```ucm -project/alice> merge /bob +``` ucm +scratch/topic> add +``` + +``` unison +type Foo = Bar +``` + +``` ucm +scratch/main> update +``` + +``` ucm +scratch/main> merge topic +scratch/main> view Foo +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + +### Dependent that doesn't need to be in the file + +This test demonstrates a bug. + + +``` ucm :hide +scratch/alice> builtins.mergeio lib.builtins +``` + +In the LCA, we have `foo` with dependent `bar`, and `baz`. + +``` unison +foo : Nat +foo = 17 + +bar : Nat +bar = foo + foo + +baz : Text +baz = "lca" +``` + +``` ucm +scratch/alice> add +scratch/alice> branch bob +``` + +On Bob, we update `baz` to "bob". + +``` unison +baz : Text +baz = "bob" +``` + +``` ucm +scratch/bob> update +``` + +On Alice, we update `baz` to "alice" (conflict), but also update `foo` (unconflicted), which propagates to `bar`. + +``` unison +foo : Nat +foo = 18 + +baz : Text +baz = "alice" +``` + +``` ucm +scratch/alice> update +``` + +When we try to merge Bob into Alice, we should see both versions of `baz`, with Alice's unconflicted `foo` and `bar` in +the underlying namespace. + +``` ucm :error +scratch/alice> merge /bob +``` + +But `bar` was put into the scratch file instead. + +``` ucm :hide +scratch/main> project.delete scratch +``` + +### Merge loop test + +This tests for regressions of https://github.com/unisonweb/unison/issues/1276 where trivial merges cause loops in the +history. + +Let's make three identical namespaces with different histories: + +``` unison +a = 1 +``` + +``` ucm +scratch/alice> add +``` + +``` unison +b = 2 +``` + +``` ucm +scratch/alice> add +``` + +``` unison +b = 2 +``` + +``` ucm +scratch/bob> add +``` + +``` unison +a = 1 +``` + +``` ucm +scratch/bob> add +``` + +``` unison +a = 1 +b = 2 +``` + +``` ucm +scratch/carol> add +scratch/bob> merge /alice +scratch/carol> merge /bob +scratch/carol> history +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + +### Variables named `_` + +This test demonstrates a change in syntactic hashing that fixed a bug due to auto-generated variable names for ignored +results. + +``` ucm :hide +scratch/alice> builtins.mergeio lib.builtins +``` + +``` unison +ignore : a -> () +ignore _ = () + +foo : Nat +foo = 18 + +bar : Nat +bar = + ignore "hi" + foo + foo +``` + +``` ucm +scratch/alice> add +scratch/alice> branch bob +``` + +``` unison +bar : Nat +bar = + ignore "hi" + foo + foo + foo +``` + +``` ucm +scratch/bob> update +``` + +Previously, this update to `foo` would also cause a "real update" on `bar`, its dependent. Now it doesn't, so the merge +will succeed. + +``` unison +foo : Nat +foo = 19 +``` + +``` ucm +scratch/alice> update +``` + +``` ucm +scratch/alice> merge /bob +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + +### Unique type GUID reuse + +Previously, a merge branch would not include any dependents in the namespace, but that resulted in dependent unique +types' GUIDs being regenerated. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +type Foo = Lca +type Bar = MkBar Foo +``` + +``` ucm +scratch/main> add +scratch/main> branch alice +scratch/alice> move.term Foo.Lca Foo.Alice +scratch/main> branch bob +scratch/bob> move.term Foo.Lca Foo.Bob +``` + +``` ucm :error +scratch/alice> merge /bob +``` + +``` ucm +scratch/merge-bob-into-alice> +``` + +``` unison +type Foo = Merged +type Bar = MkBar Foo +``` + +``` ucm +scratch/merge-bob-into-alice> update +scratch/merge-bob-into-alice> names Bar +scratch/alice> names Bar +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + +### Using Alice's names for Bob's things + +Previously, we'd render Alice's stuff with her names and Bob's stuff with his. But because Alice is doing the merge, +we now use her names whenever possible. In this example, Alice calls something `foo` and Bob calls it `bar`. When +rendering conflicts, in Bob's term that references (what he calls) `bar`, we render `foo` instead. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +hello = 17 +``` + +``` ucm +scratch/main> add +scratch/main> branch alice +``` + +``` unison +hello = 18 + foo +foo = 100 +``` + +``` ucm +scratch/alice> update +scratch/main> branch bob +``` + +``` unison +hello = 19 + bar +bar = 100 +``` + +``` ucm +scratch/bob> update +``` + +Note Bob's `hello` references `foo` (Alice's name), not `bar` (Bob's name). + +``` ucm :error +scratch/alice> merge /bob ``` -```ucm:hide -.> project.delete project +``` ucm :hide +scratch/main> project.delete scratch ``` diff --git a/unison-src/transcripts/merge.output.md b/unison-src/transcripts/merge.output.md index 1ead9f4581..e12726898d 100644 --- a/unison-src/transcripts/merge.output.md +++ b/unison-src/transcripts/merge.output.md @@ -3,71 +3,122 @@ The `merge` command merges together two branches in the same project: the current branch (unspecificed), and the target branch. For example, to merge `topic` into `main`, switch to `main` and run `merge topic`: -```ucm -.> help merge +``` ucm +scratch/main> help merge -merge -`merge /branch` merges `branch` into the current branch + merge + `merge /branch` merges `branch` into the current branch -.> help merge.commit +scratch/main> help merge.commit -merge.commit (or commit.merge) -`merge.commit` merges a temporary branch created by the `merge` -command back into its parent branch, and removes the temporary -branch. + merge.commit (or commit.merge) + `merge.commit` merges a temporary branch created by the + `merge` command back into its parent branch, and removes the + temporary branch. -For example, if you've done `merge topic` from main, then -`merge.commit` is equivalent to doing - - * switch /main - * merge /merge-topic-into-main - * delete.branch /merge-topic-into-main + For example, if you've done `merge topic` from main, then + `merge.commit` is equivalent to doing + * switch /main + * merge /merge-topic-into-main + * delete.branch /merge-topic-into-main ``` + Let's see a simple unconflicted merge in action: Alice (us) and Bob (them) add different terms. The merged result contains both additions. ## Basic merge: two unconflicted adds +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` ucm :hide +scratch/main> branch alice +``` + Alice's adds: -```unison + +``` unison :hide foo : Text foo = "alices foo" ``` +``` ucm :hide +scratch/alice> add + +scratch/main> branch bob +``` + Bob's adds: -```unison + +``` unison :hide bar : Text bar = "bobs bar" ``` +``` ucm :hide +scratch/bob> add +``` + Merge result: -```ucm -project/alice> merge /bob - I merged project/bob into project/alice. +``` ucm +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... -project/alice> view foo bar + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I merged scratch/bob into scratch/alice. + +scratch/alice> view foo bar bar : Text bar = "bobs bar" - + foo : Text foo = "alices foo" +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ## Basic merge: two identical adds If Alice and Bob also happen to add the same definition, that's not a conflict. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins + +scratch/main> branch alice +``` + Alice's adds: -```unison + +``` unison :hide foo : Text foo = "alice and bobs foo" ``` +``` ucm :hide +scratch/alice> add + +scratch/main> branch bob +``` + Bob's adds: -```unison + +``` unison :hide foo : Text foo = "alice and bobs foo" @@ -75,78 +126,144 @@ bar : Text bar = "bobs bar" ``` +``` ucm :hide +scratch/bob> add +``` + Merge result: -```ucm -project/alice> merge /bob - I merged project/bob into project/alice. +``` ucm +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I merged scratch/bob into scratch/alice. -project/alice> view foo bar +scratch/alice> view foo bar bar : Text bar = "bobs bar" - + foo : Text foo = "alice and bobs foo" +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ## Simple update propagation Updates that occur in one branch are propagated to the other. In this example, Alice updates `foo`, while Bob adds a new dependent `bar` of the original `foo`. When Bob's branch is merged into Alice's, her update to `foo` is propagated to his `bar`. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide foo : Text foo = "old foo" ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice's updates: -```unison + +``` unison :hide foo : Text foo = "new foo" ``` +``` ucm :hide +scratch/alice> update + +scratch/main> branch bob +``` + Bob's adds: -```unison + +``` unison :hide bar : Text bar = foo ++ " - " ++ foo ``` -```ucm -project/bob> display bar +``` ucm +scratch/bob> display bar "old foo - old foo" +``` +``` ucm :hide +scratch/bob> add ``` + Merge result: -```ucm -project/alice> merge /bob - I merged project/bob into project/alice. +``` ucm +scratch/alice> merge /bob -project/alice> view foo bar + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I merged scratch/bob into scratch/alice. + +scratch/alice> view foo bar bar : Text bar = use Text ++ foo ++ " - " ++ foo - + foo : Text foo = "new foo" -project/alice> display bar +scratch/alice> display bar "old foo - old foo" +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ## Update propagation with common dependent We classify something as an update if its "syntactic hash"—not its normal Unison hash—differs from the original definition. This allows us to cleanly merge unconflicted updates that were individually propagated to a common dependent. Let's see an example. We have `foo`, which depends on `bar` and `baz`. Alice updates `bar` (propagating to `foo`), and Bob updates `baz` (propagating to `foo`). When we merge their updates, both updates will be reflected in the final `foo`. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide foo : Text foo = "foo" ++ " - " ++ bar ++ " - " ++ baz @@ -157,60 +274,102 @@ baz : Text baz = "old baz" ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice's updates: -```unison + +``` unison :hide bar : Text bar = "alices bar" ``` -```ucm -project/alice> display foo +``` ucm :hide +scratch/alice> update +``` + +``` ucm +scratch/alice> display foo "foo - alices bar - old baz" +``` +``` ucm :hide +scratch/main> branch bob ``` + Bob's updates: -```unison + +``` unison :hide baz : Text baz = "bobs baz" ``` -```ucm -project/bob> display foo +``` ucm :hide +scratch/bob> update +``` - "foo - old bar - bobs baz" +``` ucm +scratch/bob> display foo + "foo - old bar - bobs baz" ``` + Merge result: -```ucm -project/alice> merge /bob - I merged project/bob into project/alice. +``` ucm +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... -project/alice> view foo bar baz + I merged scratch/bob into scratch/alice. + +scratch/alice> view foo bar baz bar : Text bar = "alices bar" - + baz : Text baz = "bobs baz" - + foo : Text foo = use Text ++ "foo" ++ " - " ++ bar ++ " - " ++ baz -project/alice> display foo +scratch/alice> display foo "foo - alices bar - bobs baz" +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ## Propagating an update to an update Of course, it's also possible for Alice's update to propagate to one of Bob's updates. In this example, `foo` depends on `bar` which depends on `baz`. Alice updates `baz`, propagating to `bar` and `foo`, while Bob updates `bar` (to something that still depends on `foo`), propagating to `baz`. The merged result will have Alice's update to `foo` incorporated into Bob's updated `bar`, and both updates will propagate to `baz`. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide foo : Text foo = "old foo" ++ " - " ++ bar @@ -221,105 +380,189 @@ baz : Text baz = "old baz" ``` -```ucm -project/main> display foo +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> display foo "old foo - old bar - old baz" +``` +``` ucm :hide +scratch/main> branch alice ``` + Alice's updates: -```unison + +``` unison :hide baz : Text baz = "alices baz" ``` -```ucm -project/alice> display foo +``` ucm :hide +scratch/alice> update +``` + +``` ucm +scratch/alice> display foo "old foo - old bar - alices baz" +``` +``` ucm :hide +scratch/main> branch bob ``` + Bob's updates: -```unison + +``` unison :hide bar : Text bar = "bobs bar" ++ " - " ++ baz ``` -```ucm -project/bob> display foo +``` ucm :hide +scratch/bob> update +``` - "old foo - bobs bar - old baz" +``` ucm +scratch/bob> display foo + "old foo - bobs bar - old baz" ``` + Merge result: -```ucm -project/alice> merge /bob - I merged project/bob into project/alice. +``` ucm +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... -project/alice> view foo bar baz + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I merged scratch/bob into scratch/alice. + +scratch/alice> view foo bar baz bar : Text bar = use Text ++ "bobs bar" ++ " - " ++ baz - + baz : Text baz = "alices baz" - + foo : Text foo = use Text ++ "old foo" ++ " - " ++ bar -project/alice> display foo +scratch/alice> display foo "old foo - bobs bar - alices baz" +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ## Update + delete isn't (currently) a conflict We don't currently consider "update + delete" a conflict like Git does. In this situation, the delete is just ignored, allowing the update to proceed. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide foo : Text foo = "old foo" ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice's updates: -```unison + +``` unison :hide foo : Text foo = "alices foo" ``` +``` ucm :hide +scratch/alice> update + +scratch/main> branch bob +``` + Bob's changes: -```ucm -project/bob> delete.term foo - Done. +``` ucm +scratch/bob> delete.term foo + Done. ``` + Merge result: -```ucm -project/alice> merge /bob - I merged project/bob into project/alice. +``` ucm +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... -project/alice> view foo + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I merged scratch/bob into scratch/alice. + +scratch/alice> view foo foo : Text foo = "alices foo" +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + In a future version, we'd like to give the user a warning at least. ## Library dependencies don't create merge conflicts Library dependencies don't cause merge conflicts, the library dependencies are just unioned together. If two library dependencies have the same name but different namespace hashes, then the merge algorithm makes up two fresh names. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Alice's adds: -```unison + +``` ucm :hide +scratch/main> branch alice +``` + +``` unison :hide lib.alice.foo : Nat lib.alice.foo = 17 @@ -330,8 +573,15 @@ lib.bothDifferent.baz : Nat lib.bothDifferent.baz = 19 ``` +``` ucm :hide +scratch/alice> add + +scratch/main> branch bob +``` + Bob's adds: -```unison + +``` unison :hide lib.bob.foo : Nat lib.bob.foo = 20 @@ -342,134 +592,202 @@ lib.bothDifferent.baz : Nat lib.bothDifferent.baz = 21 ``` +``` ucm :hide +scratch/bob> add +``` + Merge result: -```ucm -project/alice> merge bob - I merged project/bob into project/alice. +``` ucm +scratch/alice> merge bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... -project/alice> view foo bar baz + I merged scratch/bob into scratch/alice. + +scratch/alice> view foo bar baz lib.alice.foo : Nat lib.alice.foo = 17 - + lib.bob.foo : Nat lib.bob.foo = 20 - + lib.bothDifferent__0.baz : Nat lib.bothDifferent__0.baz = 19 - + lib.bothDifferent__1.baz : Nat lib.bothDifferent__1.baz = 21 - + lib.bothSame.bar : Nat lib.bothSame.bar = 18 +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ## No-op merge (Bob = Alice) If Bob is equals Alice, then merging Bob into Alice looks like this. -```ucm -project/main> branch alice +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` ucm +scratch/main> branch alice Done. I've created the alice branch based off of main. - + Tip: To merge your work back into the main branch, first `switch /main` then `merge /alice`. -project/main> branch bob +scratch/main> branch bob Done. I've created the bob branch based off of main. - + Tip: To merge your work back into the main branch, first `switch /main` then `merge /bob`. -project/alice> merge /bob +scratch/alice> merge /bob 😶 - - project/alice was already up-to-date with project/bob. + scratch/alice was already up-to-date with scratch/bob. +``` + +``` ucm :hide +scratch/main> project.delete scratch ``` -## No-op merge (Bob < Alice) + +## No-op merge (Bob \< Alice) If Bob is behind Alice, then merging Bob into Alice looks like this. -```ucm -project/main> branch alice +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` ucm +scratch/main> branch alice Done. I've created the alice branch based off of main. - + Tip: To merge your work back into the main branch, first `switch /main` then `merge /alice`. -project/main> branch bob +scratch/main> branch bob Done. I've created the bob branch based off of main. - + Tip: To merge your work back into the main branch, first `switch /main` then `merge /bob`. - ``` + Alice's addition: -```unison + +``` unison :hide foo : Text foo = "foo" ``` -```ucm -project/alice> add +``` ucm +scratch/alice> add ⍟ I've added these definitions: - + foo : Text -project/alice> merge /bob +scratch/alice> merge /bob 😶 - - project/alice was already up-to-date with project/bob. + scratch/alice was already up-to-date with scratch/bob. +``` + +``` ucm :hide +scratch/main> project.delete scratch ``` -## Fast-forward merge (Bob > Alice) + +## Fast-forward merge (Bob \> Alice) If Bob is ahead of Alice, then merging Bob into Alice looks like this. -```ucm -project/main> branch alice +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` ucm +scratch/main> branch alice Done. I've created the alice branch based off of main. - + Tip: To merge your work back into the main branch, first `switch /main` then `merge /alice`. -project/main> branch bob +scratch/main> branch bob Done. I've created the bob branch based off of main. - + Tip: To merge your work back into the main branch, first `switch /main` then `merge /bob`. - ``` + Bob's addition: -```unison + +``` unison :hide foo : Text foo = "foo" ``` -```ucm -project/bob> add +``` ucm +scratch/bob> add ⍟ I've added these definitions: - + foo : Text -project/alice> merge /bob +scratch/alice> merge /bob + + I fast-forward merged scratch/bob into scratch/alice. +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + +## No-op merge: merge empty namespace into empty namespace + +``` ucm +scratch/main> branch topic + + Done. I've created the topic branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic`. - I fast-forward merged project/bob into project/alice. +scratch/main> merge /topic + + 😶 + + scratch/main was already up-to-date with scratch/topic. +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ## Merge failure: someone deleted something If either Alice or Bob delete something, so long as the other person didn't update it (in which case we ignore the delete, as explained above), then the delete goes through. @@ -478,58 +796,90 @@ This can cause merge failures due to out-of-scope identifiers, and the user may In this example, Alice deletes `foo`, while Bob adds a new dependent of `foo`. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide foo : Text foo = "foo" ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice's delete: -```ucm -project/alice> delete.term foo + +``` ucm +scratch/alice> delete.term foo Done. +``` +``` ucm :hide +scratch/main> branch bob ``` + Bob's new code that depends on `foo`: -```unison + +``` unison :hide bar : Text bar = foo ++ " - " ++ foo ``` -```ucm -project/bob> add +``` ucm :error +scratch/bob> add ⍟ I've added these definitions: - + bar : Text -project/alice> merge /bob +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... - I couldn't automatically merge project/bob into project/alice. + Rendering Unison file... + + Typechecking Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. However, I've added the definitions that need attention to the top of scratch.u. - + When you're done, you can run - + merge.commit - + to merge your changes back into alice and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run - + delete.branch /merge-bob-into-alice - - to delete the temporary branch and switch back to alice. + to delete the temporary branch and switch back to alice. ``` -```unison:added-by-ucm scratch.u + +``` unison :added-by-ucm scratch.u bar : Text bar = use Text ++ foo ++ " - " ++ foo +``` +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: type error @@ -538,51 +888,89 @@ It may be Alice's and Bob's changes merge together cleanly in the sense that the In this example, Alice updates a `Text` to a `Nat`, while Bob adds a new dependent of the `Text`. Upon merging, propagating Alice's update to Bob's dependent causes a typechecking failure. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide foo : Text foo = "foo" ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice's update: -```unison + +``` unison :hide foo : Nat foo = 100 ``` +``` ucm :hide +scratch/alice> update + +scratch/main> branch bob +``` + Bob's new definition: -```unison + +``` unison :hide bar : Text bar = foo ++ " - " ++ foo ``` -```ucm -project/alice> merge /bob +``` ucm :hide +scratch/bob> update +``` + +``` ucm :error +scratch/alice> merge /bob + + Loading branches... - I couldn't automatically merge project/bob into project/alice. + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. However, I've added the definitions that need attention to the top of scratch.u. - + When you're done, you can run - + merge.commit - + to merge your changes back into alice and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run - + delete.branch /merge-bob-into-alice - - to delete the temporary branch and switch back to alice. + to delete the temporary branch and switch back to alice. ``` -```unison:added-by-ucm scratch.u + +``` unison :added-by-ucm scratch.u bar : Text bar = use Text ++ foo ++ " - " ++ foo +``` +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: simple term conflict @@ -590,8 +978,13 @@ bar = Alice and Bob may disagree about the definition of a term. In this case, the conflicted term and all of its dependents are presented to the user to resolve. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide foo : Text foo = "old foo" @@ -599,8 +992,15 @@ bar : Text bar = "old bar" ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice's changes: -```unison + +``` unison :hide foo : Text foo = "alices foo" @@ -611,9 +1011,15 @@ qux : Text qux = "alices qux depends on alices foo" ++ foo ``` +``` ucm :hide +scratch/alice> update + +scratch/main> branch bob +``` + Bob's changes: -```unison +``` unison :hide foo : Text foo = "bobs foo" @@ -621,32 +1027,46 @@ baz : Text baz = "bobs baz" ``` -```ucm -project/alice> merge /bob +``` ucm :hide +scratch/bob> update +``` + +``` ucm :error +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... - I couldn't automatically merge project/bob into project/alice. + Loading and merging library dependencies... + + Rendering Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. However, I've added the definitions that need attention to the top of scratch.u. - + When you're done, you can run - + merge.commit - + to merge your changes back into alice and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run - + delete.branch /merge-bob-into-alice - - to delete the temporary branch and switch back to alice. + to delete the temporary branch and switch back to alice. ``` -```unison:added-by-ucm scratch.u --- project/alice + +``` unison :added-by-ucm scratch.u +-- scratch/alice foo : Text foo = "alices foo" --- project/bob +-- scratch/bob foo : Text foo = "bobs foo" @@ -658,283 +1078,460 @@ qux = use Text ++ "alices qux depends on alices foo" ++ foo - ``` -```ucm -project/merge-bob-into-alice> view bar baz +``` ucm +scratch/merge-bob-into-alice> view bar baz bar : Text bar = "alices bar" - + baz : Text baz = "bobs baz" +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ## Merge failure: simple type conflict Ditto for types; if the hashes don't match, it's a conflict. In this example, Alice and Bob do different things to the same constructor. However, any explicit changes to the same type will result in a conflict, including changes that could concievably be merged (e.g. Alice and Bob both add a new constructor, or edit different constructors). +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide unique type Foo = MkFoo Nat ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice's changes: -```unison + +``` unison :hide unique type Foo = MkFoo Nat Nat ``` +``` ucm :hide +scratch/alice> update + +scratch/main> branch bob +``` + Bob's changes: -```unison + +``` unison :hide unique type Foo = MkFoo Nat Text ``` -```ucm -project/alice> merge /bob +``` ucm :hide +scratch/bob> update +``` + +``` ucm :error +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... - I couldn't automatically merge project/bob into project/alice. + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. However, I've added the definitions that need attention to the top of scratch.u. - + When you're done, you can run - + merge.commit - + to merge your changes back into alice and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run - + delete.branch /merge-bob-into-alice - - to delete the temporary branch and switch back to alice. + to delete the temporary branch and switch back to alice. ``` -```unison:added-by-ucm scratch.u --- project/alice + +``` unison :added-by-ucm scratch.u +-- scratch/alice type Foo = MkFoo Nat Nat --- project/bob +-- scratch/bob type Foo = MkFoo Nat Text +``` +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: type-update + constructor-rename conflict We model the renaming of a type's constructor as an update, so if Alice updates a type and Bob renames one of its constructors (even without changing its structure), we consider it a conflict. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide unique type Foo = Baz Nat | Qux Text ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice's changes `Baz Nat` to `Baz Nat Nat` -```unison + +``` unison :hide unique type Foo = Baz Nat Nat | Qux Text ``` +``` ucm :hide +scratch/alice> update + +scratch/main> branch bob +``` + Bob's renames `Qux` to `BobQux`: -```unison -unique type Foo = Baz Nat | BobQux Text + +``` ucm +scratch/bob> move.term Foo.Qux Foo.BobQux + + Done. ``` -```ucm -project/alice> merge /bob +``` ucm :error +scratch/alice> merge /bob - I couldn't automatically merge project/bob into project/alice. + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. However, I've added the definitions that need attention to the top of scratch.u. - + When you're done, you can run - + merge.commit - + to merge your changes back into alice and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run - + delete.branch /merge-bob-into-alice - - to delete the temporary branch and switch back to alice. + to delete the temporary branch and switch back to alice. ``` -```unison:added-by-ucm scratch.u --- project/alice + +``` unison :added-by-ucm scratch.u +-- scratch/alice type Foo = Baz Nat Nat | Qux Text --- project/bob -type Foo = Baz Nat | BobQux Text +-- scratch/bob +type Foo = BobQux Text | Baz Nat +``` +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: constructor-rename conflict Here is another example demonstrating that constructor renames are modeled as updates. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide unique type Foo = Baz Nat | Qux Text ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice's rename: -```ucm -project/alice> move.term Foo.Baz Foo.Alice + +``` ucm +scratch/alice> move.term Foo.Baz Foo.Alice Done. +``` +``` ucm :hide +scratch/main> branch bob ``` + Bob's rename: -```ucm -project/bob> move.term Foo.Qux Foo.Bob - Done. +``` ucm +scratch/bob> move.term Foo.Qux Foo.Bob + Done. ``` -```ucm -project/alice> merge bob - I couldn't automatically merge project/bob into project/alice. +``` ucm :error +scratch/alice> merge bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. However, I've added the definitions that need attention to the top of scratch.u. - + When you're done, you can run - + merge.commit - + to merge your changes back into alice and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run - + delete.branch /merge-bob-into-alice - - to delete the temporary branch and switch back to alice. + to delete the temporary branch and switch back to alice. ``` -```unison:added-by-ucm scratch.u --- project/alice + +``` unison :added-by-ucm scratch.u +-- scratch/alice type Foo = Qux Text | Alice Nat --- project/bob +-- scratch/bob type Foo = Bob Text | Baz Nat +``` +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: non-constructor/constructor conflict A constructor on one side can conflict with a regular term definition on the other. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` ucm :hide +scratch/main> branch alice +``` + Alice's additions: -```unison + +``` unison :hide my.cool.thing : Nat my.cool.thing = 17 ``` +``` ucm :hide +scratch/alice> add + +scratch/main> branch bob +``` + Bob's additions: -```unison + +``` unison :hide unique ability my.cool where thing : Nat -> Nat ``` -```ucm -project/alice> merge bob +``` ucm :hide +scratch/bob> add +``` + +``` ucm :error +scratch/alice> merge bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... - I couldn't automatically merge project/bob into project/alice. + Loading and merging library dependencies... + + Rendering Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. However, I've added the definitions that need attention to the top of scratch.u. - + When you're done, you can run - + merge.commit - + to merge your changes back into alice and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run - + delete.branch /merge-bob-into-alice - - to delete the temporary branch and switch back to alice. + to delete the temporary branch and switch back to alice. ``` -```unison:added-by-ucm scratch.u --- project/alice + +``` unison :added-by-ucm scratch.u +-- scratch/alice my.cool.thing : Nat my.cool.thing = 17 --- project/bob +-- scratch/bob ability my.cool where thing : Nat ->{cool} Nat +``` +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge failure: type/type conflict with term/constructor conflict Here's a subtle situation where a new type is added on each side of the merge, and an existing term is replaced with a constructor of one of the types. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide Foo.Bar : Nat Foo.Bar = 17 ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice adds this type `Foo` with constructor `Foo.Alice`: -```unison + +``` unison :hide unique type Foo = Alice Nat ``` +``` ucm :hide +scratch/alice> add + +scratch/main> branch bob +``` + Bob adds the type `Foo` with constructor `Foo.Bar`, replacing the original `Foo.Bar` term: -```ucm -project/bob> delete.term Foo.Bar - Done. +``` ucm +scratch/bob> delete.term Foo.Bar + Done. ``` -```unison + +``` unison :hide unique type Foo = Bar Nat Nat ``` +``` ucm :hide +scratch/bob> add +``` + These won't cleanly merge. -```ucm -project/alice> merge bob - I couldn't automatically merge project/bob into project/alice. +``` ucm :error +scratch/alice> merge bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. However, I've added the definitions that need attention to the top of scratch.u. - + When you're done, you can run - + merge.commit - + to merge your changes back into alice and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run - + delete.branch /merge-bob-into-alice - - to delete the temporary branch and switch back to alice. + to delete the temporary branch and switch back to alice. ``` -```unison:added-by-ucm scratch.u --- project/alice + +``` unison :added-by-ucm scratch.u +-- scratch/alice Foo.Bar : Nat Foo.Bar = 17 --- project/alice +-- scratch/alice type Foo = Alice Nat --- project/bob +-- scratch/bob type Foo = Bar Nat Nat +``` +``` ucm :hide +scratch/main> project.delete scratch ``` Here's a more involved example that demonstrates the same idea. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + In the LCA, we have a type with two constructors, and some term. -```unison +``` unison :hide unique type Foo = Bar.Baz Nat | Bar.Qux Nat Nat @@ -943,66 +1540,107 @@ Foo.Bar.Hello : Nat Foo.Bar.Hello = 17 ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice deletes this type entirely, and repurposes its constructor names for other terms. She also updates the term. -```ucm -project/alice> view Foo.Bar.Baz Foo.Bar.Qux Foo.Bar.Hello +``` ucm :hide +scratch/alice> delete.type Foo + +scratch/alice> delete.term Foo.Bar.Baz + +scratch/alice> delete.term Foo.Bar.Qux +``` + +``` ucm :hide +scratch/alice> update +``` + +``` ucm +scratch/alice> view Foo.Bar.Baz Foo.Bar.Qux Foo.Bar.Hello Foo.Bar.Baz : Nat Foo.Bar.Baz = 100 - + Foo.Bar.Hello : Nat Foo.Bar.Hello = 18 - + Foo.Bar.Qux : Nat Foo.Bar.Qux = 200 - ``` + Bob, meanwhile, first deletes the term, then sort of deletes the type and re-adds it under another name, but one constructor's fully qualified names doesn't actually change. The other constructor reuses the name of the deleted term. -```ucm -project/bob> view Foo.Bar +``` ucm :hide +scratch/main> branch bob + +scratch/bob> delete.term Foo.Bar.Hello + +scratch/bob> move.type Foo Foo.Bar - type Foo.Bar = Baz Nat | Hello Nat Nat +scratch/bob> move.term Foo.Bar.Qux Foo.Bar.Hello +``` + +``` ucm +scratch/bob> view Foo.Bar + type Foo.Bar = Hello Nat Nat | Baz Nat ``` + At this point, Bob and alice have both updated the name `Foo.Bar.Hello` in different ways, so that's a conflict. Therefore, Bob's entire type (`Foo.Bar` with constructors `Foo.Bar.Baz` and `Foo.Bar.Hello`) gets rendered into the scratch file. Notably, Alice's "unconflicted" update on the name "Foo.Bar.Baz" (because she changed its hash and Bob didn't touch it) is nonetheless considered conflicted with Bob's "Foo.Bar.Baz". -```ucm -project/alice> merge bob +``` ucm :error +scratch/alice> merge bob + + Loading branches... - I couldn't automatically merge project/bob into project/alice. + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. However, I've added the definitions that need attention to the top of scratch.u. - + When you're done, you can run - + merge.commit - + to merge your changes back into alice and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run - + delete.branch /merge-bob-into-alice - - to delete the temporary branch and switch back to alice. + to delete the temporary branch and switch back to alice. ``` -```unison:added-by-ucm scratch.u --- project/alice + +``` unison :added-by-ucm scratch.u +-- scratch/alice Foo.Bar.Baz : Nat Foo.Bar.Baz = 100 --- project/alice +-- scratch/alice Foo.Bar.Hello : Nat Foo.Bar.Hello = 18 --- project/bob -type Foo.Bar = Baz Nat | Hello Nat Nat +-- scratch/bob +type Foo.Bar = Hello Nat Nat | Baz Nat +``` +``` ucm :hide +scratch/main> project.delete scratch ``` ## Merge algorithm quirk: add/add unique types @@ -1013,48 +1651,78 @@ which is a parse error. We will resolve this situation automatically in a future version. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` ucm :hide +scratch/main> branch alice +``` + Alice's additions: -```unison + +``` unison :hide unique type Foo = Bar alice : Foo -> Nat alice _ = 18 ``` +``` ucm :hide +scratch/alice> add + +scratch/main> branch bob +``` + Bob's additions: -```unison + +``` unison :hide unique type Foo = Bar bob : Foo -> Nat bob _ = 19 ``` -```ucm -project/alice> merge bob +``` ucm :hide +scratch/bob> add +``` + +``` ucm :error +scratch/alice> merge bob + + Loading branches... - I couldn't automatically merge project/bob into project/alice. + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. However, I've added the definitions that need attention to the top of scratch.u. - + When you're done, you can run - + merge.commit - + to merge your changes back into alice and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run - + delete.branch /merge-bob-into-alice - - to delete the temporary branch and switch back to alice. + to delete the temporary branch and switch back to alice. ``` -```unison:added-by-ucm scratch.u --- project/alice + +``` unison :added-by-ucm scratch.u +-- scratch/alice type Foo = Bar --- project/bob +-- scratch/bob type Foo = Bar @@ -1067,7 +1735,10 @@ alice _ = 18 bob : Foo -> Nat bob _ = 19 +``` +``` ucm :hide +scratch/main> project.delete scratch ``` ## `merge.commit` example (success) @@ -1075,124 +1746,167 @@ bob _ = 19 After merge conflicts are resolved, you can use `merge.commit` rather than `switch` + `merge` + `branch.delete` to "commit" your changes. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide foo : Text foo = "old foo" ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice's changes: -```unison + +``` unison :hide foo : Text foo = "alices foo" ``` +``` ucm :hide +scratch/alice> update + +scratch/main> branch bob +``` + Bob's changes: -```unison +``` unison :hide foo : Text foo = "bobs foo" ``` Attempt to merge: -```ucm -project/alice> merge /bob +``` ucm :hide +scratch/bob> update +``` + +``` ucm :error +scratch/alice> merge /bob - I couldn't automatically merge project/bob into project/alice. + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. However, I've added the definitions that need attention to the top of scratch.u. - + When you're done, you can run - + merge.commit - + to merge your changes back into alice and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run - + delete.branch /merge-bob-into-alice - - to delete the temporary branch and switch back to alice. + to delete the temporary branch and switch back to alice. ``` -```unison:added-by-ucm scratch.u --- project/alice + +``` unison :added-by-ucm scratch.u +-- scratch/alice foo : Text foo = "alices foo" --- project/bob +-- scratch/bob foo : Text foo = "bobs foo" - ``` Resolve conflicts and commit: -```unison +``` unison foo : Text foo = "alice and bobs foo" ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - - ⍟ These new definitions are ok to `add`: + + ⍟ These names already exist. You can `update` them to your + new definition: foo : Text - ``` -```ucm -project/merge-bob-into-alice> update + +``` ucm +scratch/merge-bob-into-alice> update Okay, I'm searching the branch for code that needs to be updated... Done. -project/merge-bob-into-alice> merge.commit +scratch/merge-bob-into-alice> merge.commit - I fast-forward merged project/merge-bob-into-alice into - project/alice. + I fast-forward merged scratch/merge-bob-into-alice into + scratch/alice. -project/alice> view foo +scratch/alice> view foo foo : Text foo = "alice and bobs foo" -project/alice> branches +scratch/alice> branches Branch Remote branch 1. alice 2. bob 3. main +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ## `merge.commit` example (failure) `merge.commit` can only be run on a "merge branch". -```ucm -project/main> branch topic +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` ucm +scratch/main> branch topic Done. I've created the topic branch based off of main. - + Tip: To merge your work back into the main branch, first `switch /main` then `merge /topic`. - ``` -```ucm -project/topic> merge.commit + +``` ucm :error +scratch/topic> merge.commit It doesn't look like there's a merge in progress. +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ## Precondition violations There are a number of conditions under which we can't perform a merge, and the user will have to fix up the namespace(s) manually before attempting to merge again. @@ -1201,8 +1915,13 @@ There are a number of conditions under which we can't perform a merge, and the u If `foo` and `bar` are aliases in the nearest common ancestor, but not in Alice's branch, then we don't know whether to update Bob's dependents to Alice's `foo` or Alice's `bar` (and vice-versa). +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Original branch: -```unison + +``` unison :hide foo : Nat foo = 100 @@ -1210,8 +1929,15 @@ bar : Nat bar = 100 ``` +``` ucm :hide +scratch/main> add + +scratch/main> branch alice +``` + Alice's updates: -```unison + +``` unison :hide foo : Nat foo = 200 @@ -1219,33 +1945,52 @@ bar : Nat bar = 300 ``` +``` ucm :hide +scratch/alice> update + +scratch/main> branch bob +``` + Bob's addition: -```unison + +``` unison :hide baz : Text baz = "baz" ``` -```ucm -project/alice> merge /bob +``` ucm :hide +scratch/bob> add +``` + +``` ucm :error +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... Sorry, I wasn't able to perform the merge: - + On the merge ancestor, bar and foo were aliases for the same - definition, but on project/alice the names have different + term, but on scratch/alice the names have different definitions currently. I'd need just a single new definition to use in their dependents when I merge. - - Please fix up project/alice to resolve this. For example, - + + Please fix up scratch/alice to resolve this. For example, + * `update` the definitions to be the same again, so that there's nothing for me to decide. * `move` or `delete` all but one of the definitions; I'll use the remaining name when propagating updates. (You can `move` it back after the merge.) - + and then try merging again. +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ### Conflict involving builtin We don't have a way of rendering a builtin in a scratch file, where users resolve merge conflicts. Thus, if there is a @@ -1253,446 +1998,1544 @@ conflict involving a builtin, we can't perform a merge. One way to fix this in the future would be to introduce a syntax for defining aliases in the scratch file. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` ucm :hide +scratch/main> branch alice +``` + Alice's branch: -```ucm -project/alice> alias.type builtin.Nat MyNat - Done. +``` ucm +scratch/alice> alias.type lib.builtins.Nat MyNat + Done. ``` + Bob's branch: -```unison + +``` ucm :hide +scratch/main> branch bob +``` + +``` unison :hide unique type MyNat = MyNat Nat ``` -```ucm -project/alice> merge /bob +``` ucm :hide +scratch/bob> add +``` + +``` ucm :error +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... Sorry, I wasn't able to perform the merge: - - There's a merge conflict on MyNat, but it's a builtin on one - or both branches. I can't yet handle merge conflicts involving - builtins. - + + There's a merge conflict on type MyNat, but it's a builtin on + one or both branches. I can't yet handle merge conflicts + involving builtins. + Please eliminate this conflict by updating one branch or the other, making MyNat the same on both branches, or making neither of them a builtin, and then try the merge again. +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ### Constructor alias Each naming of a decl may not have more than one name for each constructor, within the decl's namespace. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` ucm :hide +scratch/main> branch alice +``` + Alice's branch: -```unison + +``` unison :hide unique type Foo = Bar ``` -```ucm -project/alice> alias.term Foo.Bar Foo.some.other.Alias +``` ucm :hide +scratch/alice> add +``` + +``` ucm +scratch/alice> alias.term Foo.Bar Foo.some.other.Alias Done. - ``` + Bob's branch: -```unison + +``` ucm :hide +scratch/main> branch bob +``` + +``` unison :hide bob : Nat bob = 100 ``` -```ucm -project/alice> merge /bob +``` ucm :hide +scratch/bob> add +``` + +``` ucm :error +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... Sorry, I wasn't able to perform the merge: - - On project/alice, the type Foo has a constructor with multiple + + On scratch/alice, the type Foo has a constructor with multiple names, and I can't perform a merge in this situation: - + * Foo.Bar * Foo.some.other.Alias - + Please delete all but one name for each constructor, and then try merging again. +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ### Missing constructor name Each naming of a decl must have a name for each constructor, within the decl's namespace. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Alice's branch: -```unison + +``` ucm :hide +scratch/main> branch alice +``` + +``` unison :hide unique type Foo = Bar ``` -```ucm -project/alice> delete.term Foo.Bar +``` ucm :hide +scratch/alice> add +``` - Done. +``` ucm +scratch/alice> delete.term Foo.Bar + Done. ``` + Bob's branch: -```unison + +``` ucm :hide +scratch/main> branch /bob +``` + +``` unison :hide bob : Nat bob = 100 ``` -```ucm -project/alice> merge /bob +``` ucm :hide +scratch/bob> add +``` + +``` ucm :error +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... Sorry, I wasn't able to perform the merge: - - On project/alice, the type Foo has some constructors with + + On scratch/alice, the type Foo has some constructors with missing names, and I can't perform a merge in this situation. - + You can use `view Foo` and `alias.term Foo.` to give names to each unnamed constructor, and then try the merge again. +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ### Nested decl alias A decl cannot be aliased within the namespace of another of its aliased. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Alice's branch: -```unison + +``` ucm :hide +scratch/main> branch alice +``` + +``` unison :hide structural type A = B Nat | C Nat Nat structural type A.inner.X = Y Nat | Z Nat Nat ``` -```ucm -project/alice> names A +``` ucm :hide +scratch/alice> add +``` + +``` ucm +scratch/alice> names A Type Hash: #65mdg7015r Names: A A.inner.X - - Tip: Use `names.global` to see more results. - ``` + Bob's branch: -```unison + +``` ucm :hide +scratch/main> branch bob +``` + +``` unison :hide bob : Nat bob = 100 ``` -```ucm -project/alice> merge /bob +``` ucm :hide +scratch/bob> add +``` + +``` ucm :error +scratch/alice> merge /bob + + Loading branches... - On project/alice, the type A.inner.X is an alias of A. I'm not + Computing diff between branches... + + On scratch/alice, the type A.inner.X is an alias of A. I'm not able to perform a merge when a type exists nested under an alias of itself. Please separate them or delete one copy, and then try merging again. +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ### Stray constructor alias Constructors may only exist within the corresponding decl's namespace. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Alice's branch: -```ucm -project/alice> add + +``` ucm :hide +scratch/main> branch alice +``` + +``` ucm +scratch/alice> add ⍟ I've added these definitions: - + type Foo -project/alice> alias.term Foo.Bar AliasOutsideFooNamespace +scratch/alice> alias.term Foo.Bar AliasOutsideFooNamespace Done. - ``` + Bob's branch: -```ucm -project/bob> add + +``` ucm :hide +scratch/main> branch bob +``` + +``` ucm +scratch/bob> add ⍟ I've added these definitions: - - bob : Nat + bob : Nat ``` -```ucm -project/alice> merge bob + +``` ucm :error +scratch/alice> merge bob + + Loading branches... + + Computing diff between branches... Sorry, I wasn't able to perform the merge, because I need all constructor names to be nested somewhere beneath the corresponding type name. - - On project/alice, the constructor AliasOutsideFooNamespace is + + On scratch/alice, the constructor AliasOutsideFooNamespace is not nested beneath the corresponding type name. Please either use `move` to move it, or if it's an extra copy, you can simply `delete` it. Then try the merge again. +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ### Term or type in `lib` By convention, `lib` can only namespaces; each of these represents a library dependencies. Individual terms and types are not allowed at the top level of `lib`. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + Alice's branch: -```unison + +``` ucm :hide +scratch/main> branch alice +``` + +``` unison :hide lib.foo : Nat lib.foo = 1 ``` +``` ucm :hide +scratch/alice> add + +scratch/main> branch bob +``` + Bob's branch: -```unison + +``` unison :hide bob : Nat bob = 100 ``` -```ucm -project/alice> merge /bob +``` ucm :hide +scratch/bob> add +``` + +``` ucm :error +scratch/alice> merge /bob + + Loading branches... Sorry, I wasn't able to perform the merge: - - On project/alice, there's a type or term at the top level of + + On scratch/alice, there's a type or term at the top level of the `lib` namespace, where I only expect to find subnamespaces representing library dependencies. - + Please move or remove it and then try merging again. +``` +``` ucm :hide +scratch/main> project.delete scratch ``` + ## LCA precondition violations -The LCA is not subject to most precondition violations, which is good, because the user can't easily manipulate it! +The LCA is not subject to most precondition violations, which is good, because the user can't easily manipulate it\! Here's an example. We'll delete a constructor name from the LCA and still be able to merge Alice and Bob's stuff together. +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + LCA: -```unison +``` unison structural type Foo = Bar Nat | Baz Nat Nat ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: structural type Foo - ``` -```ucm -project/main> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + structural type Foo -project/main> delete.term Foo.Baz +scratch/main> delete.term Foo.Baz Done. - ``` + Alice's branch: -```ucm -project/main> branch alice +``` ucm +scratch/main> branch alice Done. I've created the alice branch based off of main. - + Tip: To merge your work back into the main branch, first `switch /main` then `merge /alice`. -project/alice> delete.type Foo +scratch/alice> delete.type Foo Done. -project/alice> delete.term Foo.Bar +scratch/alice> delete.term Foo.Bar Done. - ``` -```unison + +``` unison alice : Nat alice = 100 ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: alice : Nat - ``` -```ucm -project/alice> add + +``` ucm +scratch/alice> add ⍟ I've added these definitions: - - alice : Nat + alice : Nat ``` + Bob's branch: -```ucm -project/main> branch bob +``` ucm +scratch/main> branch bob Done. I've created the bob branch based off of main. - + Tip: To merge your work back into the main branch, first `switch /main` then `merge /bob`. -project/bob> delete.type Foo +scratch/bob> delete.type Foo Done. -project/bob> delete.term Foo.Bar +scratch/bob> delete.term Foo.Bar Done. - ``` -```unison + +``` unison bob : Nat bob = 101 ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: bob : Nat - ``` -```ucm -project/bob> add + +``` ucm +scratch/bob> add ⍟ I've added these definitions: - - bob : Nat + bob : Nat ``` + Now we merge: -```ucm -project/alice> merge /bob +``` ucm +scratch/alice> merge /bob + + Loading branches... - I merged project/bob into project/alice. + Computing diff between branches... + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I merged scratch/bob into scratch/alice. ``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + ## Regression tests ### Delete one alias and update the other +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` -```unison +``` unison foo = 17 bar = 17 ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: bar : Nat foo : Nat - ``` -```ucm -project/main> add + +``` ucm +scratch/main> add ⍟ I've added these definitions: - + bar : Nat foo : Nat -project/main> branch alice +scratch/main> branch alice Done. I've created the alice branch based off of main. - + Tip: To merge your work back into the main branch, first `switch /main` then `merge /alice`. -project/alice> delete.term bar +scratch/alice> delete.term bar Done. - ``` -```unison + +``` unison foo = 18 ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These names already exist. You can `update` them to your new definition: foo : Nat - ``` -```ucm -project/alice> update + +``` ucm +scratch/alice> update Okay, I'm searching the branch for code that needs to be updated... Done. -project/main> branch bob +scratch/main> branch bob Done. I've created the bob branch based off of main. - + Tip: To merge your work back into the main branch, first `switch /main` then `merge /bob`. - ``` -```unison + +``` unison bob = 101 ``` -```ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: bob : Nat - ``` -```ucm -project/bob> add + +``` ucm +scratch/bob> add ⍟ I've added these definitions: - + bob : Nat +``` + +``` ucm +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I merged scratch/bob into scratch/alice. +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + +### Delete a constructor + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +type Foo = Bar | Baz +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo +``` + +``` ucm +scratch/main> add + ⍟ I've added these definitions: + + type Foo + +scratch/main> branch topic + + Done. I've created the topic branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /topic`. +``` + +``` unison +boop = "boop" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + boop : Text +``` + +``` ucm +scratch/topic> add + + ⍟ I've added these definitions: + + boop : Text +``` + +``` unison +type Foo = Bar ``` -```ucm -project/alice> merge /bob - I merged project/bob into project/alice. +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Foo +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +``` ucm +scratch/main> merge topic + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I merged scratch/topic into scratch/main. + +scratch/main> view Foo + + type Foo = Bar +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + +### Dependent that doesn't need to be in the file + +This test demonstrates a bug. + +``` ucm :hide +scratch/alice> builtins.mergeio lib.builtins +``` + +In the LCA, we have `foo` with dependent `bar`, and `baz`. + +``` unison +foo : Nat +foo = 17 + +bar : Nat +bar = foo + foo + +baz : Text +baz = "lca" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + baz : Text + foo : Nat +``` + +``` ucm +scratch/alice> add + + ⍟ I've added these definitions: + + bar : Nat + baz : Text + foo : Nat + +scratch/alice> branch bob + + Done. I've created the bob branch based off of alice. + + Tip: To merge your work back into the alice branch, first + `switch /alice` then `merge /bob`. +``` + +On Bob, we update `baz` to "bob". + +``` unison +baz : Text +baz = "bob" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + baz : Text +``` + +``` ucm +scratch/bob> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +On Alice, we update `baz` to "alice" (conflict), but also update `foo` (unconflicted), which propagates to `bar`. + +``` unison +foo : Nat +foo = 18 + +baz : Text +baz = "alice" +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + baz : Text + foo : Nat +``` + +``` ucm +scratch/alice> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. +``` + +When we try to merge Bob into Alice, we should see both versions of `baz`, with Alice's unconflicted `foo` and `bar` in +the underlying namespace. + +``` ucm :error +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. + However, I've added the definitions that need attention to the + top of scratch.u. + + When you're done, you can run + + merge.commit + + to merge your changes back into alice and delete the temporary + branch. Or, if you decide to cancel the merge instead, you can + run + + delete.branch /merge-bob-into-alice + + to delete the temporary branch and switch back to alice. +``` + +``` unison :added-by-ucm scratch.u +-- scratch/alice +baz : Text +baz = "alice" + +-- scratch/bob +baz : Text +baz = "bob" + +-- The definitions below are not conflicted, but they each depend on one or more +-- conflicted definitions above. + +bar : Nat +bar = + use Nat + + foo + foo + +``` + +But `bar` was put into the scratch file instead. + +``` ucm :hide +scratch/main> project.delete scratch +``` + +### Merge loop test + +This tests for regressions of https://github.com/unisonweb/unison/issues/1276 where trivial merges cause loops in the +history. + +Let's make three identical namespaces with different histories: + +``` unison +a = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + a : ##Nat +``` + +``` ucm +scratch/alice> add + + ⍟ I've added these definitions: + + a : ##Nat +``` + +``` unison +b = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + b : ##Nat +``` + +``` ucm +scratch/alice> add + + ⍟ I've added these definitions: + + b : ##Nat +``` + +``` unison +b = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked the definitions in scratch.u. This + file has been previously added to the codebase. +``` + +``` ucm +scratch/bob> add + + ⍟ I've added these definitions: + + b : ##Nat +``` + +``` unison +a = 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + a : ##Nat +``` + +``` ucm +scratch/bob> add + + ⍟ I've added these definitions: + + a : ##Nat +``` + +``` unison +a = 1 +b = 2 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked the definitions in scratch.u. This + file has been previously added to the codebase. +``` + +``` ucm +scratch/carol> add + + ⍟ I've added these definitions: + + a : ##Nat + b : ##Nat + +scratch/bob> merge /alice + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I merged scratch/alice into scratch/bob. + +scratch/carol> merge /bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I merged scratch/bob into scratch/carol. + +scratch/carol> history + + Note: The most recent namespace hash is immediately below this + message. + + + + This segment of history starts with a merge. Use + `history #som3n4m3space` to view history starting from a given + namespace hash. + + ⊙ 1. #b7fr6ifj87 + ⑃ + 2. #9npggauqo9 + 3. #dm4u1eokg1 +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + +### Variables named `_` + +This test demonstrates a change in syntactic hashing that fixed a bug due to auto-generated variable names for ignored +results. + +``` ucm :hide +scratch/alice> builtins.mergeio lib.builtins +``` + +``` unison +ignore : a -> () +ignore _ = () + +foo : Nat +foo = 18 + +bar : Nat +bar = + ignore "hi" + foo + foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + foo : Nat + ignore : a -> () +``` + +``` ucm +scratch/alice> add + + ⍟ I've added these definitions: + + bar : Nat + foo : Nat + ignore : a -> () + +scratch/alice> branch bob + + Done. I've created the bob branch based off of alice. + + Tip: To merge your work back into the alice branch, first + `switch /alice` then `merge /bob`. +``` + +``` unison +bar : Nat +bar = + ignore "hi" + foo + foo + foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + bar : Nat +``` + +``` ucm +scratch/bob> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +Previously, this update to `foo` would also cause a "real update" on `bar`, its dependent. Now it doesn't, so the merge +will succeed. + +``` unison +foo : Nat +foo = 19 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + foo : Nat +``` + +``` ucm +scratch/alice> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. +``` + +``` ucm +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + Typechecking Unison file... + + I merged scratch/bob into scratch/alice. +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + +### Unique type GUID reuse + +Previously, a merge branch would not include any dependents in the namespace, but that resulted in dependent unique +types' GUIDs being regenerated. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +type Foo = Lca +type Bar = MkBar Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Bar + type Foo +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Bar + type Foo + +scratch/main> branch alice + + Done. I've created the alice branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /alice`. + +scratch/alice> move.term Foo.Lca Foo.Alice + + Done. + +scratch/main> branch bob + + Done. I've created the bob branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /bob`. + +scratch/bob> move.term Foo.Lca Foo.Bob + + Done. +``` + +``` ucm :error +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. + However, I've added the definitions that need attention to the + top of scratch.u. + + When you're done, you can run + + merge.commit + + to merge your changes back into alice and delete the temporary + branch. Or, if you decide to cancel the merge instead, you can + run + + delete.branch /merge-bob-into-alice + + to delete the temporary branch and switch back to alice. +``` + +``` unison :added-by-ucm scratch.u +-- scratch/alice +type Foo + = Alice + +-- scratch/bob +type Foo + = Bob + +-- The definitions below are not conflicted, but they each depend on one or more +-- conflicted definitions above. + +type Bar + = MkBar Foo + +``` + +``` ucm +``` + +``` unison +type Foo = Merged +type Bar = MkBar Foo +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked the definitions in scratch.u. This + file has been previously added to the codebase. +``` + +``` ucm +scratch/merge-bob-into-alice> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/merge-bob-into-alice> names Bar + + Type + Hash: #h3af39sae7 + Names: Bar + +scratch/alice> names Bar + + Type + Hash: #h3af39sae7 + Names: Bar +``` + +``` ucm :hide +scratch/main> project.delete scratch +``` + +### Using Alice's names for Bob's things + +Previously, we'd render Alice's stuff with her names and Bob's stuff with his. But because Alice is doing the merge, +we now use her names whenever possible. In this example, Alice calls something `foo` and Bob calls it `bar`. When +rendering conflicts, in Bob's term that references (what he calls) `bar`, we render `foo` instead. + +``` ucm :hide +scratch/main> builtins.mergeio lib.builtins +``` + +``` unison +hello = 17 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + hello : Nat +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + hello : Nat + +scratch/main> branch alice + + Done. I've created the alice branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /alice`. +``` + +``` unison +hello = 18 + foo +foo = 100 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + hello : Nat +``` + +``` ucm +scratch/alice> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> branch bob + + Done. I've created the bob branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /bob`. +``` + +``` unison +hello = 19 + bar +bar = 100 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bar : Nat + + ⍟ These names already exist. You can `update` them to your + new definition: + + hello : Nat +``` + +``` ucm +scratch/bob> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +Note Bob's `hello` references `foo` (Alice's name), not `bar` (Bob's name). + +``` ucm :error +scratch/alice> merge /bob + + Loading branches... + + Computing diff between branches... + + Loading dependents of changes... + + Loading and merging library dependencies... + + Rendering Unison file... + + I couldn't automatically merge scratch/bob into scratch/alice. + However, I've added the definitions that need attention to the + top of scratch.u. + + When you're done, you can run + + merge.commit + + to merge your changes back into alice and delete the temporary + branch. Or, if you decide to cancel the merge instead, you can + run + + delete.branch /merge-bob-into-alice + + to delete the temporary branch and switch back to alice. +``` + +``` unison :added-by-ucm scratch.u +-- scratch/alice +hello : Nat +hello = + use Nat + + 18 + foo + +-- scratch/bob +hello : Nat +hello = + use Nat + + 19 + foo + +``` +``` ucm :hide +scratch/main> project.delete scratch ``` diff --git a/unison-src/transcripts/mergeloop.md b/unison-src/transcripts/mergeloop.md deleted file mode 100644 index fd1b25fa8e..0000000000 --- a/unison-src/transcripts/mergeloop.md +++ /dev/null @@ -1,51 +0,0 @@ -# Merge loop test - -This tests for regressions of https://github.com/unisonweb/unison/issues/1276 where trivial merges cause loops in the history. - -Let's make three identical namespaces with different histories: - -```unison -a = 1 -``` - -```ucm -.x> add -``` - -```unison -b = 2 -``` - -```ucm -.x> add -``` - -```unison -b = 2 -``` - -```ucm -.y> add -``` - -```unison -a = 1 -``` - -```ucm -.y> add -``` - -```unison -a = 1 -b = 2 -``` - -```ucm -.z> add -.> merge.old x y -.> merge.old y z -.> history z -``` - - diff --git a/unison-src/transcripts/mergeloop.output.md b/unison-src/transcripts/mergeloop.output.md deleted file mode 100644 index faa084764b..0000000000 --- a/unison-src/transcripts/mergeloop.output.md +++ /dev/null @@ -1,157 +0,0 @@ -# Merge loop test - -This tests for regressions of https://github.com/unisonweb/unison/issues/1276 where trivial merges cause loops in the history. - -Let's make three identical namespaces with different histories: - -```unison -a = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - a : ##Nat - -``` -```ucm - ☝️ The namespace .x is empty. - -.x> add - - ⍟ I've added these definitions: - - a : ##Nat - -``` -```unison -b = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - b : ##Nat - -``` -```ucm -.x> add - - ⍟ I've added these definitions: - - b : ##Nat - -``` -```unison -b = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked the definitions in scratch.u. This - file has been previously added to the codebase. - -``` -```ucm - ☝️ The namespace .y is empty. - -.y> add - - ⍟ I've added these definitions: - - b : ##Nat - -``` -```unison -a = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - a : ##Nat - -``` -```ucm -.y> add - - ⍟ I've added these definitions: - - a : ##Nat - -``` -```unison -a = 1 -b = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked the definitions in scratch.u. This - file has been previously added to the codebase. - -``` -```ucm - ☝️ The namespace .z is empty. - -.z> add - - ⍟ I've added these definitions: - - a : ##Nat - b : ##Nat - -.> merge.old x y - - Nothing changed as a result of the merge. - - Applying changes from patch... - -.> merge.old y z - - Nothing changed as a result of the merge. - - Applying changes from patch... - -.> history z - - Note: The most recent namespace hash is immediately below this - message. - - - - This segment of history starts with a merge. Use - `history #som3n4m3space` to view history starting from a given - namespace hash. - - ⊙ 1. #b7fr6ifj87 - ⑃ - 2. #9npggauqo9 - 3. #dm4u1eokg1 - -``` diff --git a/unison-src/transcripts/merges.md b/unison-src/transcripts/merges.md deleted file mode 100644 index 330e46857b..0000000000 --- a/unison-src/transcripts/merges.md +++ /dev/null @@ -1,121 +0,0 @@ -# Forking and merging namespaces in `ucm` - -```ucm:hide -.master> builtins.merge -``` - -The Unison namespace is a versioned tree of names that map to Unison definitions. You can change this namespace and fork and merge subtrees of it. Let's start by introducing a few definitions into a new namespace, `foo`: - -```unison -x = 42 -``` - -```ucm -.> add -``` - -Let's move `x` into a new namespace, `master`: - -```ucm -.> rename.term x master.x -``` - -If you want to do some experimental work in a namespace without disturbing anyone else, you can `fork` it (which is a shorthand for `copy.namespace`). This creates a copy of it, preserving its history. - -> __Note:__ these copies are very efficient to create as they just have pointers into the same underlying definitions. Create as many as you like. - -Let's go ahead and do this: - -``` -.> fork master feature1 -.> view master.x -.> view feature1.x -``` - -Great! We can now do some further work in the `feature1` branch, then merge it back into `master` when we're ready. - -```unison -y = "hello" -``` - -```ucm -.feature1> add -.master> merge.old .feature1 -.master> view y -``` - -> Note: `merge src`, with one argument, merges `src` into the current namespace. You can also do `merge src dest` to merge into any destination namespace. - -Notice that `master` now has the definition of `y` we wrote. - -We can also delete the fork if we're done with it. (Don't worry, even though the history at that path is now empty, -it's still in the `history` of the parent namespace and can be resurrected at any time.) - -```ucm -.> delete.namespace feature1 -.> history .feature1 -.> history -``` - -To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. - -## Concurrent edits and merges - -In the above scenario the destination namespace (`master`) was strictly behind the source namespace, so the merge didn't have anything interesting to do (Git would call this a "fast forward" merge). In other cases, the source and destination namespaces will each have changes the other doesn't know about, and the merge needs to something more interesting. That's okay too, and Unison will merge those results, using a 3-way merge algorithm. - -> __Note:__ When merging nested namespaces, Unison actually uses a recursive 3-way merge, so it finds a different (and possibly closer) common ancestor at each level of the tree. - -Let's see how this works. We are going to create a copy of `master`, add and delete some definitions in `master` and in the fork, then merge. - -```ucm -.> fork master feature2 -``` - -Here's one fork, we add `z` and delete `x`: - -```unison -z = 99 -``` - -```ucm -.feature2> add -.feature2> delete.term.verbose x -``` - -And here's the other fork, where we update `y` and add a new definition, `frobnicate`: - -```unison -master.y = "updated y" -master.frobnicate n = n + 1 -``` - -```ucm -.> update -.> view master.y -.> view master.frobnicate -``` - -At this point, `master` and `feature2` both have some changes the other doesn't know about. Let's merge them. - -```ucm -.> merge.old feature2 master -``` - -Notice that `x` is deleted in the merged branch (it was deleted in `feature2` and untouched by `master`): - -```ucm:error -.> view master.x -``` - -And notice that `y` has the most recent value, and that `z` and `frobnicate` both exist as well: - -```ucm -.> view master.y -.> view master.z -.> view master.frobnicate -``` - -## FAQ - -* What happens if namespace1 deletes a name that namespace2 has updated? A: ??? -* ... diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md deleted file mode 100644 index 8bfbb170fb..0000000000 --- a/unison-src/transcripts/merges.output.md +++ /dev/null @@ -1,312 +0,0 @@ -# Forking and merging namespaces in `ucm` - -The Unison namespace is a versioned tree of names that map to Unison definitions. You can change this namespace and fork and merge subtrees of it. Let's start by introducing a few definitions into a new namespace, `foo`: - -```unison -x = 42 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - x : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - x : Nat - -``` -Let's move `x` into a new namespace, `master`: - -```ucm -.> rename.term x master.x - - Done. - -``` -If you want to do some experimental work in a namespace without disturbing anyone else, you can `fork` it (which is a shorthand for `copy.namespace`). This creates a copy of it, preserving its history. - -> __Note:__ these copies are very efficient to create as they just have pointers into the same underlying definitions. Create as many as you like. - -Let's go ahead and do this: - -``` -.> fork master feature1 -.> view master.x -.> view feature1.x - -``` - -Great! We can now do some further work in the `feature1` branch, then merge it back into `master` when we're ready. - -```unison -y = "hello" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - y : Text - -``` -```ucm - ☝️ The namespace .feature1 is empty. - -.feature1> add - - ⍟ I've added these definitions: - - y : ##Text - -.master> merge.old .feature1 - - Here's what's changed in the current namespace after the - merge: - - Added definitions: - - 1. y : Text - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.master> view y - - y : Text - y = "hello" - -``` -> Note: `merge src`, with one argument, merges `src` into the current namespace. You can also do `merge src dest` to merge into any destination namespace. - -Notice that `master` now has the definition of `y` we wrote. - -We can also delete the fork if we're done with it. (Don't worry, even though the history at that path is now empty, -it's still in the `history` of the parent namespace and can be resurrected at any time.) - -```ucm -.> delete.namespace feature1 - - Done. - -.> history .feature1 - - ☝️ The namespace .feature1 is empty. - -.> history - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #6j9omad7mv - - - Deletes: - - feature1.y - - ⊙ 2. #59u4sdgodu - - + Adds / updates: - - master.y - - = Copies: - - Original name New name(s) - feature1.y master.y - - ⊙ 3. #0je96at36h - - + Adds / updates: - - feature1.y - - ⊙ 4. #cnv4gjntbl - - > Moves: - - Original name New name - x master.x - - ⊙ 5. #tp0bn8ulih - - + Adds / updates: - - x - - □ 6. #cujaete914 (start of history) - -``` -To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. - -## Concurrent edits and merges - -In the above scenario the destination namespace (`master`) was strictly behind the source namespace, so the merge didn't have anything interesting to do (Git would call this a "fast forward" merge). In other cases, the source and destination namespaces will each have changes the other doesn't know about, and the merge needs to something more interesting. That's okay too, and Unison will merge those results, using a 3-way merge algorithm. - -> __Note:__ When merging nested namespaces, Unison actually uses a recursive 3-way merge, so it finds a different (and possibly closer) common ancestor at each level of the tree. - -Let's see how this works. We are going to create a copy of `master`, add and delete some definitions in `master` and in the fork, then merge. - -```ucm -.> fork master feature2 - - Done. - -``` -Here's one fork, we add `z` and delete `x`: - -```unison -z = 99 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - z : Nat - -``` -```ucm -.feature2> add - - ⍟ I've added these definitions: - - z : Nat - -.feature2> delete.term.verbose x - - Removed definitions: - - 1. x : Nat - - Tip: You can use `undo` or `reflog` to undo this change. - -``` -And here's the other fork, where we update `y` and add a new definition, `frobnicate`: - -```unison -master.y = "updated y" -master.frobnicate n = n + 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - master.frobnicate : Nat -> Nat - master.y : Text - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> view master.y - - master.y : Text - master.y = "updated y" - -.> view master.frobnicate - - master.frobnicate : Nat -> Nat - master.frobnicate n = - use Nat + - n + 1 - -``` -At this point, `master` and `feature2` both have some changes the other doesn't know about. Let's merge them. - -```ucm -.> merge.old feature2 master - - Here's what's changed in master after the merge: - - Added definitions: - - 1. z : Nat - - Removed definitions: - - 2. x : Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` -Notice that `x` is deleted in the merged branch (it was deleted in `feature2` and untouched by `master`): - -```ucm -.> view master.x - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - master.x - -``` -And notice that `y` has the most recent value, and that `z` and `frobnicate` both exist as well: - -```ucm -.> view master.y - - master.y : Text - master.y = "updated y" - -.> view master.z - - master.z : Nat - master.z = 99 - -.> view master.frobnicate - - master.frobnicate : Nat -> Nat - master.frobnicate n = - use Nat + - n + 1 - -``` -## FAQ - -* What happens if namespace1 deletes a name that namespace2 has updated? A: ??? -* ... diff --git a/unison-src/transcripts/move-all.md b/unison-src/transcripts/move-all.md deleted file mode 100644 index f3a4f5209c..0000000000 --- a/unison-src/transcripts/move-all.md +++ /dev/null @@ -1,71 +0,0 @@ -# Tests for `move` - -```ucm:hide -.> builtins.merge -``` - -## Happy Path - namespace, term, and type - -Create a term, type, and namespace with history - -```unison -Foo = 2 -unique type Foo = Foo -Foo.termInA = 1 -unique type Foo.T = T -``` - -```ucm -.> add -``` - -```unison -Foo.termInA = 2 -unique type Foo.T = T1 | T2 -``` - -```ucm -.> update -``` - -Should be able to move the term, type, and namespace, including its types, terms, and sub-namespaces. - -```ucm -.> move Foo Bar -.> ls -.> ls Bar -.> history Bar -``` - -## Happy Path - Just term - -```unison -bonk = 5 -``` - -```ucm -.z> builtins.merge -.z> add -.z> move bonk zonk -.z> ls -``` - -## Happy Path - Just namespace - -```unison -bonk.zonk = 5 -``` - -```ucm -.a> builtins.merge -.a> add -.a> move bonk zonk -.a> ls -.a> view zonk.zonk -``` - -## Sad Path - No term, type, or namespace named src - -```ucm:error -.> move doesntexist foo -``` diff --git a/unison-src/transcripts/move-all.output.md b/unison-src/transcripts/move-all.output.md deleted file mode 100644 index f5fefba061..0000000000 --- a/unison-src/transcripts/move-all.output.md +++ /dev/null @@ -1,209 +0,0 @@ -# Tests for `move` - -## Happy Path - namespace, term, and type - -Create a term, type, and namespace with history - -```unison -Foo = 2 -unique type Foo = Foo -Foo.termInA = 1 -unique type Foo.T = T -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - type Foo.T - Foo : Nat - Foo.termInA : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - type Foo.T - Foo : Nat - Foo.termInA : Nat - -``` -```unison -Foo.termInA = 2 -unique type Foo.T = T1 | T2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo.T - Foo.termInA : Nat - (also named Foo) - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -``` -Should be able to move the term, type, and namespace, including its types, terms, and sub-namespaces. - -```ucm -.> move Foo Bar - - Done. - -.> ls - - 1. Bar (Nat) - 2. Bar (type) - 3. Bar/ (4 terms, 1 type) - 4. builtin/ (469 terms, 74 types) - -.> ls Bar - - 1. Foo (Bar) - 2. T (type) - 3. T/ (2 terms) - 4. termInA (Nat) - -.> history Bar - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #o7vuviel4c - - + Adds / updates: - - T T.T1 T.T2 termInA - - - Deletes: - - T.T - - □ 2. #c5cggiaumo (start of history) - -``` -## Happy Path - Just term - -```unison -bonk = 5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bonk : Nat - -``` -```ucm - ☝️ The namespace .z is empty. - -.z> builtins.merge - - Done. - -.z> add - - ⍟ I've added these definitions: - - bonk : Nat - -.z> move bonk zonk - - Done. - -.z> ls - - 1. builtin/ (469 terms, 74 types) - 2. zonk (Nat) - -``` -## Happy Path - Just namespace - -```unison -bonk.zonk = 5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bonk.zonk : Nat - (also named zonk) - -``` -```ucm - ☝️ The namespace .a is empty. - -.a> builtins.merge - - Done. - -.a> add - - ⍟ I've added these definitions: - - bonk.zonk : Nat - -.a> move bonk zonk - - Done. - -.a> ls - - 1. builtin/ (469 terms, 74 types) - 2. zonk/ (1 term) - -.a> view zonk.zonk - - zonk.zonk : Nat - zonk.zonk = 5 - -``` -## Sad Path - No term, type, or namespace named src - -```ucm -.> move doesntexist foo - - ⚠️ - - There is no term, type, or namespace at doesntexist. - -``` diff --git a/unison-src/transcripts/move-namespace.md b/unison-src/transcripts/move-namespace.md deleted file mode 100644 index 15c66f74c2..0000000000 --- a/unison-src/transcripts/move-namespace.md +++ /dev/null @@ -1,132 +0,0 @@ -# Tests for `move.namespace` - -```ucm:hide -.happy> builtins.merge -.history> builtins.merge -.existing> builtins.merge -``` - -## Happy path - -Create a namespace and add some history to it - -```unison -a.termInA = 1 -unique type a.T = T -``` - -```ucm -.happy> add -``` - -```unison -a.termInA = 2 -unique type a.T = T1 | T2 -``` - -```ucm -.happy> update -``` - -Should be able to move the namespace, including its types, terms, and sub-namespaces. - -```ucm -.happy> move.namespace a b -.happy> ls b -.happy> history b -``` - - -## Namespace history - - -Create some namespaces and add some history to them - -```unison -a.termInA = 1 -b.termInB = 10 -``` - -```ucm -.history> add -``` - -```unison -a.termInA = 2 -b.termInB = 11 -``` - -```ucm -.history> update -``` - -Deleting a namespace should not leave behind any history, -if we move another to that location we expect the history to simply be the history -of the moved namespace. - -```ucm -.history> delete.namespace b -.history> move.namespace a b --- Should be the history from 'a' -.history> history b --- Should be empty -.history> history a -``` - - -## Moving over an existing branch - -Create some namespace and add some history to them - -```unison -a.termInA = 1 -b.termInB = 10 -``` - -```ucm -.existing> add -``` - -```unison -a.termInA = 2 -b.termInB = 11 -``` - -```ucm -.existing> update -.existing> move.namespace a b -``` - -## Moving the Root - -I should be able to move the root into a sub-namespace - -```ucm --- Should request confirmation -.> move.namespace . .root.at.path -.> move.namespace . .root.at.path -.> ls -.> history -``` - -```ucm -.> ls .root.at.path -.> history .root.at.path -``` - -I should be able to move a sub namespace _over_ the root. - -```ucm --- Should request confirmation -.> move.namespace .root.at.path.happy . -.> move.namespace .root.at.path.happy . -.> ls -.> history -``` - - -```ucm:error --- should be empty -.> ls .root.at.path.happy -.> history .root.at.path.happy -``` diff --git a/unison-src/transcripts/move-namespace.output.md b/unison-src/transcripts/move-namespace.output.md deleted file mode 100644 index 9b63baeb67..0000000000 --- a/unison-src/transcripts/move-namespace.output.md +++ /dev/null @@ -1,465 +0,0 @@ -# Tests for `move.namespace` - -## Happy path - -Create a namespace and add some history to it - -```unison -a.termInA = 1 -unique type a.T = T -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type a.T - a.termInA : Nat - -``` -```ucm -.happy> add - - ⍟ I've added these definitions: - - type a.T - a.termInA : Nat - -``` -```unison -a.termInA = 2 -unique type a.T = T1 | T2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type a.T - a.termInA : Nat - -``` -```ucm -.happy> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -``` -Should be able to move the namespace, including its types, terms, and sub-namespaces. - -```ucm -.happy> move.namespace a b - - Done. - -.happy> ls b - - 1. T (type) - 2. T/ (2 terms) - 3. termInA (Nat) - -.happy> history b - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #4j747vnmdk - - + Adds / updates: - - T T.T1 T.T2 termInA - - - Deletes: - - T.T - - □ 2. #r71j4144fe (start of history) - -``` -## Namespace history - - -Create some namespaces and add some history to them - -```unison -a.termInA = 1 -b.termInB = 10 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - a.termInA : Nat - b.termInB : Nat - -``` -```ucm -.history> add - - ⍟ I've added these definitions: - - a.termInA : Nat - b.termInB : Nat - -``` -```unison -a.termInA = 2 -b.termInB = 11 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - a.termInA : Nat - b.termInB : Nat - -``` -```ucm -.history> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -``` -Deleting a namespace should not leave behind any history, -if we move another to that location we expect the history to simply be the history -of the moved namespace. - -```ucm -.history> delete.namespace b - - Done. - -.history> move.namespace a b - - Done. - --- Should be the history from 'a' -.history> history b - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #j0cjjqepb3 - - + Adds / updates: - - termInA - - □ 2. #m8smmmgjso (start of history) - --- Should be empty -.history> history a - - ☝️ The namespace .history.a is empty. - -``` -## Moving over an existing branch - -Create some namespace and add some history to them - -```unison -a.termInA = 1 -b.termInB = 10 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - a.termInA : Nat - b.termInB : Nat - -``` -```ucm -.existing> add - - ⍟ I've added these definitions: - - a.termInA : Nat - b.termInB : Nat - -``` -```unison -a.termInA = 2 -b.termInB = 11 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - a.termInA : Nat - b.termInB : Nat - -``` -```ucm -.existing> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.existing> move.namespace a b - - ⚠️ - - A branch existed at the destination: b so I over-wrote it. - - Tip: You can use `undo` or `reflog` to undo this change. - - Done. - -``` -## Moving the Root - -I should be able to move the root into a sub-namespace - -```ucm --- Should request confirmation -.> move.namespace . .root.at.path - - ⚠️ - - Moves which affect the root branch cannot be undone, are you sure? - Re-run the same command to proceed. - -.> move.namespace . .root.at.path - - Done. - -.> ls - - 1. root/ (1412 terms, 223 types) - -.> history - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #o7cku9c0t9 (start of history) - -``` -```ucm -.> ls .root.at.path - - 1. existing/ (470 terms, 74 types) - 2. happy/ (472 terms, 75 types) - 3. history/ (470 terms, 74 types) - -.> history .root.at.path - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #fv72cqfto4 - - - Deletes: - - existing.b.termInB - - > Moves: - - Original name New name - existing.a.termInA existing.b.termInA - - ⊙ 2. #12iqsb3l9g - - + Adds / updates: - - existing.a.termInA existing.b.termInB - - = Copies: - - Original name New name(s) - happy.b.termInA existing.a.termInA - history.b.termInA existing.a.termInA - - ⊙ 3. #r9jmgtco5u - - + Adds / updates: - - existing.a.termInA existing.b.termInB - - ⊙ 4. #1k6kae1vn4 - - > Moves: - - Original name New name - history.a.termInA history.b.termInA - - ⊙ 5. #ua9re7leg7 - - - Deletes: - - history.b.termInB - - ⊙ 6. #3k8ouql6cc - - + Adds / updates: - - history.a.termInA history.b.termInB - - = Copies: - - Original name New name(s) - happy.b.termInA history.a.termInA - - ⊙ 7. #fp2331i1ek - - + Adds / updates: - - history.a.termInA history.b.termInB - - ⊙ 8. #5sj5jefgcu - - > Moves: - - Original name New name - happy.a.T happy.b.T - happy.a.T.T1 happy.b.T.T1 - happy.a.T.T2 happy.b.T.T2 - happy.a.termInA happy.b.termInA - - ⊙ 9. #ell48pttus - - + Adds / updates: - - happy.a.T happy.a.T.T1 happy.a.T.T2 happy.a.termInA - - - Deletes: - - happy.a.T.T - - ⊙ 10. #al8eguoh70 - - + Adds / updates: - - happy.a.T happy.a.T.T happy.a.termInA - - There's more history before the versions shown here. Use - `history #som3n4m3space` to view history starting from a given - namespace hash. - - ⠇ - - ⊙ 11. #okceqk39nf - - -``` -I should be able to move a sub namespace _over_ the root. - -```ucm --- Should request confirmation -.> move.namespace .root.at.path.happy . - - ⚠️ - - Moves which affect the root branch cannot be undone, are you sure? - Re-run the same command to proceed. - -.> move.namespace .root.at.path.happy . - - Done. - -.> ls - - 1. b/ (3 terms, 1 type) - 2. builtin/ (469 terms, 74 types) - -.> history - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #0rvi5q5une - - + Adds / updates: - - b.T b.T.T1 b.T.T2 b.termInA - - ⊙ 2. #oaa8ltdusf - - - Deletes: - - a.T a.T.T1 a.T.T2 a.termInA - - ⊙ 3. #t1c91ou7ri - - + Adds / updates: - - a.T a.T.T1 a.T.T2 a.termInA - - - Deletes: - - a.T.T - - ⊙ 4. #hovh08jep4 - - + Adds / updates: - - a.T a.T.T a.termInA - - □ 5. #4bigcpnl7t (start of history) - -``` -```ucm --- should be empty -.> ls .root.at.path.happy - - nothing to show - -.> history .root.at.path.happy - - ☝️ The namespace .root.at.path.happy is empty. - -``` diff --git a/unison-src/transcripts/name-segment-escape.md b/unison-src/transcripts/name-segment-escape.md deleted file mode 100644 index a782953188..0000000000 --- a/unison-src/transcripts/name-segment-escape.md +++ /dev/null @@ -1,15 +0,0 @@ -You can use a keyword or reserved operator as a name segment if you surround it with backticks. - -```ucm:error -.> view `match` -.> view `=` -``` - -You can also use backticks to expand the set of valid symbols in a symboly name segment to include these three: `.()` - -This allows you to spell `.` or `()` as name segments (which historically have appeared in the namespace). - -```ucm:error -.> view `.` -.> view `()` -``` diff --git a/unison-src/transcripts/name-segment-escape.output.md b/unison-src/transcripts/name-segment-escape.output.md deleted file mode 100644 index 7eef020774..0000000000 --- a/unison-src/transcripts/name-segment-escape.output.md +++ /dev/null @@ -1,38 +0,0 @@ -You can use a keyword or reserved operator as a name segment if you surround it with backticks. - -```ucm -.> view `match` - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - `match` - -.> view `=` - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - `=` - -``` -You can also use backticks to expand the set of valid symbols in a symboly name segment to include these three: `.()` - -This allows you to spell `.` or `()` as name segments (which historically have appeared in the namespace). - -```ucm -.> view `.` - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - `.` - -.> view `()` - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - `()` - -``` diff --git a/unison-src/transcripts/name-selection.md b/unison-src/transcripts/name-selection.md deleted file mode 100644 index 992ee79491..0000000000 --- a/unison-src/transcripts/name-selection.md +++ /dev/null @@ -1,95 +0,0 @@ -This transcript shows how the pretty-printer picks names for a hash when multiple are available. The algorithm is: - -1. Names that are "name-only" come before names that are hash qualified. So `List.map` comes before `List.map#2384a` and also `aaaa#xyz`. -2. Shorter names (in terms of segment count) come before longer ones, for instance `base.List.map` comes before `somelibrary.external.base.List.map`. -3. Otherwise if there are multiple names with a minimal number of segments, compare the names alphabetically. - -```ucm:hide -.a> builtins.merge -.a2> builtins.merge -.a3> builtins.merge -.biasing> builtins.merge -``` - -```unison:hide -a = b + 1 -b = 0 + 1 -``` - -Will add `a` and `b` to the codebase and give `b` a longer (in terms of segment length alias), and show that it isn't used when viewing `a`: - -```ucm -.a> add -.a> alias.term b aaa.but.more.segments -.a> view a -``` - -Next let's introduce a conflicting symbol and show that its hash qualified name isn't used when it has an unconflicted name: - -``` -.> fork a a2 -.> fork a a3 -``` - -```unison:hide -c = 1 -d = c + 10 -``` - -```ucm:hide -.a2> builtins.merge -``` -```ucm -.a2> add -.a2> alias.term c long.name.but.shortest.suffixification -``` - -```unison:hide -c = 2 -d = c + 10 -``` - -```ucm -.a3> add -.a3> merge.old .a2 .a3 -``` - -At this point, `a3` is conflicted for symbols `c` and `d`, so those are deprioritized. -The original `a2` namespace has an unconflicted definition for `c` and `d`, but since there are multiple 'c's in scope, -`a2.c` is chosen because although the suffixified version has fewer segments, its fully-qualified name has the fewest segments. - -```ucm -.> view a b c d -``` - -## Name biasing - -```unison -deeply.nested.term = - a + 1 - -deeply.nested.num = 10 - -a = 10 -``` - -```ucm -.biasing> add --- Despite being saved with name `a`, --- the pretty printer should prefer the suffixified 'deeply.nested.num name' over the shallow 'a'. --- It's closer to the term being printed. -.biasing> view deeply.nested.term -``` - -Add another term with `num` suffix to force longer suffixification of `deeply.nested.num` - -```unison -other.num = 20 -``` - -```ucm -.biasing> add --- nested.num should be preferred over the shorter name `a` due to biasing --- because `deeply.nested.num` is nearby to the term being viewed. -.biasing> view deeply.nested.term -``` diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md deleted file mode 100644 index e124c18a20..0000000000 --- a/unison-src/transcripts/name-selection.output.md +++ /dev/null @@ -1,217 +0,0 @@ -This transcript shows how the pretty-printer picks names for a hash when multiple are available. The algorithm is: - -1. Names that are "name-only" come before names that are hash qualified. So `List.map` comes before `List.map#2384a` and also `aaaa#xyz`. -2. Shorter names (in terms of segment count) come before longer ones, for instance `base.List.map` comes before `somelibrary.external.base.List.map`. -3. Otherwise if there are multiple names with a minimal number of segments, compare the names alphabetically. - -```unison -a = b + 1 -b = 0 + 1 -``` - -Will add `a` and `b` to the codebase and give `b` a longer (in terms of segment length alias), and show that it isn't used when viewing `a`: - -```ucm -.a> add - - ⍟ I've added these definitions: - - a : Nat - b : Nat - -.a> alias.term b aaa.but.more.segments - - Done. - -.a> view a - - a : Nat - a = - use Nat + - b + 1 - -``` -Next let's introduce a conflicting symbol and show that its hash qualified name isn't used when it has an unconflicted name: - -``` -.> fork a a2 -.> fork a a3 - -``` - -```unison -c = 1 -d = c + 10 -``` - -```ucm -.a2> add - - ⍟ I've added these definitions: - - c : Nat - d : Nat - -.a2> alias.term c long.name.but.shortest.suffixification - - Done. - -``` -```unison -c = 2 -d = c + 10 -``` - -```ucm -.a3> add - - ⍟ I've added these definitions: - - c : Nat - d : Nat - -.a3> merge.old .a2 .a3 - - Here's what's changed in .a3 after the merge: - - New name conflicts: - - 1. c#dcgdua2lj6 : Nat - ↓ - 2. ┌ c#dcgdua2lj6 : Nat - 3. └ c#gjmq673r1v : Nat - - 4. d#9ivhgvhthc : Nat - ↓ - 5. ┌ d#9ivhgvhthc : Nat - 6. └ d#ve16e6jmf6 : Nat - - Added definitions: - - 7. ┌ c#gjmq673r1v : Nat - 8. └ long.name.but.shortest.suffixification : Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` -At this point, `a3` is conflicted for symbols `c` and `d`, so those are deprioritized. -The original `a2` namespace has an unconflicted definition for `c` and `d`, but since there are multiple 'c's in scope, -`a2.c` is chosen because although the suffixified version has fewer segments, its fully-qualified name has the fewest segments. - -```ucm -.> view a b c d - - a.a : Nat - a.a = - use Nat + - b + 1 - - a.b : Nat - a.b = - use Nat + - 0 + 1 - - a2.c : Nat - a2.c = 1 - - a2.d : Nat - a2.d = - use Nat + - a2.c + 10 - - a3.c#dcgdua2lj6 : Nat - a3.c#dcgdua2lj6 = 2 - - a3.d#9ivhgvhthc : Nat - a3.d#9ivhgvhthc = - use Nat + - c#dcgdua2lj6 + 10 - -``` -## Name biasing - -```unison -deeply.nested.term = - a + 1 - -deeply.nested.num = 10 - -a = 10 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - a : Nat - deeply.nested.num : Nat - deeply.nested.term : Nat - -``` -```ucm -.biasing> add - - ⍟ I've added these definitions: - - a : Nat - deeply.nested.num : Nat - deeply.nested.term : Nat - --- Despite being saved with name `a`, --- the pretty printer should prefer the suffixified 'deeply.nested.num name' over the shallow 'a'. --- It's closer to the term being printed. -.biasing> view deeply.nested.term - - deeply.nested.term : Nat - deeply.nested.term = - use Nat + - num + 1 - -``` -Add another term with `num` suffix to force longer suffixification of `deeply.nested.num` - -```unison -other.num = 20 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - other.num : Nat - -``` -```ucm -.biasing> add - - ⍟ I've added these definitions: - - other.num : Nat - --- nested.num should be preferred over the shorter name `a` due to biasing --- because `deeply.nested.num` is nearby to the term being viewed. -.biasing> view deeply.nested.term - - deeply.nested.term : Nat - deeply.nested.term = - use Nat + - nested.num + 1 - -``` diff --git a/unison-src/transcripts/names.md b/unison-src/transcripts/names.md deleted file mode 100644 index 6d395266c4..0000000000 --- a/unison-src/transcripts/names.md +++ /dev/null @@ -1,42 +0,0 @@ -# `names` command - -Example uses of the `names` command and output - -```unison --- Some names with the same value -some.place.x = 1 -some.otherplace.y = 1 -some.otherplace.x = 10 -somewhere.z = 1 --- Some similar name with a different value -somewhere.y = 2 -``` - -```ucm -.> add -``` - - -`names` searches relative to the current path. - -```ucm --- We can search by suffix and find all definitions named 'x', and each of their aliases respectively. --- But we don't see somewhere.z which is has the same value but is out of our namespace -.some> names x --- We can search by hash, and see all aliases of that hash -.some> names #gjmq673r1v --- If the query is absolute, treat it as a `names.global` -.some> names .some.place.x -``` - -`names.global` searches from the root, and absolutely qualifies results - - -```ucm --- We can search by suffix and find all definitions in the codebase named 'x', and each of their aliases respectively. -.some> names.global x --- We can search by hash, and see all aliases of that hash in the codebase -.some> names.global #gjmq673r1v --- We can search using an absolute name -.some> names.global .some.place.x -``` diff --git a/unison-src/transcripts/names.output.md b/unison-src/transcripts/names.output.md deleted file mode 100644 index 8138b5434d..0000000000 --- a/unison-src/transcripts/names.output.md +++ /dev/null @@ -1,107 +0,0 @@ -# `names` command - -Example uses of the `names` command and output - -```unison --- Some names with the same value -some.place.x = 1 -some.otherplace.y = 1 -some.otherplace.x = 10 -somewhere.z = 1 --- Some similar name with a different value -somewhere.y = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - some.otherplace.x : ##Nat - some.otherplace.y : ##Nat - some.place.x : ##Nat - somewhere.y : ##Nat - somewhere.z : ##Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - some.otherplace.x : ##Nat - some.otherplace.y : ##Nat - some.place.x : ##Nat - somewhere.y : ##Nat - somewhere.z : ##Nat - -``` -`names` searches relative to the current path. - -```ucm --- We can search by suffix and find all definitions named 'x', and each of their aliases respectively. --- But we don't see somewhere.z which is has the same value but is out of our namespace -.some> names x - - Terms - Hash: #gjmq673r1v - Names: otherplace.y place.x - - Hash: #pi25gcdv0o - Names: otherplace.x - - Tip: Use `names.global` to see more results. - --- We can search by hash, and see all aliases of that hash -.some> names #gjmq673r1v - - Term - Hash: #gjmq673r1v - Names: otherplace.y place.x - - Tip: Use `names.global` to see more results. - --- If the query is absolute, treat it as a `names.global` -.some> names .some.place.x - - Term - Hash: #gjmq673r1v - Names: .some.otherplace.y .some.place.x .somewhere.z - - Tip: Use `names.global` to see more results. - -``` -`names.global` searches from the root, and absolutely qualifies results - - -```ucm --- We can search by suffix and find all definitions in the codebase named 'x', and each of their aliases respectively. -.some> names.global x - - Terms - Hash: #gjmq673r1v - Names: .some.otherplace.y .some.place.x .somewhere.z - - Hash: #pi25gcdv0o - Names: .some.otherplace.x - --- We can search by hash, and see all aliases of that hash in the codebase -.some> names.global #gjmq673r1v - - Term - Hash: #gjmq673r1v - Names: .some.otherplace.y .some.place.x .somewhere.z - --- We can search using an absolute name -.some> names.global .some.place.x - - Term - Hash: #gjmq673r1v - Names: .some.otherplace.y .some.place.x .somewhere.z - -``` diff --git a/unison-src/transcripts/namespace-deletion-regression.md b/unison-src/transcripts/namespace-deletion-regression.md deleted file mode 100644 index d33a707100..0000000000 --- a/unison-src/transcripts/namespace-deletion-regression.md +++ /dev/null @@ -1,16 +0,0 @@ -# Namespace deletion regression test - -See https://github.com/unisonweb/unison/issues/1552 - -If branch operations aren't performed in the correct order it's possible to end up with unexpected results. - -Previously the following sequence delete the current namespace -unexpectedly 😬. - -```ucm -.> alias.term ##Nat.+ .Nat.+ -.> ls Nat -.> move.namespace Nat Nat.operators -.> ls Nat -.> ls Nat.operators -``` diff --git a/unison-src/transcripts/namespace-deletion-regression.output.md b/unison-src/transcripts/namespace-deletion-regression.output.md deleted file mode 100644 index 45af1bfcb3..0000000000 --- a/unison-src/transcripts/namespace-deletion-regression.output.md +++ /dev/null @@ -1,31 +0,0 @@ -# Namespace deletion regression test - -See https://github.com/unisonweb/unison/issues/1552 - -If branch operations aren't performed in the correct order it's possible to end up with unexpected results. - -Previously the following sequence delete the current namespace -unexpectedly 😬. - -```ucm -.> alias.term ##Nat.+ .Nat.+ - - Done. - -.> ls Nat - - 1. + (##Nat -> ##Nat -> ##Nat) - -.> move.namespace Nat Nat.operators - - Done. - -.> ls Nat - - 1. operators/ (1 term) - -.> ls Nat.operators - - 1. + (##Nat -> ##Nat -> ##Nat) - -``` diff --git a/unison-src/transcripts/no-hash-in-term-declaration.md b/unison-src/transcripts/no-hash-in-term-declaration.md index ac43b449ac..85ef6c0de2 100644 --- a/unison-src/transcripts/no-hash-in-term-declaration.md +++ b/unison-src/transcripts/no-hash-in-term-declaration.md @@ -2,7 +2,7 @@ There should not be hashes in the names used in term declarations, either in the type signature or the type definition. -```unison:hide:all:error +``` unison :hide-all :error x##Nat : Int -> Int -> Boolean x##Nat = 5 -``` \ No newline at end of file +``` diff --git a/unison-src/transcripts/no-hash-in-term-declaration.output.md b/unison-src/transcripts/no-hash-in-term-declaration.output.md index aa3dc9d9fc..a72d53344c 100644 --- a/unison-src/transcripts/no-hash-in-term-declaration.output.md +++ b/unison-src/transcripts/no-hash-in-term-declaration.output.md @@ -1,4 +1,3 @@ # No Hashes in Term Declarations There should not be hashes in the names used in term declarations, either in the type signature or the type definition. - diff --git a/unison-src/transcripts/numbered-args.md b/unison-src/transcripts/numbered-args.md deleted file mode 100644 index f421a67177..0000000000 --- a/unison-src/transcripts/numbered-args.md +++ /dev/null @@ -1,56 +0,0 @@ -# Using numbered arguments in UCM - -```ucm:hide -.temp> alias.type ##Text Text -``` - -First lets add some contents to our codebase. - -```unison -foo = "foo" -bar = "bar" -baz = "baz" -qux = "qux" -quux = "quux" -corge = "corge" -``` - -```ucm -.temp> add -``` - -We can get the list of things in the namespace, and UCM will give us a numbered -list: - -```ucm -.temp> find -``` - -We can ask to `view` the second element of this list: - -```ucm -.temp> find -.temp> view 2 -``` - -And we can `view` multiple elements by separating with spaces: - -```ucm -.temp> find -.temp> view 2 3 5 -``` - -We can also ask for a range: - -```ucm -.temp> find -.temp> view 2-4 -``` - -And we can ask for multiple ranges and use mix of ranges and numbers: - -```ucm -.temp> find -.temp> view 1-3 4 5-6 -``` - diff --git a/unison-src/transcripts/numbered-args.output.md b/unison-src/transcripts/numbered-args.output.md deleted file mode 100644 index b8dfce49f2..0000000000 --- a/unison-src/transcripts/numbered-args.output.md +++ /dev/null @@ -1,167 +0,0 @@ -# Using numbered arguments in UCM - -First lets add some contents to our codebase. - -```unison -foo = "foo" -bar = "bar" -baz = "baz" -qux = "qux" -quux = "quux" -corge = "corge" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bar : Text - baz : Text - corge : Text - foo : Text - quux : Text - qux : Text - -``` -```ucm -.temp> add - - ⍟ I've added these definitions: - - bar : Text - baz : Text - corge : Text - foo : Text - quux : Text - qux : Text - -``` -We can get the list of things in the namespace, and UCM will give us a numbered -list: - -```ucm -.temp> find - - 1. bar : Text - 2. baz : Text - 3. corge : Text - 4. foo : Text - 5. quux : Text - 6. qux : Text - 7. builtin type Text - - -``` -We can ask to `view` the second element of this list: - -```ucm -.temp> find - - 1. bar : Text - 2. baz : Text - 3. corge : Text - 4. foo : Text - 5. quux : Text - 6. qux : Text - 7. builtin type Text - - -.temp> view 2 - - baz : Text - baz = "baz" - -``` -And we can `view` multiple elements by separating with spaces: - -```ucm -.temp> find - - 1. bar : Text - 2. baz : Text - 3. corge : Text - 4. foo : Text - 5. quux : Text - 6. qux : Text - 7. builtin type Text - - -.temp> view 2 3 5 - - baz : Text - baz = "baz" - - corge : Text - corge = "corge" - - quux : Text - quux = "quux" - -``` -We can also ask for a range: - -```ucm -.temp> find - - 1. bar : Text - 2. baz : Text - 3. corge : Text - 4. foo : Text - 5. quux : Text - 6. qux : Text - 7. builtin type Text - - -.temp> view 2-4 - - baz : Text - baz = "baz" - - corge : Text - corge = "corge" - - foo : Text - foo = "foo" - -``` -And we can ask for multiple ranges and use mix of ranges and numbers: - -```ucm -.temp> find - - 1. bar : Text - 2. baz : Text - 3. corge : Text - 4. foo : Text - 5. quux : Text - 6. qux : Text - 7. builtin type Text - - -.temp> view 1-3 4 5-6 - - bar : Text - bar = "bar" - - baz : Text - baz = "baz" - - corge : Text - corge = "corge" - - foo : Text - foo = "foo" - - quux : Text - quux = "quux" - - qux : Text - qux = "qux" - -``` diff --git a/unison-src/transcripts/old-fold-right.md b/unison-src/transcripts/old-fold-right.md deleted file mode 100644 index f3c01d5d01..0000000000 --- a/unison-src/transcripts/old-fold-right.md +++ /dev/null @@ -1,17 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -```unison -oldRight: (b ->{e} a ->{e} b) -> [a] ->{e} [b] -oldRight f la = bug "out" - -pecan: '{} [Text] -pecan = 'let - la = [1, 2, 3] - f: Text -> Nat -> Text - f = bug "out" - - oldRight f la -``` - diff --git a/unison-src/transcripts/old-fold-right.output.md b/unison-src/transcripts/old-fold-right.output.md deleted file mode 100644 index 4f210513b9..0000000000 --- a/unison-src/transcripts/old-fold-right.output.md +++ /dev/null @@ -1,27 +0,0 @@ -```unison -oldRight: (b ->{e} a ->{e} b) -> [a] ->{e} [b] -oldRight f la = bug "out" - -pecan: '{} [Text] -pecan = 'let - la = [1, 2, 3] - f: Text -> Nat -> Text - f = bug "out" - - oldRight f la -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - oldRight : (b ->{e} a ->{e} b) -> [a] ->{e} [b] - pecan : '[Text] - -``` diff --git a/unison-src/transcripts/pattern-match-coverage.md b/unison-src/transcripts/pattern-match-coverage.md deleted file mode 100644 index 8c35e07d55..0000000000 --- a/unison-src/transcripts/pattern-match-coverage.md +++ /dev/null @@ -1,621 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -# Basics -## non-exhaustive patterns -```unison:error -unique type T = A | B | C - -test : T -> () -test = cases - A -> () -``` - -```unison:error -unique type T = A | B - -test : (T, Optional T) -> () -test = cases - (A, Some _) -> () - (A, None) -> () - (B, Some A) -> () - (B, None) -> () -``` - -## redundant patterns -```unison:error -unique type T = A | B | C - -test : T -> () -test = cases - A -> () - B -> () - C -> () - _ -> () -``` - -```unison:error -unique type T = A | B - -test : (T, Optional T) -> () -test = cases - (A, Some _) -> () - (A, None) -> () - (B, Some _) -> () - (B, None) -> () - (A, Some A) -> () -``` - -# Uninhabited patterns - -match is complete without covering uninhabited patterns -```unison -unique type V = - -test : Optional (Optional V) -> () -test = cases - None -> () - Some None -> () -``` - -uninhabited patterns are reported as redundant -```unison:error -unique type V = - -test0 : V -> () -test0 = cases - _ -> () -``` - -```unison:error -unique type V = - -test : Optional (Optional V) -> () -test = cases - None -> () - Some None -> () - Some _ -> () -``` - -# Guards - -## Incomplete patterns due to guards should be reported -```unison:error -test : () -> () -test = cases - () | false -> () -``` - -```unison:error -test : Optional Nat -> Nat -test = cases - None -> 0 - Some x - | isEven x -> x -``` - -## Complete patterns with guards should be accepted -```unison:error -test : Optional Nat -> Nat -test = cases - None -> 0 - Some x - | isEven x -> x - | otherwise -> 0 -``` - -# Pattern instantiation depth - -Uncovered patterns are only instantiated as deeply as necessary to -distinguish them from existing patterns. -```unison:error -unique type T = A | B | C - -test : Optional (Optional T) -> () -test = cases - None -> () - Some None -> () -``` - -```unison:error -unique type T = A | B | C - -test : Optional (Optional T) -> () -test = cases - None -> () - Some None -> () - Some (Some A) -> () -``` - -# Literals - -## Non-exhaustive - -Nat -```unison:error -test : Nat -> () -test = cases - 0 -> () -``` - -Boolean -```unison:error -test : Boolean -> () -test = cases - true -> () -``` - -## Exhaustive - -Nat -```unison -test : Nat -> () -test = cases - 0 -> () - _ -> () -``` - -Boolean -```unison -test : Boolean -> () -test = cases - true -> () - false -> () -``` - -# Redundant - -Nat -```unison:error -test : Nat -> () -test = cases - 0 -> () - 0 -> () - _ -> () -``` - -Boolean -```unison:error -test : Boolean -> () -test = cases - true -> () - false -> () - _ -> () -``` - -# Sequences - -## Exhaustive -```unison -test : [()] -> () -test = cases - [] -> () - x +: xs -> () -``` - -## Non-exhaustive -```unison:error -test : [()] -> () -test = cases - [] -> () -``` - -```unison:error -test : [()] -> () -test = cases - x +: xs -> () -``` - -```unison:error -test : [()] -> () -test = cases - xs :+ x -> () -``` - -```unison:error -test : [()] -> () -test = cases - x0 +: (x1 +: xs) -> () - [] -> () -``` - -```unison:error -test : [()] -> () -test = cases - [] -> () - x0 +: [] -> () -``` - -## Uninhabited - -`Cons` is not expected since `V` is uninhabited -```unison -unique type V = - -test : [V] -> () -test = cases - [] -> () -``` - -## Length restrictions can equate cons and nil patterns - -Here the first pattern matches lists of length two or greater, the -second pattern matches lists of length 0. The third case matches when the -final element is `false`, while the fourth pattern matches when the -first element is `true`. However, the only possible list length at -the third or fourth clause is 1, so the first and final element must -be equal. Thus, the pattern match is exhaustive. -```unison -test : [Boolean] -> () -test = cases - [a, b] ++ xs -> () - [] -> () - xs :+ false -> () - true +: xs -> () -``` - -This is the same idea as above but shows that fourth match is redundant. -```unison:error -test : [Boolean] -> () -test = cases - [a, b] ++ xs -> () - [] -> () - xs :+ true -> () - true +: xs -> () - _ -> () -``` - -This is another similar example. The first pattern matches lists of -length 5 or greater. The second matches lists of length 4 or greater where the -first and third element are true. The third matches lists of length 4 -or greater where the final 4 elements are `true, false, true, false`. -The list must be exactly of length 4 to arrive at the second or third -clause, so the third pattern is redundant. -```unison:error -test : [Boolean] -> () -test = cases - [a, b, c, d, f] ++ xs -> () - [true, _, true, _] ++ _ -> () - _ ++ [true, false, true, false] -> () - _ -> () -``` - -# bugfix: Sufficient data decl map - -```unison -unique type T = A - -unit2t : Unit -> T -unit2t = cases - () -> A -``` - -```ucm -.> add -``` - -Pattern coverage checking needs the data decl map to contain all -transitive type dependencies of the scrutinee type. We do this -before typechecking begins in a roundabout way: fetching all -transitive type dependencies of references that appear in the expression. - -This test ensures that we have fetched the `T` type although there is -no data decl reference to `T` in `witht`. -```unison -witht : Unit -witht = match unit2t () with - x -> () -``` - -```unison -unique type V = - -evil : Unit -> V -evil = bug "" -``` - -```ucm -.> add -``` - -```unison:error -withV : Unit -withV = match evil () with - x -> () -``` - -```unison -unique type SomeType = A -``` - -```ucm -.> add -``` - -```unison -unique type R = R SomeType - -get x = match x with - R y -> y -``` - -```unison -unique type R = { someType : SomeType } -``` - -# Ability handlers - -## Exhaustive ability handlers are accepted - -```unison -structural ability Abort where - abort : {Abort} a - - -result : '{e, Abort} a -> {e} a -result f = handle !f with cases - { x } -> x - { abort -> _ } -> bug "aborted" -``` - -```unison -structural ability Abort where - abort : {Abort} a - -unique type T = A | B - -result : '{e, Abort} T -> {e} () -result f = handle !f with cases - { A } -> () - { B } -> () - { abort -> _ } -> bug "aborted" -``` - -```unison -structural ability Abort where - abort : {Abort} a - -result : '{e, Abort} V -> {e} V -result f = - impl : Request {Abort} V -> V - impl = cases - { abort -> _ } -> bug "aborted" - handle !f with impl -``` - -```unison -structural ability Abort where - abort : {Abort} a - -structural ability Stream a where - emit : a -> {Stream a} Unit - -handleMulti : '{Stream a, Abort} r -> (Optional r, [a]) -handleMulti c = - impl xs = cases - { r } -> (Some r, xs) - { emit x -> resume } -> handle !resume with impl (xs :+ x) - { abort -> _ } -> (None, xs) - handle !c with impl [] -``` - -## Non-exhaustive ability handlers are rejected - -```unison:error -structural ability Abort where - abort : {Abort} a - abortWithMessage : Text -> {Abort} a - - -result : '{e, Abort} a -> {e} a -result f = handle !f with cases - { abort -> _ } -> bug "aborted" -``` - -```unison:error -structural ability Abort where - abort : {Abort} a - -unique type T = A | B - -result : '{e, Abort} T -> {e} () -result f = handle !f with cases - { A } -> () - { abort -> _ } -> bug "aborted" -``` - -```unison:error -unique ability Give a where - give : a -> {Give a} Unit - -unique type T = A | B - -result : '{e, Give T} r -> {e} r -result f = handle !f with cases - { x } -> x - { give A -> resume } -> result resume -``` - -```unison:error -structural ability Abort where - abort : {Abort} a - -structural ability Stream a where - emit : a -> {Stream a} Unit - -handleMulti : '{Stream a, Abort} r -> (Optional r, [a]) -handleMulti c = - impl : [a] -> Request {Stream a, Abort} r -> (Optional r, [a]) - impl xs = cases - { r } -> (Some r, xs) - { emit x -> resume } -> handle !resume with impl (xs :+ x) - handle !c with impl [] -``` - -## Redundant handler cases are rejected - -```unison:error -unique ability Give a where - give : a -> {Give a} Unit - -unique type T = A | B - -result : '{e, Give T} r -> {e} r -result f = handle !f with cases - { x } -> x - { give _ -> resume } -> result resume - { give A -> resume } -> result resume -``` - -## Exhaustive ability reinterpretations are accepted - -```unison -structural ability Abort where - abort : {Abort} a - abortWithMessage : Text -> {Abort} a - - -result : '{e, Abort} a -> {e, Abort} a -result f = handle !f with cases - { x } -> x - { abort -> _ } -> abort - { abortWithMessage msg -> _ } -> abortWithMessage ("aborting: " ++ msg) -``` - -```unison -structural ability Abort a where - abort : {Abort a} r - abortWithMessage : a -> {Abort a} r - -result : '{e, Abort V} a -> {e, Abort V} a -result f = - impl : Request {Abort V} r -> {Abort V} r - impl = cases - { x } -> x - { abort -> _ } -> abort - handle !f with impl -``` - -## Non-exhaustive ability reinterpretations are rejected - -```unison:error -structural ability Abort where - abort : {Abort} a - abortWithMessage : Text -> {Abort} a - - -result : '{e, Abort} a -> {e, Abort} a -result f = handle !f with cases - { x } -> x - { abortWithMessage msg -> _ } -> abortWithMessage ("aborting: " ++ msg) -``` - -## Hacky workaround for uninhabited abilities - -Although all of the constructors of an ability might be uninhabited, -the typechecker requires at least one be specified so that it can -determine that the ability should be discharged. So, the default -pattern match coverage checking behavior of prohibiting covering any -of the cases is problematic. Instead, the pattern match coverage -checker will require that at least one constructor be given, even if -they are all uninhabited. - -The messages here aren't the best, but I don't think uninhabited -abilities will come up and get handlers written for them often. - -```unison:error -unique ability Give a where - give : a -> {Give a} Unit - give2 : a -> {Give a} Unit - -result : '{e, Give V} r -> {e} r -result f = - impl : Request {Give V} r -> {} r - impl = cases - { x } -> x - handle !f with impl -``` - -```unison -unique ability Give a where - give : a -> {Give a} Unit - give2 : a -> {Give a} Unit - -result : '{e, Give V} r -> {e} r -result f = - impl : Request {Give V} r -> {} r - impl = cases - { x } -> x - { give _ -> resume } -> bug "impossible" - handle !f with impl -``` - -```unison -unique ability Give a where - give : a -> {Give a} Unit - give2 : a -> {Give a} Unit - -result : '{e, Give V} r -> {e} r -result f = - impl : Request {Give V} r -> {} r - impl = cases - { x } -> x - { give2 _ -> resume } -> bug "impossible" - handle !f with impl -``` - -```unison:error -unique ability Give a where - give : a -> {Give a} Unit - give2 : a -> {Give a} Unit - -result : '{e, Give V} r -> {e} r -result f = - impl : Request {Give V} r -> {} r - impl = cases - { x } -> x - { give _ -> resume } -> bug "impossible" - { give2 _ -> resume } -> bug "impossible" - handle !f with impl -``` - -```unison:error -unique ability GiveA a where - giveA : a -> {GiveA a} Unit - giveA2 : a -> {GiveA a} Unit - -unique ability GiveB a where - giveB : a -> {GiveB a} Unit - giveB2 : a -> {GiveB a} Unit - -result : '{e, GiveA V, GiveB V} r -> {e} r -result f = - impl : Request {GiveA V, GiveB V} r -> {} r - impl = cases - { x } -> x - { giveA _ -> _ } -> bug "impossible" - { giveA2 _ -> _ } -> bug "impossible" - { giveB _ -> _ } -> bug "impossible" - { giveB2 _ -> _ } -> bug "impossible" - handle !f with impl -``` - -```unison -unique ability GiveA a where - giveA : a -> {GiveA a} Unit - giveA2 : a -> {GiveA a} Unit - -unique ability GiveB a where - giveB : a -> {GiveB a} Unit - giveB2 : a -> {GiveB a} Unit - -result : '{e, GiveA V, GiveB V} r -> {e} r -result f = - impl : Request {GiveA V, GiveB V} r -> {} r - impl = cases - { x } -> x - { giveA2 _ -> _ } -> bug "impossible" - { giveB _ -> _ } -> bug "impossible" - handle !f with impl -``` diff --git a/unison-src/transcripts/pattern-match-coverage.output.md b/unison-src/transcripts/pattern-match-coverage.output.md deleted file mode 100644 index 0a0b290c99..0000000000 --- a/unison-src/transcripts/pattern-match-coverage.output.md +++ /dev/null @@ -1,1319 +0,0 @@ -# Basics -## non-exhaustive patterns -```unison -unique type T = A | B | C - -test : T -> () -test = cases - A -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 4 | test = cases - 5 | A -> () - - - Patterns not matched: - - * B - * C - -``` -```unison -unique type T = A | B - -test : (T, Optional T) -> () -test = cases - (A, Some _) -> () - (A, None) -> () - (B, Some A) -> () - (B, None) -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 4 | test = cases - 5 | (A, Some _) -> () - 6 | (A, None) -> () - 7 | (B, Some A) -> () - 8 | (B, None) -> () - - - Patterns not matched: - * (B, Some B) - -``` -## redundant patterns -```unison -unique type T = A | B | C - -test : T -> () -test = cases - A -> () - B -> () - C -> () - _ -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - This case would be ignored because it's already covered by the preceding case(s): - 8 | _ -> () - - -``` -```unison -unique type T = A | B - -test : (T, Optional T) -> () -test = cases - (A, Some _) -> () - (A, None) -> () - (B, Some _) -> () - (B, None) -> () - (A, Some A) -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - This case would be ignored because it's already covered by the preceding case(s): - 9 | (A, Some A) -> () - - -``` -# Uninhabited patterns - -match is complete without covering uninhabited patterns -```unison -unique type V = - -test : Optional (Optional V) -> () -test = cases - None -> () - Some None -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type V - test : Optional (Optional V) -> () - -``` -uninhabited patterns are reported as redundant -```unison -unique type V = - -test0 : V -> () -test0 = cases - _ -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - This case would be ignored because it's already covered by the preceding case(s): - 5 | _ -> () - - -``` -```unison -unique type V = - -test : Optional (Optional V) -> () -test = cases - None -> () - Some None -> () - Some _ -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - This case would be ignored because it's already covered by the preceding case(s): - 7 | Some _ -> () - - -``` -# Guards - -## Incomplete patterns due to guards should be reported -```unison -test : () -> () -test = cases - () | false -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 2 | test = cases - 3 | () | false -> () - - - Patterns not matched: - * () - -``` -```unison -test : Optional Nat -> Nat -test = cases - None -> 0 - Some x - | isEven x -> x -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 2 | test = cases - 3 | None -> 0 - 4 | Some x - 5 | | isEven x -> x - - - Patterns not matched: - * Some _ - -``` -## Complete patterns with guards should be accepted -```unison -test : Optional Nat -> Nat -test = cases - None -> 0 - Some x - | isEven x -> x - | otherwise -> 0 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - test : Optional Nat -> Nat - -``` -# Pattern instantiation depth - -Uncovered patterns are only instantiated as deeply as necessary to -distinguish them from existing patterns. -```unison -unique type T = A | B | C - -test : Optional (Optional T) -> () -test = cases - None -> () - Some None -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 4 | test = cases - 5 | None -> () - 6 | Some None -> () - - - Patterns not matched: - * Some (Some _) - -``` -```unison -unique type T = A | B | C - -test : Optional (Optional T) -> () -test = cases - None -> () - Some None -> () - Some (Some A) -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 4 | test = cases - 5 | None -> () - 6 | Some None -> () - 7 | Some (Some A) -> () - - - Patterns not matched: - - * Some (Some B) - * Some (Some C) - -``` -# Literals - -## Non-exhaustive - -Nat -```unison -test : Nat -> () -test = cases - 0 -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 2 | test = cases - 3 | 0 -> () - - - Patterns not matched: - * _ - -``` -Boolean -```unison -test : Boolean -> () -test = cases - true -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 2 | test = cases - 3 | true -> () - - - Patterns not matched: - * false - -``` -## Exhaustive - -Nat -```unison -test : Nat -> () -test = cases - 0 -> () - _ -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - test : Nat -> () - -``` -Boolean -```unison -test : Boolean -> () -test = cases - true -> () - false -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - test : Boolean -> () - -``` -# Redundant - -Nat -```unison -test : Nat -> () -test = cases - 0 -> () - 0 -> () - _ -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - This case would be ignored because it's already covered by the preceding case(s): - 4 | 0 -> () - - -``` -Boolean -```unison -test : Boolean -> () -test = cases - true -> () - false -> () - _ -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - This case would be ignored because it's already covered by the preceding case(s): - 5 | _ -> () - - -``` -# Sequences - -## Exhaustive -```unison -test : [()] -> () -test = cases - [] -> () - x +: xs -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - test : [()] -> () - -``` -## Non-exhaustive -```unison -test : [()] -> () -test = cases - [] -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 2 | test = cases - 3 | [] -> () - - - Patterns not matched: - * (() +: _) - -``` -```unison -test : [()] -> () -test = cases - x +: xs -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 2 | test = cases - 3 | x +: xs -> () - - - Patterns not matched: - * [] - -``` -```unison -test : [()] -> () -test = cases - xs :+ x -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 2 | test = cases - 3 | xs :+ x -> () - - - Patterns not matched: - * [] - -``` -```unison -test : [()] -> () -test = cases - x0 +: (x1 +: xs) -> () - [] -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 2 | test = cases - 3 | x0 +: (x1 +: xs) -> () - 4 | [] -> () - - - Patterns not matched: - * (() +: []) - -``` -```unison -test : [()] -> () -test = cases - [] -> () - x0 +: [] -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 2 | test = cases - 3 | [] -> () - 4 | x0 +: [] -> () - - - Patterns not matched: - * (() +: (() +: _)) - -``` -## Uninhabited - -`Cons` is not expected since `V` is uninhabited -```unison -unique type V = - -test : [V] -> () -test = cases - [] -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type V - test : [V] -> () - -``` -## Length restrictions can equate cons and nil patterns - -Here the first pattern matches lists of length two or greater, the -second pattern matches lists of length 0. The third case matches when the -final element is `false`, while the fourth pattern matches when the -first element is `true`. However, the only possible list length at -the third or fourth clause is 1, so the first and final element must -be equal. Thus, the pattern match is exhaustive. -```unison -test : [Boolean] -> () -test = cases - [a, b] ++ xs -> () - [] -> () - xs :+ false -> () - true +: xs -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - test : [Boolean] -> () - -``` -This is the same idea as above but shows that fourth match is redundant. -```unison -test : [Boolean] -> () -test = cases - [a, b] ++ xs -> () - [] -> () - xs :+ true -> () - true +: xs -> () - _ -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - This case would be ignored because it's already covered by the preceding case(s): - 6 | true +: xs -> () - - -``` -This is another similar example. The first pattern matches lists of -length 5 or greater. The second matches lists of length 4 or greater where the -first and third element are true. The third matches lists of length 4 -or greater where the final 4 elements are `true, false, true, false`. -The list must be exactly of length 4 to arrive at the second or third -clause, so the third pattern is redundant. -```unison -test : [Boolean] -> () -test = cases - [a, b, c, d, f] ++ xs -> () - [true, _, true, _] ++ _ -> () - _ ++ [true, false, true, false] -> () - _ -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - This case would be ignored because it's already covered by the preceding case(s): - 5 | _ ++ [true, false, true, false] -> () - - -``` -# bugfix: Sufficient data decl map - -```unison -unique type T = A - -unit2t : Unit -> T -unit2t = cases - () -> A -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type T - unit2t : 'T - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type T - unit2t : 'T - -``` -Pattern coverage checking needs the data decl map to contain all -transitive type dependencies of the scrutinee type. We do this -before typechecking begins in a roundabout way: fetching all -transitive type dependencies of references that appear in the expression. - -This test ensures that we have fetched the `T` type although there is -no data decl reference to `T` in `witht`. -```unison -witht : Unit -witht = match unit2t () with - x -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - witht : () - -``` -```unison -unique type V = - -evil : Unit -> V -evil = bug "" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type V - evil : 'V - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type V - evil : 'V - -``` -```unison -withV : Unit -withV = match evil () with - x -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - This case would be ignored because it's already covered by the preceding case(s): - 3 | x -> () - - -``` -```unison -unique type SomeType = A -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type SomeType - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type SomeType - -``` -```unison -unique type R = R SomeType - -get x = match x with - R y -> y -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type R - get : R -> SomeType - -``` -```unison -unique type R = { someType : SomeType } -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type R - R.someType : R -> SomeType - R.someType.modify : (SomeType ->{g} SomeType) -> R ->{g} R - R.someType.set : SomeType -> R -> R - -``` -# Ability handlers - -## Exhaustive ability handlers are accepted - -```unison -structural ability Abort where - abort : {Abort} a - - -result : '{e, Abort} a -> {e} a -result f = handle !f with cases - { x } -> x - { abort -> _ } -> bug "aborted" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability Abort - result : '{e, Abort} a ->{e} a - -``` -```unison -structural ability Abort where - abort : {Abort} a - -unique type T = A | B - -result : '{e, Abort} T -> {e} () -result f = handle !f with cases - { A } -> () - { B } -> () - { abort -> _ } -> bug "aborted" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability Abort - result : '{e, Abort} T ->{e} () - - ⍟ These names already exist. You can `update` them to your - new definition: - - type T - -``` -```unison -structural ability Abort where - abort : {Abort} a - -result : '{e, Abort} V -> {e} V -result f = - impl : Request {Abort} V -> V - impl = cases - { abort -> _ } -> bug "aborted" - handle !f with impl -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability Abort - result : '{e, Abort} V ->{e} V - -``` -```unison -structural ability Abort where - abort : {Abort} a - -structural ability Stream a where - emit : a -> {Stream a} Unit - -handleMulti : '{Stream a, Abort} r -> (Optional r, [a]) -handleMulti c = - impl xs = cases - { r } -> (Some r, xs) - { emit x -> resume } -> handle !resume with impl (xs :+ x) - { abort -> _ } -> (None, xs) - handle !c with impl [] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability Abort - structural ability Stream a - handleMulti : '{Abort, Stream a} r -> (Optional r, [a]) - -``` -## Non-exhaustive ability handlers are rejected - -```unison -structural ability Abort where - abort : {Abort} a - abortWithMessage : Text -> {Abort} a - - -result : '{e, Abort} a -> {e} a -result f = handle !f with cases - { abort -> _ } -> bug "aborted" -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 7 | result f = handle !f with cases - 8 | { abort -> _ } -> bug "aborted" - - - Patterns not matched: - - * { _ } - * { abortWithMessage _ -> _ } - -``` -```unison -structural ability Abort where - abort : {Abort} a - -unique type T = A | B - -result : '{e, Abort} T -> {e} () -result f = handle !f with cases - { A } -> () - { abort -> _ } -> bug "aborted" -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 7 | result f = handle !f with cases - 8 | { A } -> () - 9 | { abort -> _ } -> bug "aborted" - - - Patterns not matched: - * { B } - -``` -```unison -unique ability Give a where - give : a -> {Give a} Unit - -unique type T = A | B - -result : '{e, Give T} r -> {e} r -result f = handle !f with cases - { x } -> x - { give A -> resume } -> result resume -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 7 | result f = handle !f with cases - 8 | { x } -> x - 9 | { give A -> resume } -> result resume - - - Patterns not matched: - * { give B -> _ } - -``` -```unison -structural ability Abort where - abort : {Abort} a - -structural ability Stream a where - emit : a -> {Stream a} Unit - -handleMulti : '{Stream a, Abort} r -> (Optional r, [a]) -handleMulti c = - impl : [a] -> Request {Stream a, Abort} r -> (Optional r, [a]) - impl xs = cases - { r } -> (Some r, xs) - { emit x -> resume } -> handle !resume with impl (xs :+ x) - handle !c with impl [] -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 10 | impl xs = cases - 11 | { r } -> (Some r, xs) - 12 | { emit x -> resume } -> handle !resume with impl (xs :+ x) - - - Patterns not matched: - * { abort -> _ } - -``` -## Redundant handler cases are rejected - -```unison -unique ability Give a where - give : a -> {Give a} Unit - -unique type T = A | B - -result : '{e, Give T} r -> {e} r -result f = handle !f with cases - { x } -> x - { give _ -> resume } -> result resume - { give A -> resume } -> result resume -``` - -```ucm - - Loading changes detected in scratch.u. - - This case would be ignored because it's already covered by the preceding case(s): - 10 | { give A -> resume } -> result resume - - -``` -## Exhaustive ability reinterpretations are accepted - -```unison -structural ability Abort where - abort : {Abort} a - abortWithMessage : Text -> {Abort} a - - -result : '{e, Abort} a -> {e, Abort} a -result f = handle !f with cases - { x } -> x - { abort -> _ } -> abort - { abortWithMessage msg -> _ } -> abortWithMessage ("aborting: " ++ msg) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability Abort - result : '{e, Abort} a ->{e, Abort} a - -``` -```unison -structural ability Abort a where - abort : {Abort a} r - abortWithMessage : a -> {Abort a} r - -result : '{e, Abort V} a -> {e, Abort V} a -result f = - impl : Request {Abort V} r -> {Abort V} r - impl = cases - { x } -> x - { abort -> _ } -> abort - handle !f with impl -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability Abort a - result : '{e, Abort V} a ->{e, Abort V} a - -``` -## Non-exhaustive ability reinterpretations are rejected - -```unison -structural ability Abort where - abort : {Abort} a - abortWithMessage : Text -> {Abort} a - - -result : '{e, Abort} a -> {e, Abort} a -result f = handle !f with cases - { x } -> x - { abortWithMessage msg -> _ } -> abortWithMessage ("aborting: " ++ msg) -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 7 | result f = handle !f with cases - 8 | { x } -> x - 9 | { abortWithMessage msg -> _ } -> abortWithMessage ("aborting: " ++ msg) - - - Patterns not matched: - * { abort -> _ } - -``` -## Hacky workaround for uninhabited abilities - -Although all of the constructors of an ability might be uninhabited, -the typechecker requires at least one be specified so that it can -determine that the ability should be discharged. So, the default -pattern match coverage checking behavior of prohibiting covering any -of the cases is problematic. Instead, the pattern match coverage -checker will require that at least one constructor be given, even if -they are all uninhabited. - -The messages here aren't the best, but I don't think uninhabited -abilities will come up and get handlers written for them often. - -```unison -unique ability Give a where - give : a -> {Give a} Unit - give2 : a -> {Give a} Unit - -result : '{e, Give V} r -> {e} r -result f = - impl : Request {Give V} r -> {} r - impl = cases - { x } -> x - handle !f with impl -``` - -```ucm - - Loading changes detected in scratch.u. - - Pattern match doesn't cover all possible cases: - 8 | impl = cases - 9 | { x } -> x - - - Patterns not matched: - - * { give _ -> _ } - * { give2 _ -> _ } - -``` -```unison -unique ability Give a where - give : a -> {Give a} Unit - give2 : a -> {Give a} Unit - -result : '{e, Give V} r -> {e} r -result f = - impl : Request {Give V} r -> {} r - impl = cases - { x } -> x - { give _ -> resume } -> bug "impossible" - handle !f with impl -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ability Give a - result : '{e, Give V} r ->{e} r - -``` -```unison -unique ability Give a where - give : a -> {Give a} Unit - give2 : a -> {Give a} Unit - -result : '{e, Give V} r -> {e} r -result f = - impl : Request {Give V} r -> {} r - impl = cases - { x } -> x - { give2 _ -> resume } -> bug "impossible" - handle !f with impl -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ability Give a - result : '{e, Give V} r ->{e} r - -``` -```unison -unique ability Give a where - give : a -> {Give a} Unit - give2 : a -> {Give a} Unit - -result : '{e, Give V} r -> {e} r -result f = - impl : Request {Give V} r -> {} r - impl = cases - { x } -> x - { give _ -> resume } -> bug "impossible" - { give2 _ -> resume } -> bug "impossible" - handle !f with impl -``` - -```ucm - - Loading changes detected in scratch.u. - - This case would be ignored because it's already covered by the preceding case(s): - 11 | { give2 _ -> resume } -> bug "impossible" - - -``` -```unison -unique ability GiveA a where - giveA : a -> {GiveA a} Unit - giveA2 : a -> {GiveA a} Unit - -unique ability GiveB a where - giveB : a -> {GiveB a} Unit - giveB2 : a -> {GiveB a} Unit - -result : '{e, GiveA V, GiveB V} r -> {e} r -result f = - impl : Request {GiveA V, GiveB V} r -> {} r - impl = cases - { x } -> x - { giveA _ -> _ } -> bug "impossible" - { giveA2 _ -> _ } -> bug "impossible" - { giveB _ -> _ } -> bug "impossible" - { giveB2 _ -> _ } -> bug "impossible" - handle !f with impl -``` - -```ucm - - Loading changes detected in scratch.u. - - This case would be ignored because it's already covered by the preceding case(s): - 15 | { giveA2 _ -> _ } -> bug "impossible" - - -``` -```unison -unique ability GiveA a where - giveA : a -> {GiveA a} Unit - giveA2 : a -> {GiveA a} Unit - -unique ability GiveB a where - giveB : a -> {GiveB a} Unit - giveB2 : a -> {GiveB a} Unit - -result : '{e, GiveA V, GiveB V} r -> {e} r -result f = - impl : Request {GiveA V, GiveB V} r -> {} r - impl = cases - { x } -> x - { giveA2 _ -> _ } -> bug "impossible" - { giveB _ -> _ } -> bug "impossible" - handle !f with impl -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - ability GiveA a - ability GiveB a - result : '{e, GiveA V, GiveB V} r ->{e} r - -``` diff --git a/unison-src/transcripts/pattern-pretty-print-2345.md b/unison-src/transcripts/pattern-pretty-print-2345.md deleted file mode 100644 index 0879808f2d..0000000000 --- a/unison-src/transcripts/pattern-pretty-print-2345.md +++ /dev/null @@ -1,85 +0,0 @@ -Regression test for https://github.com/unisonweb/unison/pull/2377 - - -```ucm:hide -.> builtins.merge -``` - -```unison -structural ability Ab where - a: Nat -> () - -dopey = cases - ?0 -> () - _ -> () - -grumpy = cases - d -> () - -happy = cases - true -> () - false -> () - -sneezy = cases - +1 -> () - _ -> () - -bashful = cases - Some a -> () - _ -> () - -mouthy = cases - [] -> () - _ -> () - -pokey = cases - h +: t -> () - _ -> () - -sleepy = cases - i :+ l -> () - _ -> () - -demure = cases - [0] -> () - _ -> () - -angry = cases - a ++ [] -> () - -tremulous = cases - (0,1) -> () - _ -> () - -throaty = cases - { Ab.a a -> k } -> () - { _ } -> () - -agitated = cases - a | a == 2 -> () - _ -> () - -doc = cases - y@4 -> () - _ -> () -``` - -```ucm -.> add -.> view dopey -.> view grumpy -.> view happy -.> view sneezy -.> view bashful -.> view mouthy -.> view pokey -.> view sleepy -.> view demure -.> view angry -.> view tremulous -.> view throaty -.> view agitated -.> view doc - -``` - diff --git a/unison-src/transcripts/pattern-pretty-print-2345.output.md b/unison-src/transcripts/pattern-pretty-print-2345.output.md deleted file mode 100644 index 6c239772d2..0000000000 --- a/unison-src/transcripts/pattern-pretty-print-2345.output.md +++ /dev/null @@ -1,205 +0,0 @@ -Regression test for https://github.com/unisonweb/unison/pull/2377 - - -```unison -structural ability Ab where - a: Nat -> () - -dopey = cases - ?0 -> () - _ -> () - -grumpy = cases - d -> () - -happy = cases - true -> () - false -> () - -sneezy = cases - +1 -> () - _ -> () - -bashful = cases - Some a -> () - _ -> () - -mouthy = cases - [] -> () - _ -> () - -pokey = cases - h +: t -> () - _ -> () - -sleepy = cases - i :+ l -> () - _ -> () - -demure = cases - [0] -> () - _ -> () - -angry = cases - a ++ [] -> () - -tremulous = cases - (0,1) -> () - _ -> () - -throaty = cases - { Ab.a a -> k } -> () - { _ } -> () - -agitated = cases - a | a == 2 -> () - _ -> () - -doc = cases - y@4 -> () - _ -> () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural ability Ab - agitated : Nat -> () - angry : [t] -> () - bashful : Optional a -> () - demure : [Nat] -> () - doc : Nat -> () - dopey : Char -> () - grumpy : ff284oqf651 -> () - happy : Boolean -> () - mouthy : [t] -> () - pokey : [t] -> () - sleepy : [t] -> () - sneezy : Int -> () - throaty : Request {g, Ab} x -> () - tremulous : (Nat, Nat) -> () - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - structural ability Ab - agitated : Nat -> () - angry : [t] -> () - bashful : Optional a -> () - demure : [Nat] -> () - doc : Nat -> () - dopey : Char -> () - grumpy : ff284oqf651 -> () - happy : Boolean -> () - mouthy : [t] -> () - pokey : [t] -> () - sleepy : [t] -> () - sneezy : Int -> () - throaty : Request {g, Ab} x -> () - tremulous : (Nat, Nat) -> () - -.> view dopey - - dopey : Char -> () - dopey = cases - ?0 -> () - _ -> () - -.> view grumpy - - grumpy : ff284oqf651 -> () - grumpy = cases d -> () - -.> view happy - - happy : Boolean -> () - happy = cases - true -> () - false -> () - -.> view sneezy - - sneezy : Int -> () - sneezy = cases - +1 -> () - _ -> () - -.> view bashful - - bashful : Optional a -> () - bashful = cases - Some a -> () - _ -> () - -.> view mouthy - - mouthy : [t] -> () - mouthy = cases - [] -> () - _ -> () - -.> view pokey - - pokey : [t] -> () - pokey = cases - h +: t -> () - _ -> () - -.> view sleepy - - sleepy : [t] -> () - sleepy = cases - i :+ l -> () - _ -> () - -.> view demure - - demure : [Nat] -> () - demure = cases - [0] -> () - _ -> () - -.> view angry - - angry : [t] -> () - angry = cases a ++ [] -> () - -.> view tremulous - - tremulous : (Nat, Nat) -> () - tremulous = cases - (0, 1) -> () - _ -> () - -.> view throaty - - throaty : Request {g, Ab} x -> () - throaty = cases - { Ab.a a -> k } -> () - { _ } -> () - -.> view agitated - - agitated : Nat -> () - agitated = cases - a | a == 2 -> () - _ -> () - -.> view doc - - doc : Nat -> () - doc = cases - y@4 -> () - _ -> () - -``` diff --git a/unison-src/transcripts/patternMatchTls.md b/unison-src/transcripts/patternMatchTls.md deleted file mode 100644 index cfe5b177cf..0000000000 --- a/unison-src/transcripts/patternMatchTls.md +++ /dev/null @@ -1,34 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -We had bugs in the calling conventions for both send and terminate which would -cause pattern matching on the resulting (Right ()) would cause a runtime error. - - - -```unison -use builtin.io2.Tls newClient send handshake terminate - -frank: '{IO} () -frank = do - socket = assertRight (clientSocket.impl "example.com" "443") - config = ClientConfig.default "example.com" 0xs - tls = assertRight (newClient.impl config socket) - () = assertRight (handshake.impl tls) - () = assertRight (send.impl tls 0xs) - () = assertRight (terminate.impl tls) - () - -assertRight : Either a b -> b -assertRight = cases - Right x -> x - Left _ -> bug "expected a right but got a left" -``` - - - -```ucm -.> add -.> run frank -``` diff --git a/unison-src/transcripts/patternMatchTls.output.md b/unison-src/transcripts/patternMatchTls.output.md deleted file mode 100644 index b1f82833b5..0000000000 --- a/unison-src/transcripts/patternMatchTls.output.md +++ /dev/null @@ -1,51 +0,0 @@ -We had bugs in the calling conventions for both send and terminate which would -cause pattern matching on the resulting (Right ()) would cause a runtime error. - - - -```unison -use builtin.io2.Tls newClient send handshake terminate - -frank: '{IO} () -frank = do - socket = assertRight (clientSocket.impl "example.com" "443") - config = ClientConfig.default "example.com" 0xs - tls = assertRight (newClient.impl config socket) - () = assertRight (handshake.impl tls) - () = assertRight (send.impl tls 0xs) - () = assertRight (terminate.impl tls) - () - -assertRight : Either a b -> b -assertRight = cases - Right x -> x - Left _ -> bug "expected a right but got a left" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - assertRight : Either a b -> b - frank : '{IO} () - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - assertRight : Either a b -> b - frank : '{IO} () - -.> run frank - - () - -``` diff --git a/unison-src/transcripts/patterns.md b/unison-src/transcripts/patterns.md deleted file mode 100644 index 104d1bc8ae..0000000000 --- a/unison-src/transcripts/patterns.md +++ /dev/null @@ -1,12 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -Some tests of pattern behavior. - -```unison -p1 = join [literal "blue", literal "frog"] - -> Pattern.run (many p1) "bluefrogbluegoat" -> Pattern.run (many.corrected p1) "bluefrogbluegoat" -``` diff --git a/unison-src/transcripts/patterns.output.md b/unison-src/transcripts/patterns.output.md deleted file mode 100644 index 7db153f99b..0000000000 --- a/unison-src/transcripts/patterns.output.md +++ /dev/null @@ -1,33 +0,0 @@ -Some tests of pattern behavior. - -```unison -p1 = join [literal "blue", literal "frog"] - -> Pattern.run (many p1) "bluefrogbluegoat" -> Pattern.run (many.corrected p1) "bluefrogbluegoat" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - p1 : Pattern Text - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 3 | > Pattern.run (many p1) "bluefrogbluegoat" - ⧩ - Some ([], "goat") - - 4 | > Pattern.run (many.corrected p1) "bluefrogbluegoat" - ⧩ - Some ([], "bluegoat") - -``` diff --git a/unison-src/transcripts/project-merge.md b/unison-src/transcripts/project-merge.md deleted file mode 100644 index d18fd89cfd..0000000000 --- a/unison-src/transcripts/project-merge.md +++ /dev/null @@ -1,39 +0,0 @@ -# projects merge - -```ucm -.> builtins.merge -``` - -```unison -zonk = 0 -``` - -```ucm -.foo> add -.> project.create-empty foo -.> merge.old foo foo/main -``` - -```unison -bonk = 2 -``` - -```ucm -foo/main> add -``` - -```ucm -.> project.create-empty bar -bar/main> merge.old foo/main -bar/main> branch /topic -``` - -```unison -xonk = 1 -``` - -```ucm -bar/main> add -bar/topic> merge.old /main -.bar> merge.old foo/main -``` diff --git a/unison-src/transcripts/project-merge.output.md b/unison-src/transcripts/project-merge.output.md deleted file mode 100644 index 98f20e79d7..0000000000 --- a/unison-src/transcripts/project-merge.output.md +++ /dev/null @@ -1,193 +0,0 @@ -# projects merge - -```ucm -.> builtins.merge - - Done. - -``` -```unison -zonk = 0 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - zonk : Nat - -``` -```ucm - ☝️ The namespace .foo is empty. - -.foo> add - - ⍟ I've added these definitions: - - zonk : ##Nat - -.> project.create-empty foo - - 🎉 I've created the project foo. - - 🎨 Type `ui` to explore this project's code in your browser. - 🔭 Discover libraries at https://share.unison-lang.org - 📖 Use `help-topic projects` to learn more about projects. - - Write your first Unison code with UCM: - - 1. Open scratch.u. - 2. Write some Unison code and save the file. - 3. In UCM, type `add` to save it to your new project. - - 🎉 🥳 Happy coding! - -.> merge.old foo foo/main - - Here's what's changed in foo/main after the merge: - - Added definitions: - - 1. zonk : Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` -```unison -bonk = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bonk : Nat - -``` -```ucm -foo/main> add - - ⍟ I've added these definitions: - - bonk : ##Nat - -``` -```ucm -.> project.create-empty bar - - 🎉 I've created the project bar. - - 🎨 Type `ui` to explore this project's code in your browser. - 🔭 Discover libraries at https://share.unison-lang.org - 📖 Use `help-topic projects` to learn more about projects. - - Write your first Unison code with UCM: - - 1. Open scratch.u. - 2. Write some Unison code and save the file. - 3. In UCM, type `add` to save it to your new project. - - 🎉 🥳 Happy coding! - -bar/main> merge.old foo/main - - Here's what's changed in the current namespace after the - merge: - - Added definitions: - - 1. bonk : ##Nat - 2. zonk : ##Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -bar/main> branch /topic - - Done. I've created the topic branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic`. - -``` -```unison -xonk = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - xonk : ##Nat - -``` -```ucm -bar/main> add - - ⍟ I've added these definitions: - - xonk : ##Nat - -bar/topic> merge.old /main - - Here's what's changed in the current namespace after the - merge: - - Added definitions: - - 1. xonk : ##Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - - ☝️ The namespace .bar is empty. - -.bar> merge.old foo/main - - Here's what's changed in the current namespace after the - merge: - - Added definitions: - - 1. bonk : ##Nat - 2. zonk : ##Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` diff --git a/unison-src/transcripts/project-outputs/.github/ISSUE_TEMPLATE/bug_report.output.md b/unison-src/transcripts/project-outputs/.github/ISSUE_TEMPLATE/bug_report.output.md new file mode 100644 index 0000000000..287ba0bb94 --- /dev/null +++ b/unison-src/transcripts/project-outputs/.github/ISSUE_TEMPLATE/bug_report.output.md @@ -0,0 +1,35 @@ +----- + +name: Bug report +about: Create a report to help us improve +title: '' +labels: bug +assignees: '' + +----- + +**Describe and demonstrate the bug** +This should be written as a [ucm transcript](https://www.unison-lang.org/docs/tooling/transcripts/) if possible, calling out the unexpected behavior in the text. e.g. + +``` unison :hide +a = 1 +``` + +Here I typo the next command and `ucm` silently does nothing, I would have expected an error message: + +``` ucm +scratch/main> add b + +``` + +**Screenshots** +If applicable, add screenshots to help explain your problem. + +**Environment (please complete the following information):** + + - `ucm --version` \[e.g. "0.5.21", or "1cb2437 (built on 2024-06-03)"\] + - OS/Architecture: \[e.g. "macOS 14.5, Intel"\] + - Browser, if applicable: \[e.g. "chrome 125.0.6422.142"\] (Version numbers are typically found the about menu option) + +**Additional context** +Add any other context about the problem here. diff --git a/unison-src/transcripts/project-outputs/.github/pull_request_template.output.md b/unison-src/transcripts/project-outputs/.github/pull_request_template.output.md new file mode 100644 index 0000000000..4a02905b24 --- /dev/null +++ b/unison-src/transcripts/project-outputs/.github/pull_request_template.output.md @@ -0,0 +1,32 @@ +**Choose your PR title well:** Your pull request title is what's used to create release notes, so please make it descriptive of the change itself, which may be different from the initial motivation to make the change. + +## Overview + +What does this change accomplish and why? +i.e. How does it change the user experience? +i.e. What was the old behavior/API and what is the new behavior/API? + +Feel free to include "before and after" examples if appropriate. (You can copy/paste screenshots directly into this editor.) + +If relevant, which Github issues does it close? (See [closing-issues-using-keywords](https://help.github.com/en/enterprise/2.16/user/github/managing-your-work-on-github/closing-issues-using-keywords).) + +## Implementation notes + +How does it accomplish it, in broad strokes? i.e. How does it change the Haskell codebase? + +## Interesting/controversial decisions + +Include anything that you thought twice about, debated, chose arbitrarily, etc. +What could have been done differently, but wasn't? And why? + +## Test coverage + +Have you included tests (which could be a transcript) for this change, or is it somehow covered by existing tests? + +Would you recommend improving the test coverage (either as part of this PR or as a separate issue) or do you think it’s adequate? + +If you only tested by hand, because that's all that's practical to do for this change, mention that. + +## Loose ends + +Link to related issues that address things you didn't get to. Stuff you encountered on the way and decided not to include in this PR. diff --git a/unison-src/transcripts/project-outputs/docs/ability-typechecking.output.md b/unison-src/transcripts/project-outputs/docs/ability-typechecking.output.md new file mode 100644 index 0000000000..9d8b398604 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/ability-typechecking.output.md @@ -0,0 +1,81 @@ +Brief document discussing Unison's algebraic effects. + + - The type `a ->{IO} b` type is a function from `a` to `b`, which requires the `IO` ability. The `{}` should be thought of as being attached to the `->`. + - The `{}` syntax can contain any number of comma separated types, like `a ->{IO, Abort, State Nat} b`. We call the `{}` list the "required abilities" of the function. + - Within an abilities list, type variables like `{e1, e2}` can be instantiated to sets of abilities, so we should think of the `{}` as just taking the union of all the sets contained therein. `IO` within `{IO}` is really the singleton set. + - Unison's typechecker prevents calling a function whose required abilities aren't available in the currrent expression. We say that at each subexpression of the program, there's an *ambient* set of abilities available, and when calling a function `f : a ->{e1,e2} b`, the ambient abilities must be at least as big as as `{e1, e2}` (according to the subtyping judgement). Verifying that these requested abilities are available is called an "ability check". + - The ambient abilities at a subterm is defined to be equal to the required abilities on the type of the *nearest enclosing lambda*. For instance, within the body of a lambda of type `a ->{Remote} b`, `{Remote}` is the ambient set. + - Okay the above isn't quite right because `handle` blocks prepend new abilities to the ambient based on the abilities that the handler eliminates. So a handler `h : Request {IO} a -> b` will grant access to `IO` within the `body` of `handle h in body`. So the ambient set is really the required abilities on the type of the nearest enclosing lambda, plus the abilities eliminated by enclosing handlers. + +Here are a few examples: + +``` haskell +foo : Text ->{} () +foo name = IO.printLine ("Hello, " ++ name) +``` + +Triggers an ability check failure, since the nearest enclosing lambda requires `{}`, the empty set of abilities. Therefore the body of that lambda doesn't have access to `IO`. + +``` haskell +foo2 : Text ->{IO} Text ->{} () +foo2 name1 name = IO.printLine ("Hello, " ++ name) +``` + +This also triggers an ability check failure. The inner lambda still requires only `{}` and we don't get access to abilities required by outer lambdas. This would be unsound (you could partially apply the function, then obtain a function with a smaller abilities requirement than what it actually used). + +This would work: + +``` haskell +foo2 : Text ->{IO} Text ->{} () +foo2 name1 = + IO.printLine ("Hello, " ++ name1) + name -> () +``` + +Notice that we get access to `IO` after just the first argument is supplied. The lambda we return though can't use `IO`. + +TODO: handle blocks + +## Type annotations and ability inference + +The type of the nearest enclosing lambda and therefore the ambient set can't always be known in advance, if the user hasn't provided type annotations. In this case, we invent an existential type parameter for the ambient set and allow the existential to be refined by the normal ability checks. + +I realized it's not sound to do Frank-style effect generalization after typechecking and have a different proposal instead. For instance, suppose we have the function: + +``` haskell +map : (a -> b) -> [a] -> [b] +``` + +Which we typecheck and then afterwards generalize to: + +``` haskell +map : (a ->{e} b) -> [a] ->{e} [b] +``` + +Except, what if that function `a ->{e} b` were actually being passed (within the body of `map`) to some other function that was expecting an `a ->{} b`? We can't just generalize this willy nilly, we actually need to typecheck with the enriched type. + +So I propose the following: + + - The type `a -> b` means `a ->{e} b` for some existential `e` to be inferrered by Unison. It doesn't mean `forall e . a ->{e} b` or `a ->{} b`. + - And as before: + - The type `a ->{} b` means a function with no required abilities, AKA a pure function + - The type `a ->{e} b` means a function with exactly `e` as its required abilities + +So, the `map` function, assuming it were implemented in an ability-polymorphic way, would get the signature: + +``` haskell +map : (a ->{e} b) -> [a] ->{e} [b] +``` + +This would be the type it would get if inferred, or if the user provided the signature `(a -> b) -> [a] -> [b]` to the function, it would note this elaborated type for the user (and possibly link to some docs about what this means). + +This is sound and should work fine. It has the benefit of being highly nonmagical. I think it could also good for teaching about abilities: one can write "simple" type signatures and have them be elaborated automatically, which builds some familiarity. A downside is that the user will see more ability type variables. But maybe that's a feature, not a bug. + +A couple usability improvements can elide ability type variables in various cases: + + - When displaying a type signature, we can elide any ability type variables that are mentioned just once by the type (as in `forall e . Nat ->{e} Nat`). If the variable is mentioned more than once in the signature, we include it, since it's adding useful information about what the function does and how it works. A principle here is that it's okay to eliminate informtaion from an arrow `a ->{e} b` and show that as `a -> b` if the user can use that as an `a ->{e} b` for any choice of `e`, including `{}`. + - Another possible usability thing that's maybe more questionable, eliminate any empty `{}` that aren't to the left of an `->`. So for instance `Nat ->{} Nat ->{} Text` would display as just `Nat -> Nat -> Text`, but like `(a ->{} b) -> blah` would still display as `(a ->{} b) -> blah` since the `{}` appear to the left of an `->`. + +### Question + +Given the above, wow do we decide when a type signature is redundant, for purposes of determining whether to store that signature along with the type? diff --git a/unison-src/transcripts/project-outputs/docs/adding-builtins.output.md b/unison-src/transcripts/project-outputs/docs/adding-builtins.output.md new file mode 100644 index 0000000000..4a5029f870 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/adding-builtins.output.md @@ -0,0 +1,236 @@ +This document explains how to add builtins to the language by working +through the example of adding `MVar` and some associated functions. + +## Builtin Data + +The logical first step for this example is to add a built-in `MVar` +type, whose values will simply be wrapped values of the Haskell type +with the same name. The 'old' runtime deviates from this approach for +several types, but this is how e.g. `Text` works even there. + +Data types, including opaque pseudo data types of this sort are +referred to by `Reference`. Builtin, opaque data types use the +`Builtin` constructor with an appropriate name. The ones in actual +use are listed in the `Unison.Type` module, so we'll add a definition +there: + +``` haskell +mvarRef :: Reference +mvarRef = Reference.Builtin "MVar" +``` + +This definition alone won't do anything, however. It is merely +something for other definitions to refer to. If the reference is used +in e.g. the type of a function definitions without giving it an actual +name in the codebase, the type will be displayed with the raw hash, +which looks like `#MVar`. + +The builtin reference can be given a name during the `builtins.merge` +ucm command. To make this happen, we must modify the `builtinTypesSrc` +definition in the `Unison.Builtin` module. This is just a list of +values that describe various builtin type related actions to be +performed during that command. In this case, we will add two values to +the list: + +``` haskell +B' "MVar" CT.Data +``` + +This specifies that there should be a builtin data type referring to +the `Builtin "MVar"` reference. The codebase name assigned to this is +the same as the reference (MVar here), but nested in the `builtin` +namespace. However, we will also add the value: + +``` haskell +Rename' "MVar" "io2.MVar" +``` + +because this is a type to be used with the new IO functions, which are +currently nested under the `io2` namespace. With both of these added +to the list, running `builtins.merge` should have a `builtin.io2.MVar` +type referring to the `Builtin "MVar"` reference. + +The reason for both a `B'` and a `Rename'` is that eventually one +would expect the IO functionality to be moved from the `io2` +namespace. However, the builtin reference name may not be changed +easily, so it is preferable to have it named in the eventual expected +way, rather than permanently named `io2.MVar` internally. + +## Builtin function declarations + +The next step is to declare builtin functions that make use of the new +type. These are declared in a similar way to the type names above. +There is another list in `Unison.Builtin`, `builtinsSrc`, that defines +values specifying what builtin functions should exist. + +Like the builtin type list, there are declarations for adding a +builtin function with a given name, and declarations for renaming from +the given name to a different namespace location. For the `MVar` +functions, we'll again give them their intended names as the original, +and rename them to the `io2` namespace for the time being. + +Builtin functions also have an associated type as part of the initial +declaration. So for the complete specification of a function, we will +add declarations similar to: + +``` haskell +B "MVar.new" $ forall1 "a" (\a -> a --> io (mvar a)) +Rename "MVar.new" "io2.MVar.new" +B "MVar.take" $ forall1 "a" (\a -> mvar a --> iof a) +Rename "MVar.take" "io2.MVar.take" +``` + +The `forall1`, `io`, `iof` and `-->` functions are local definitions +in `Unison.Builtin` for assistance in writing the types. `iof` +indicates that an error result may be returned, while `io` should +always succeed. Note that when the `{IO}` ability appears as a type +parameter rather than the return type of a function, you will need to +use `iot` instead. +`mvar` can be defined locally using some other +helpers in scope: + +``` haskell +mvar :: Type -> Type +mvar a = Type.ref () Type.mvarRef `app` a +``` + +For the actual `MVar` implementation, we'll be doing many definitions +followed by renames, so it'll be factored into a list of the name and +type, and we can then call the `moveUnder` helper to generate the `B` +declaration and the `Rename`. + +## Builtin function implementation -- new runtime + +What we have done so far only declares the functions and their types. +There is nothing yet implementing them. This section will proceed +through the implementation backing the declarations of the `MVar.new` +and `MVar.take` above. + +In this case, we will implement the operations using the 'foreign +function' machinery. This path is somewhat less optimized, but +doesn't require inventing opcodes and modifying the runtime at +quite as low a level. The builtin 'foreign' functions are declared +in `Unison.Runtime.Builtin`, in a definition `declareForeigns`. We +can declare our builtins there by adding: + +``` haskell + declareForeign Tracked "MVar.new" boxDirect + . mkForeign $ \(c :: Closure) -> newMVar c + declareForeign Tracked "MVar.take" boxToEFBox + . mkForeignIOF $ \(mv :: MVar Closure) -> takeMVar mv +``` + +These lines do multiple things at once. The first argument to +`declareForeign` determines whether the function should be explicitly +tracked by the Unison Cloud sandboxing functionality or not. As a +general guideline, functions in `{IO}` are `Tracked`, and pure +functions are `Untracked`. The second argument must match the name +from `Unison.Builtin`, as this is how they are associated. The third +argument is wrapper code that defines the conversion from the Haskell +runtim calling convention into Unison, and the definitions for these +two cases will be shown later. The last argument is the actual Haskell +implementation of the operation. However, the format for foreign +functions is somewhat more limited than 'any Haskell function,' so the +`mkForeign` and `mkForeignIOF` helpers assist in wrapping Haskell +functions correctly. The latter will catch some exceptions and yield +them as explicit results. + +The wrapper code for these two operations looks like: + +``` haskell +-- a -> b +boxDirect :: ForeignOp +boxDirect instr = + ([BX],) + . TAbs arg + $ TFOp instr [arg] + where + arg = fresh1 + +-- a -> Either Failure b +boxToEFBox :: ForeignOp +boxToEFBox = + inBx arg result $ + outIoFailBox stack1 stack2 stack3 any fail result + where + (arg, result, stack1, stack2, stack3, any, fail) = fresh +``` + +The breakdown of what is happening here is as follows: + + - `instr` is an identifier that is used to decouple the wrapper + code from the actual Haskell implementation functions. It is + made up in `declareForeign` and passed to the wrapper to use as a + sort of instruction code. + - A `ForeignOp` may take many arguments, and the list in the tuple + section specifies the calling convention for them. `[BX]` means + one boxed argument, which in this case is the value of type `a`. + `[BX,BX]` would be two boxed arguments, and `[BX,UN]` would be + one boxed and one unboxed argument. Builtin wrappers will + currently be taking all boxed arguments, because there is no way + to talk about unboxed values in the surface syntax where they are + called. + - `TAbs arg` abstracts the argument variable, which we got from + `fresh1'` at the bottom. Multiple arguments may be abstracted with + e.g. `TAbss [x,y,z]`. You can call `fresh` to instantiate a tuple of + fresh variables of a certain arity. + - `inBx` and `outIoFailBox` are helper functions for calling the + instruction and wrapping up a possible error result. + - `TFOp` simply calls the instruction with the assumption that the + result value is acceptable for directly returning. `MVar` values + will be represented directly by their Haskell values wrapped into + a closure, so the `boxDirect` code doesn't need to do any + processing of the results of its foreign function. + +The names of the helpers generally follow a form of form of Hungarian +notation, e.g. `boxToEFBox` means "boxed value to either a failure or +a boxed value", i.e. `a -> Either a b`. +However, not all helpers are named consistently at the moment, and +different builtins use slightly different implementations, so looking +at other parts of the file may be instructive, depending on what is +being added. + +At first, our declarations will cause an error, because some of the +automatic machinery for creating builtin 'foreign' functions does not +exist for `MVar`. To rectify this, we can add a `ForeignConvention` +instance in `Unison.Runtime.Foreign.Function` that specifies how to +automatically marshal `MVar Closure`, which is the representation +we'll be using. + +``` haskell +instance ForeignConvention (MVar Closure) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap mvarRef) +``` + +This takes advantage of the `Closure` instance, and uses helper +functions that apply (un)wrappers from another convention. + +With these in place, the functions should now be usable in the new +runtime. + +## Decompilation + +If it makes sense for an added type, it is possible to add to Unison's +ability to decompile runtime values or test for universal +equality/ordering. Directly embedded Haskell types are wrapped in the +`Foreign` type, and are decompiled in `Unison.Runtime.Decompile` using +the `decompileForeign` function. For instance, `Text` is decompiled in +the case: + +``` haskell + | Just t <- maybeUnwrapBuiltin f = Right $ text () t +``` + +Further cases may be added using the `maybeUnwrapBuiltin`, which just +requires adding an instance to the `BuiltinForeign` class in +`Unison.Runtime.Foreign`, specifying which builtin reference +corresponds to the type. + +## Transcripts + +One last thing remains. The additional builtin operations will have +changed some of the transcript output. The transcript runner should be +executed, and modified files should be checked and committed, so that +CI tests will pass (which check transcripts against an expected +result). diff --git a/unison-src/transcripts/project-outputs/docs/branchless-scratch.output.md b/unison-src/transcripts/project-outputs/docs/branchless-scratch.output.md new file mode 100644 index 0000000000..cbcef53ae6 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/branchless-scratch.output.md @@ -0,0 +1,54 @@ +### Remembering local/remote codetree associations? + +``` haskell +-- Designates remote paths to sync local paths against +newtype RemoteMap = RemoteMap { toMap :: Map (Path, RemoteName) RemotePath } +``` + +If I have some branch (tree node) that I want to sync with github on an ongoing basis. e.g. `/projects/foo` to `github:aryairani/foo` — that becomes a place I can publish to or pull from, how should I associate the two? If I + +If I associate it by path, then what should happen when I move or copy the node in the tree? What do I have to update to make that happen? + +What happens if I associate it by `Causal` hash? + +``` +# parenthesized hashes represent the branch hash + +/projects (mZm)> remote.set github:user/foo foo + Set remote github:user/foo for /projects/foo (0e9). +``` + +/projects/foo (0e9) linked to github:user/foo + +``` +/projects (mZm)> cp foo foo-fork +/projects (wkP)> cd foo-fork +/projects/foo-fork (0e9)> add myFunc + Added myFunc. +/projects/foo-fork (p3z)> + +Should now have: +/projects/foo (0e9) linked to github:user/foo +/projects/foo-fork (p3z) linked to github:user/foo +``` + +``` +# types +.unison/types//compiled.ub +.unison/types//dependents/ +.unison/types/_builtin//dependents/ +# terms +.unison/terms/_builtin//dependents/ +.unison/terms//compiled.ub +.unison/terms//type.ub +.unison/terms//dependents/ +# branches +.unison/branches/.ubf +.unison/branches/head/ -- if several, merge entries to produce new head. +# edits +.unison/edits// +.unison/edits//name/ -- (base58encode (utf8encode "name of the edit")) +.unison/edits//head/ -- if several, merge entries +# remotes +.unison/remotes/ +``` diff --git a/unison-src/transcripts/project-outputs/docs/branchless.output.md b/unison-src/transcripts/project-outputs/docs/branchless.output.md new file mode 100644 index 0000000000..ed371b16b1 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/branchless.output.md @@ -0,0 +1,656 @@ +----- + +### Dependents + +The reason we keep track of dependents is for the `todo` calculation. When we make an edit, what are the things that need to be updated as a result? + +When adding term `a` that depends on "derived" term `b` or type `B`, then a change to `b` or `B` affects `a`, so we record that `a` is a dependent of `b` and `B`. + +When adding type `A` that depends on type `B`, a change to `B` affects `A`, so we record that `A` is a dependent of `B`. + +We don't do anything for constructors, because constructors don't change. Depending on the constructor really means you depend on the type that constructor comes from. (i.e. a constructor doesn't have dependents.) Similarly, constructor doesn't have dependencies, but its declaring type may depend on other types. + +----- + +Commands + +``` +/> cd libs/Foo +/libs/Foo> cd .. +/libs> fork Foo Foo2 +/libs> fork thing +/libs> fork Foo /outside/Foo +/libs> fork /outside/Foo /outside/Foo2 +/libs> help merge + `> merge src dest` +/libs> merge /outside/Foo Foo +/libs> merge Foo2 Foo + +/libs/Foo> +/libs> move /libs/Foo /libs/Foo' +/libs> + +A.B.c +A.B.d + +arya renames, and has: -> +A.Z.c +A.Z.d + +paul adds, and has -> +A.B.e +A.B.c +A.B.d + +then merge -> +"Merge introduces the following aliases:" +A.Z.c -> A.B.c +A.Z.d -> A.B.d + +/libs> delete /libs/Foo +"warning: /libs/Foo includes the following definitions that aren't anywhere else: + + A.B.e#123 + +run it again to proceed with deletion" + +/libs> alias /libs/Foo/sqrt /libs/Foo2/butt +-- we talked about combining alias & fork into a single "copy" command +/libs> +``` + +Weird thing: There's no history for `sqrt`\! + +Suppose: + +``` +data Raw = Raw + { _termsR :: Set Referent + , _typesR :: Set Reference + , _childrenR :: Map NameSegment Hash + } +``` + +``` +/libfoo/Foo <- type +/libfoo/Foo <- constructor +/libfoo/Foo.f <- term in child namespace + +/libfoo> move Foo Foo2 +/libfoo> alias Foo Foo2 +``` + +``` + +``` + +## Data types: + +Old **PrettyPrintEnv** is for pretty-pretting code, and \_\_\_ + +``` haskell +{ terms :: Referent -> Maybe HashQualified +, types :: Reference -> Maybe HashQualified } +``` + +Q: How do we want to handle lookup of names that are outside of our branch? + +Old **Namespace** + +``` haskell +{ _terms :: Relation Name Referent +, _types :: Relation Name Reference } +``` + +Old **Names** is an unconflicted **Namespace**. is for parsing code? Not sufficient to parse hash-qualified names. + +``` haskell +{ termNames :: Map Name Referent +, typeNames :: Map Name Reference } +``` + +New **Names** combines old **PrettyPrintEnv** and old **Names**: + +``` haskell +-- these HashQualified are fully qualified +{ terms :: Relation HashQualified Referent +, types :: Relation HashQualified Reference } +``` + +We should be able to construct one from a `Codebase2`, given: + +``` haskell +root :: Branch +current :: Branch +terms :: Set HashQualified +types :: Set HashQualified +``` + +or + +``` haskell +root :: Branch +current :: Branch +terms :: Set Referent +types :: Set Reference +``` + +### Needed functionality + +Parsing a .u file: + + - Look up a Reference by name + + - Look up a Reference by hash-qualified name? We could avoid this by requiring that the user deconflict the names before parsing. + +Parsing command-line arguments: + + - Look up a Reference by name. + + - Look up a Reference by hash-qualified name (possibly from among deleted names); for resolving conflicted names and edits. + + ``` + /foo> todo + + These names are conflicted: + foo#abc + foo#xyz + Use `rename` to change a names, or `unname` to remove one. + + These edits are conflicted: + bar#fff -> bar#ggg : Nat (12 usages) + bar#fff -> bar#hhh : Nat -> Nat (7 usages) + bar#fff (Deprecated) + + Use `view bar#ggg bar#hhh` to view these choices. + Use `edit.resolve` to choose a canonical replacement. + Use `edit.unreplace` to cancel a replacement. + Use `edit.undeprecate` to cancel a deprecation. + Use `edit.replace bar#hhh bar#ggg` to start replacing the 7 usages of `bar#hhh` with `bar#ggg`. + + /foo> alias bar baz + + Not sure which bar you meant? + bar#ggg + bar#hhh + Try specifying the hash-qualified name, or sort out the conflicts before + making the alias. + ``` + + ``` + /foo> edit.resolve bar#fff bar#ggg + + Cleared bar#fff -> bar#hhh + Added bar#ggg -> bar#hhh + ``` + + or + + ``` + /foo> edit.unreplace bar#fff bar#ggg + + Cleared bar#fff -> bar#ggg + ``` + +Pretty-printing: + + - Select a name by Reference + +Q: What to do about names outside the current branch? + +Option 1: Don't support names outside the current branch; user must go up a level (possibly to the root), set up the names as desired, and then descend again. + +Option 2: Introduce some syntax for names outside the current branch, e.g. `_root_.Foo.bar`. We could first lookup references in the current branch, then in the root branch, then in the history of the root branch? + +## TODO tracking refactoring of existing functionality + + - \[ \] Add edits/patches to Namespace / Branch + + - \[ \] Add patch to `NameTarget` + + - \[ \] rename `propagate` to `patch` + + - moves names from old hash to new hash, transitively, to the type-preserving frontier + + - \[ \] `list [path]` + + - ~~by default, don't descend into links with names that start with `_`~~ + + - \[ \] `todo [path]` + + - list conflicted names (hash-qualified) and edit frontier + + - \[ \] `update [path]` + + - ~~when updating a term, old names goes into `./_archived`, which will be largely conflicted.~~ + + - \[ \] `propagate [path]` + + - \[ \] `edit.resolve ` + + - +Old names use case 1: + +``` +patch: +#a -> #b +#a -> #c + +namelookup: +#b -> "foo" +#c -> "foo2" + +"You have a conflicted edit: + #a -> foo#b + #a -> foo2#c + Please choose one. +" + +/pc/libs/x> edit.resolve #a foo#b +``` + +You're in the middle of an edit, it's not type preserving + + - \[ \] `rename / move` + + - \[ \] `rename.edits` + - \[ \] `rename.type` + - \[ \] `rename.term` + + - \[ \] name / copy `copy <[src][#hash]> ` + + - \[ \] `todo [path]`, `update [path]`, `propagate [path]` + + - \[x\] Implement `Branch.sync` operation that synchronizes a monadic `Branch` to disk + + - \[x\] Implement something like `Branch.fromDirectory : FilePath -> IO (Branch IO)` for getting a lazy proxy for a `Branch` + + - Also `Branch.fromExternal : (Path -> m ByteString) -> Hash -> m (Branch m)` + - Could we create a `Branch` from a GitHub reference? Seems like yeah, it's just going to do some HTTP fetching. + + - \[x\] Tweak `Codebase` to `Codebase2` + + - \[x\] Implement a `Codebase2` for `FileCodebase2` + + - \[ \] Implement `Actions2` + + - \[ \] Implement `Editor2` + + - \[ \] Implement `OutputMessages2` + + - \[ \] Implement `InputPatterns2` + + - \[ \] Go back and leave a spot for Link in serialized Branch0 format. + + - \[ \] Split Edits out of `Branch0` + + - \[ \] Delete `oldNamespace`, and instead add deprecated names + + - \[ \] Parsing takes a `Names`, a map from `Name`(fully-qualified name) to `Referent`/`Reference`. We should switch these from `Map` to `Name -> Optional xxx`, or even `Name -> m (Optional xxx)` + + - \[ \] `Context.synthesizeClosed` takes a `TypeLookup`, which includes a map from `Reference` to `Type`, `DataDecl`, `EffectDecl`. Shall we plan to include the full codebase here, or load them on demand? Maybe it doesn't matter yet. + + - `parseAndSynthesizeFile` takes a `Set Reference -> m (TypeLookup v Ann)`, maybe that's a good model. + + - \[ \] `add` and `update` will need a way to update the `Branch'` at the current level, and all the way back to the root. Some kind of zipper? + + - \[ \] `find` takes an optional path + + - \[ \] `fork` takes a `RepoPath` (or we could have a dedicated command like `clone`) + + - \[ \] `merge` takes at least a path, if not a `RepoPath` + + - \[ \] `publish` or `push`that takes a local path and a remote path? + +## Branchless codebase format + +## Commands / Usage + +``` +/> clone gh:aryairani/libfoo + Copied gh:aryairani/libfoo blah blah to /libfoo +/> undo +/> clone gh:aryairani/libfoo /libs/DeepLearning/Foo + Copied gh:aryairani/libfoo blah blah to /libs/DeepLearning/Foo +/> +``` + +`clone [path]` + +`push [path] ` + +``` +/> cd projects +/projects> rename FaceDetector FaceDetector/V1 +/projects> cd FaceDetector +/projects/FaceDetector> cp V1 V2 +``` + +`cd ` — support relative paths? + +`cp ` + +``` +/projects/FaceDetector> replace.scoped V2 /libs/DeepLearning/Foo/thing1 mything1 + + Noted replacement of thing1#af2 with mything#i9d within /projects/FaceDetector/V2. +``` + +``` +replace.write +todo + +``` + +``` +/projects/FaceDetector> todo + ...7 things... +/projects/FaceDetector> todo / + ...33 things... +/projects/FaceDetector> +``` + +`mv` / `rename` command: can refer to Terms, Types, Directories, or all three. Use hash-qualified names to discriminate. + +## Namespaces + +``` haskell +data Branch' m = Branch' (Causal m Namespace) + +data Causal m e + = One { currentHash :: Hash, head :: e } + | Cons { currentHash :: Hash, head :: e, tail :: m (Causal e) } + -- The merge operation `<>` flattens and normalizes for order + | Merge { currentHash :: Hash, head :: e, tails :: Map Hash (m (Causal e)) } + +-- just one level of name, like Foo or Bar, but not Foo.Bar +newtype NameSegment = NameSegment { toText :: Text } -- no dots, no slashes +newtype Path = Path { toList :: [NameSegment] } + +data Namespace m = Namespace + { terms :: Relation NameSegment Referent + , types :: Relation NameSegment Reference + , children :: Relation NameSegment (Branch' m) + } +``` + +**Repo format:** + +``` +# types +.unison/types//compiled.ub +.unison/types//dependents/ +.unison/types/_builtin//dependents/ + +# terms +.unison/terms//compiled.ub +.unison/terms//type.ub +.unison/terms//dependents/ +.unison/terms/_builtin//dependents/ + +# branches (hashes of Causal m Namespace) +.unison/branches/.ubf +.unison/branches/head/ -- if several, merge to produce new head. +``` + +### Backup Names? + +For pretty-printing, we want a name for every hash. Even for hashes we deleted the names for. 😐 + + - When we delete a name `x` from path `/p` (i.e. `/p/x`), we add the name `/_deleted/p/x`. + + - Or, do we just disallow removing the last name of things with dependencies? + + - When deleting a name, notify the user of the remaining names. + +## Edits + +``` haskell +newtype EditMap = EditMap { toMap :: Map GUID (Causal Edits) } + +data Edits = Edits + { terms :: Relation Reference TermEdit + , types :: Relation Reference TypeEdit + } + +type FriendlyEditNames = Relation Text GUID +``` + +**Repo format:** + +``` +.unison/edits// +.unison/edits//name/ -- (base58encode (utf8encode "name of the edit")) +.unison/edits//head/ -- if several, merge to produce new head. +``` + +### TODO: How to share these edits? + + - It could be the same as sharing Unison names (e.g. if the edits were Unison terms) + - It could be the same as sharing Unison definitions: + Make up a URI that references a repo and an edit GUID. + e.g. `https://github.com///<...>/[/hash]` + - `clone.edits [local-name]` + - `guid` comes from remote-url, and is locally given the name `local-name` + - if `local-name` is omitted, then copy name from `remote-url`. + - if `local-name` already exists locally with a different `guid`, then abort. + +### Editsets as first-class unison terms: + +Benefits: + + - Don't have two separate dimensions of forking and causality (namespace vs edits). + - Makes codebase model way simpler to explain. \<— BFD + +Costs / todo: + +Q: Do we allow users to edit `EditSets` using standard `view` and `edit` in M1? + +If Yes: + + - EditSets are arbitrary Unison programs that need to be evaluated. Once evaluated, they would have a known structure that can be decomposed for EditSet operations. We would need: + + - - \[ \] some new or existing syntax for constructing EditSet values + - \[x\] a way to evaluate these unison programs + - \[ \] a way to save evaluated results back to the codebase / namespace + - Q: Do we evaluate and save these eagerly or lazily? + - \[ \] a way in Haskell to deconstruct the EditSet value + - \[ \] a way to modify (append to) values of that type using CLI commands. e.g. `update` ? + - either `update` calls a unison function that + +If no (we don't provide user syntax for constructing `EditSets` in .u file): + + - EditSets are part of the term language? + - Or a constructor with a particular hash? (Applied to Unison terms) + +## Collecting external dependencies + +If a subtree references external dependencies, they should be given local names when exporting. + +Given: + +``` +/A/B/c#xxx +/D/E/f#yyy (depends on #xxx, #zzz) +/D/G/h#zzz +/libs/G/bar#zzz +``` + +If `/D/E` is published, what names should be assigned to `#xxx`, `#zzz`? + +### Idea 1: Names relative to nearest parent + +Collect external dependencies under `Dependencies`, using names relative to the nearest parent in common with the publication point? + +i.e.: + +``` +f#yyy +Dependencies/A/B/C#xxx +Dependencies/G/h#zzz +``` + + + + + +### Idea 2: Somehow derive from qualified imports used? + +If + +### Idea 3: Surface the condition\* to the user + +\*the condition = the publication node contains definitions that reference definitions not under the publication node. + +Ask them to create aliases below the publication point? + +### Idea 4: Add external names to `./_auxNames/` + +The nearest aux-name would only be used to render code only if there were no primary names known. + +### Idea 5: Something with symlinks + +``` haskell +data Branch' m = Branch' (Causal m Namespace) + +data Causal m e + = One { currentHash :: Hash, head :: e } + | Cons { currentHash :: Hash, head :: e, tail :: m (Causal m e) } + -- The merge operation `<>` flattens and normalizes for order + | Merge { currentHash :: Hash, head :: e, tails :: Map Hash (m (Causal m e)) } + +-- just one level of name, like Foo or Bar, but not Foo.Bar +newtype NameSegment = NameSegment { toText :: Text } -- no dots, no slashes +newtype Path = Path { toList :: [NameSegment] } + +data Namespace m = Namespace + { terms :: Relation NameSegment Referent + , types :: Relation NameSegment Reference + , children :: Relation NameSegment (Link m) + } + +data Link m = LocalLink (Branch' m) | RemoteLink RemotePath +data RemotePath = Github { username :: Text, repo :: Text, commit :: Text } -- | ... future +``` + +This lets us avoid redistributing libs unnecessarily — let the requesting user get it from wherever we got it from. But it doesn't specifically address this external naming question. + +We might be publishing `/app/foo` which references definitions we got from `repo1`. Somewhere in our tree (possibly under `/app/foo` and possibly not?) we have a link to `repo1`. + +Somewhere under `/app/foo` we reference some defn from `repo1`. + +Transitive publication algorithm: + + - find all the things that you're referencing + - the things you're publishing that aren't under the pbulication point need to be resolved + - they're local, and need to be given names under the publication point + - user is notified, or we do something automatic + - they're remote, and we need to include, in the publication, a link to the remote repo. + - user is notified, or we do something automatic + - "Something automatic" will be: + - mirror the dependency names from our namespace into `./_Libs`; if it would produce naming conflicts to use `./_Libs`, then `_Libs1`, etc. + - Or, just dump them into `./_Libs` and if doing so produces naming conflicts, force the user to resolve them before publishing. + +## Syncing with remote codetrees + +``` haskell +-- names tbd +data BranchPath = BranchPath RepoRef Path +data RepoRef = Local | GithubRef { username :: Text, repo :: Text, treeish :: Text } + +``` + +``` +/libs/community/DL +``` + +becomes +​\`\`\`haskell +BranchPath Local (Path \["libs","community","DL"\]) + +``` + + + +``` + +gh:/\[/\]\[?ref=\] -- defaults to repo's `default_branch` + +e.g. gh:aryairani/unison/libs?ref=topic/370 + +```` +becomes +​```haskell +BranchPath (GithubRef "aryairani" "unison" "topic/370") (Path ["libs"]) +```` + +or + +``` +gh:user/repo[:treeish][/path] + +e.g. github:aryairani/unison:topic/370/libs +``` + +becomes + +``` haskell +BranchPath (GithubRef "'aryairani" "unison" "topic/370") (Path ["libs"]) +``` + +## Github Notes + +Github uses a few different URL schemes. They call the ones you can pluck off their website "html\_url"s. They let you refer to files and directories, and can be parameterized by git *treeish* (branch, tag, commit). + +We can interpret these to refer to the root of a namespace. https://github.com/unisonweb/unison can be interpreted as: + +``` haskell +GithubRef "unisonweb" "unison" <$> getDefaultBranch "unisonweb" "unison" +``` + +The Github website will let you navigate to a git branch, e.g https://github.com/unisonweb/unison/tree/topic/370/ can be interpreted as: + +``` haskell +GithubRef "unisonweb" "unison" <$> matchBranch "unisonweb" "unison" "topic/370/" +``` + +Branch names can contain slashes, such as `topic/370`, complicating parsing if there's meant to be path info following the branch name. + +1. Fortunately, if you have a git branch `a/b` then it's not possible to create branches `a` or `a/b/c`. So you can load the [list of branches](https://api.github.com/repos/unisonweb/unison/branches) from JSON, and then test them against that treeish-prefixed path without ambiguity. +2. Github's website doesn't know how to navigate into `Causal` structures, so it's never going to give us URLs with paths into a Unison namespace. So maybe this is a moot point. + +So, I would still go ahead with the made-up `gh:username/repo[:treeish][/path]` URI scheme; we can try to support the other URLs mentioned above, and let them refer to the root of the published namespace. + +Our Javascript viewer can be made to create URLs with query params or fragments in them that can indicate the Unison path, and those can be the ones we share in tweets, etc: + +http(s)://.github.io/?branch=\&path= with the default branch being the head, and the default path being `/`. + +``` + + +``` diff --git a/unison-src/transcripts/project-outputs/docs/codebase-editor-design.output.md b/unison-src/transcripts/project-outputs/docs/codebase-editor-design.output.md new file mode 100644 index 0000000000..8d3f24f0f0 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/codebase-editor-design.output.md @@ -0,0 +1,511 @@ +Note: initial draft, probably a lot of rough edges. Comments/questions/ideas are welcome\! + +# Editing a Unison codebase + +The Unison codebase is not just a mutable bag of text files, it's a structured object that undergoes a series of well-typed transformations over the course of development, yet we can still make arbitrary edits to a codebase. The benefits of the Unison approach which we'll see are: + + - Incremental compilation is perfectly precise and comes for free, regardless of what editor you use. You'll almost never spend time [waiting for Unison code to compile](https://xkcd.com/303/), *no matter how large your codebase*. + - Refactoring is a controlled experience where the refactoring always typechecks and you can precisely measure your progress, so arbitrary changes to a codebase can be completed without ever dealing with a depressingly long list of (often misleading) compile errors or broken tests\! + - Codebase changes can be worked on concurrently by multiple developers, and many situations that traditionally result in incidental merge conflicts or build issues can no longer occur. (e.g., Alice swapped the order of two definitions in a file, conflicting with Bob's adding an unrelated definition.) + - Renames, even bulk renames of whole packages of definitions, are 100% accurate and fast. When it's this easy to rename things, there's less anxiety about picking names and less need to pick the perfect name at the moment you start writing something. + - We can assign multiple names to the same definitions, and you can choose which naming you prefer and publish your naming schemes for others to use if they wish. [Bikeshedding](http://bikeshed.com/) over names can be a thing of the past (or at least vastly reduced 😀). + - Dependency hell is also vastly reduced: many situations that contribute to dependency hell simply cannot arise with the Unison codebase model. + - As an added bonus, it's no problem to use different versions of some library in different parts of your application when convenient, just as you might use two unrelated libraries in your application. + - It's easy to mix and match parts of different libraries into a custom bundle, which others can use, all while retaining full compatibility with the existing libraries that the bundle draws from. + - Publishing code is trivial; it won't require any additional steps beyond pushing to a git repository or shared filesystem. (Other filesystem-like services can be supported in the future.) + - Import statements are first-class values which can be shared and aggregated and published for consumption by others. No more project-wide import boilerplate at the top of every file\! + - And this is all done in a backwards compatible way using existing tools: you can still use your favorite text editor, can still version your code with Git, use GitHub, etc. + +Warning: once you experience this mode of editing a codebase and the control, safety, and ease of it, the "mutable bag of text files" model of a codebase may start to seem barbaric in comparison. 😱 + +## The big idea 🧠 + +Here it is: *Unison definitions are identified by content.* Therefore, there's no such thing as changing a definition, there's only introducing new definitions. What can change is how we map definitions to human-friendly names. e.g. `x -> x + 1` (a definition) vs `Integer.increment` (a name we associate with it for the purposes of writing and reading other code that references it). An analogy: Unison definitions are like stars in the sky. We can discover new stars and create new star maps that pick different names for the stars, but the stars exist independently of what we choose to call them. + +With this model, we don't ever change a definition, nor do we ever change the mapping from names to definitions (we call such mappings "namespaces"). A namespace is simply another kind of definition. Like all definitions, it is immutable. When we want to "change" a namespace, we create a new one, and *change which namespace mapping we are interested in*. This might seem limited, but it isn't at all, as we'll see. + +From this simple idea of making definitions (including definitions of namespaces) immutable, we can build a better development experience around codebase editing with all of the above benefits. + +## The model + +This section gives the model of what a Unison codebase is and gives its API. Later we'll cover what the actual user experience is for interacting with the model, along with various concrete usage scenarios. The model deals with a few types, `Code`, `Codebase`, `Release`, and `Branch`: + + - `Code` could be a function or value definition (a `Term`) or a `TypeDeclaration`. Each `Term` in the `Codebase` also includes its `Type`. A Unison codebase contains no ill-typed terms. Each `Code` also knows its `Author` and `License`, which are just terms. + - `Namespace` denotes a `Map Name Code`. It defines a subset of the universe of possible Unison definitions, along with names for these definitions. (The set of definitions it talks about is just the set of values of this `Map`.) + - `Release` denotes a `Namespace -> Namespace`. It provides a function for "upgrading" from old definitions, and the "current" `Namespace` can be obtained by giving the `Release` the empty `Namespace`. + - `Branch` denotes a `Causal (Map Code (Conflicted CodeEdit, Conflicted NameEdits))`, which comes equipped with a commutative `merge` operation and can be converted to a `Release` assuming no conflicts. A `Branch` represents a `Release` "in progress". We discuss the `Causal` and `Conflicted` types later. + - `Codebase` denotes a `Set Code`, a `Map Name Branch` of named branches, and a `Map Name Release` of named releases. + +A `Release` can be sequenced with another `Release`: + +``` haskell +sequence : Release -> Release -> Release +sequence up1 up2 nsi = Map.unionWith const (up2 . up1 $ nsi) (up1 nsi) +``` + +A `Branch` has two important operations: + + - A commutative `merge` operation for combining concurrent edits. + - An associative `sequence` operation for sequencing edits. + +`Causal a` has 5 operations, specified algebraically here (we give an implementation later): + + - `before : Causal a -> Causal a -> Bool` defines a partial order on `Causal`. + - `head : Causal a -> a`, which represents the "latest" `a` value in a causal chain. + - `one : a -> Causal a`, satisfying `head (one hd) == hd` + - `cons : a -> Causal a -> Causal a`, satisfying `head (cons hd tl) == hd` and also `before tl (cons hd tl)`. + - `merge : CommutativeSemigroup a => Causal a -> Causal a -> Causal a`, which is associative and commutative and satisfies: + - `before c1 (merge c1 c2)` + - `before c2 (merge c1 c2)` + - `sequence : Causal a -> Causal a -> Causal a`, which is defined as `sequence c1 c2 = cons (head c2) (merge c1 c2)`. + - `before c1 (sequence c1 c2)` + - `head (sequence c1 c2) == head c2` + +Question: can we give a simple denotation for `Causal a`? (That doesn't mention hashes or anything) + +Thought: `Causal` could also be a `Comonad` (in the category of commutative semigroups), where each value has access to the past history at each point. + +``` haskell +merge : Branch -> Branch -> Branch +merge = Causal.merge + +mergePickRight : Branch -> Branch -> Branch +mergePickRight b1 b2 = Causal.mergePickRight + +data Conflicted a = Conflicted (Set a) deriving Monoid via Set + +-- note: +instance (Semigroup v, Ord k) => Monoid (Map k v) where + mempty = Map.empty + m1 `mappend` m2 = Map.unionWith (<>) m1 m2 + +-- Add a new definition; if one already exists for that name, produce a conflict +add : Name -> Code -> Branch +add n c = step (Map.insertWith (<>) n (Conflicted.one c)) + +-- Add or replace a definition, clobber any existing definitions for given name +set : Name -> Code -> Branch +set n c = step (Map.insert n (Conflicted.one c)) + +step : (a -> a) -> Causal a -> Causal a +step f c = f (head c) `cons` c + +deleteName : Name -> Branch +deleteName n = step (Map.delete n) + +deleteCode : Code -> Branch +deleteCode c = step (Map.filterValues (/= c)) +``` + +Here's `Codebase` and `Code` types: + +``` haskell +data Codebase = + Codebase { code : Set Code + , branches : Map Name Branch + , releases : Map Name Release } + +-- All code knows its dependencies, author, and license +Code.dependencies : Code -> Set Code +Code.author : Code -> Author +Code.license : Code -> License +``` + +### Implementation + +Now that we've given the denotation, here's some ideas for implementation: + +``` haskell +-- A branch can have unresolved conflicts, and we maintain some +-- history to help merge branches, respecting causality +data Branch' = Branch' + { namespace :: Map Code (Conflicted NameEdits) + , edited :: Map Term (Conflicted Edit) + , editedTypes :: Map TypeDeclaration (Conflicted TypeEdit) } + +data Branch = Branch (Causal Branch') + +-- A release doesn't have history or conflicts. +data Release' = Release' + { namespace :: Map Name Code + , edited :: Map Term Edit + , editedTypes :: Map TypeDeclaration TypeEdit } + +data Release = Release (Causal Release') + +data Conflicted a = One a | Many (Set a) + +instance Eq a => Semigroup (Conflicted a) where + One a <> One a2 = if a == a2 then One a else Many (Set.fromList [a,a2]) + One a <> Many as = Many (Set.add a as) + Many as <> One a = Many (Set.add a as) + Many as <> Many as2 = Many (as `Set.union` as2) + +data Edit = Replace Term Typing | Deprecated | .. -- SwapArguments Permutation, etc +data TypeEdit = Replace TypeDeclaration | Deprecated +data NameEdits = NameEdits { adds :: Set Code, removes :: Set Code } +data Typing = Same | Subtype | Different + +merge :: Branch -> Branch -> Branch +merge (Branch b1) (Branch b2) = Branch (Causal.merge b1 b2) + +-- produces a release if the branch is not conflicted +Branch.toRelease :: Branch -> Either Conflicts Release +Release.toBranch :: Release -> Branch +Release.toBranch = ... -- trivial, just promoting a to `Causal (Conflicted a)` +``` + +A couple notes: + + - The `Typing` indicates whether the replacement `Code` is the same type as the old `Code`, a subtype of it, or a different type. This is useful for knowing how far we can automatically apply changes in a `Branch`. + - The `Edit` type produces a `Conflict` when merged, though with more structured edits (*e.g.*, in the case of the `SwapArguments` data constructor), even more could be done here. + - A common workflow will be grabbing a release and then applying it to a branch you have in progress. There are some choices about how you do this: + - You can `sequence` the release into your branch, either before or after your existing changes. If you `sequence` the release *before* your changes, then any edits to the same `Code` will keep your version. Etc. + - You can `merge` the release into your branch, which can result in conflicts that you can then resolve however you like. + - You can break apart a release `Branch` and cherry-pick elements of the release, making different `sequence` / `merge` decisions on even a per-definition basis. It would be interesting to try to come up with some UX for doing this that isn't totally overwhelming for the user. + +Here's the `Causal` type, which is used above in `Branch`: + +``` haskell +newtype Causal e + = One { currentHash :: Hash, head :: e } + | Cons { currentHash :: Hash, head :: e, tail :: Causal e } + | Merge { currentHash :: Hash, head :: e, tail1 :: Causal e, tail2 :: Causal e } + +instance Semigroup e => Semigroup (Causal e) where + Causal a1 h1 <> Causal a2 h2 + | before h1 h2 = Causal a2 h2 + | before h2 h1 = Causal a1 h1 + | otherwise = Causal (a1 <> a2) (h1 `merge` h2) + +one :: Hashable e => e -> Causal e +one e h = One (hash e) e + +cons :: Hashable e => e -> Causal e -> Causal e +cons e tl = Cons (hash e <> currentHash tl) e tl + +merge :: (Hashable e, Semigroup e) => Causal e -> Causal e -> Causal e +merge h1 h2 | h1 `before` h2 = h2 + | h2 `before` h1 = h1 + | otherwise = Merge (currentHash h1 <> currentHash h2) (head h1 <> head h2) h1 h2 + +sequence :: Hashable e => Causal e -> Causal e -> Causal e +sequence a (One h e) = cons e a +sequence a (Cons h e tl) = cons e (sequence a tl) +sequence a (Merge h e l r) = merge e (sequence a l) r +-- note: if causal had a `split` operation, we'd need to sequence on both sides + +-- Does `h2` incorporate all of `h1`? +before :: Causal e -> Causal e -> Bool +before h1 h2 = go (currentHash h1) h2 where + go h1 (One h _) = h == h1 + go h1 (Cons h _ tl) = h == h1 || go h1 tl + go h1 (Merge h _ left right) = h == h1 || go h1 left || go h1 right +``` + +Operations on a `Branch`: + + - `add` a `Name` and associated `Code` to a `Branch`. + - `rename name1 name2`, checks that `name2` is available, and if so does the rename. + - `update oldcode oldnameafter newcode newname`, check that `newname` is available, if so add it to `edited` map. `oldcode` will be referred to using some fully-qualified name. `oldnameafter` will be the name for `oldcode` after the update, just like for `deprecate`. + - `deprecate oldcode newname` marks `oldcode` for deprecation, with optional `newname`, also adds this to `edited` map. + - `empty` creates a `Branch 0 newGuid Map.empty Map.empty Map.empty`, satisfies `merge b empty ~= b` and `merge empty b ~= b`, where `~=` compares branches ignoring their `branchId`. + - `fork b == merge new-branch b` + +A branch is said to *cover* a `cb : Set Code` when it has been developed to the point that the remaining updates are type-preserving and can thus be applied automatically. More precisely, a Branch `c` covers a `cb : Set Code` when all dependents in `cb` of type-changing edits in `c` (including deprecations) also have an edit in `c`, and none of the edits are in a conflicted state. If we want to measure how much work remains for a Branch `c` to cover a `cb : Codebase`, we can count the transitive dependents of all *escaped dependents* of type-changing edits in `c`. An *escaped dependent* is in `cb` but not `c`. This number will decrease monotonically as the `Branch` is developed. + +*Related:* There are some useful computations we can do to suggest which dependents of the frontier to upgrade next, based on what will make maximal progress in decreasing the remaining work. The idea is that it's useful to focus first on the "trunk" of a refactoring, which lots of code depend on, rather than the branches and leaves. Programmers sometimes try to do something like this when refactoring, but it can be difficult to know what's what when the main feedback you get from the compiler is just a big list of compile errors. + +We also typically want to encourage the user to work on updates by expanding outward from initial changes, such that the set of edits form a connected dependency graph. If the user "skips over" nodes in the graph, there's a chance they'll need to redo their work, and we should notify the user about this. It's not something we need to prevent but we want the user to be aware that it's happening. + +Thought: we may want to prevent a merge of `source` into `target` unless `source` covers all the definitions in `target` (either in the `namespace` or in the values of the `edited` `Map`). The user could develop `source` until it covers `target`, then the two branches can be merged. Alternately, we could just allow the branches to exist in an inconsistent state and prompt the user to fix these inconsistencies. + +The `namespace` portion of a `Branch` can be built up using whatever logic the programmer wishes, including picking arbitrary new names for definitions, though very often, the names output by a `Branch` will be the same as or based on the names assigned to old versions of definitions. + +This is it for the model. The rest of this document focuses on how to expose this nice model for use by the Unison programmer. + +## The developer experience + +This section very much a work in progress. + +When writing code, a developer has full access to all code that's been written, just by using different imports. Here's a sketch of developer experience: + +``` +> branch scratch +There's no branch named 'scratch' yet. +Would you like me to create it and switch to it? y/n +> y +✅ I've created and switched to branch 'scratch'. + Note: `> branch` can be used to show the active branch. +> branch +'scratch' at version 0 +> watch foo.u +Watching foo.u for definitions to add to 'scratch' branch... +Noticed a change, parsing and typechecking... +🛑 I've found errors in 'foo.u', here's what I know: +... +✅ I've parsed and typechecked definitions in foo.u: `wrangle` + Would you like to add this to the codebase? y/n +> y +✅ It's done, using 'Alice' as author, Acme, Inc. as copyright holder, + license is BSD3 (your chosen defaults). Use `> help license` if you'd + like guidance on how to change any of this. +> branch +'scratch' at version 1 +> branch series/24 +✅ Switched to 'series/24' branch +> alias scratch.wrangle Acme.Alice.utils.wrangle +✅ I've marked a new definition 'Acme.Alice.utils.wrangle' for publication + in 'series/24' branch. +``` + +*Question:* what if `Acme.Alice.utils.wrangle` already exists in the 'series/24' branch? Unison reports a conflict and forces the user to pick a unique name: + +``` +> alias scratch.wrangle Acme.Alice.utils.wrangle +🛑 I'm afraid there's already a definition in this branch called 'Acme.Alice.utils.wrangle'. + You can either `> move Acme.Alice.utils.wrangle ` or choose + a different local name for `scratch.wrangle`. +``` + +Another possibility: the name already exists locally and is coincidentally bound to the exact same `Code`, in which case we get a warning: + +``` +> alias scratch.wrangle Acme.Alice.utils.wrangle +🔸 There was already a definition `Acme.Alice.utils.wrangle` which was + exactly equivalent to `scratch.wrangle`. +``` + +*Question:* what if `scratch.wrangle` also exists in this branch? If you're using `alias`, you are always referring to another branch as the first argument. You can't alias a definition in the current branch as that would mean that a `Code` in this branch no longer had a unique name. (Alternate answer: some special syntax to disambiguate referring to another branch, like `scratch:wrangle` or `scratch/wrangle`, though if we do that, we would need to disallow that separator in branch identifiers) + +*Question:* How does Alice test that her changes actually work? She probably needs to propagate them out as far as her tests, assuming that's possible. But we obviously don't want to be recompiling and regenerating binaries on every edit. *Answer:* The namespace of a branch refers to the latest version of everything, propagated as far as possible. Anything else has the prefix `old`. We achieve this just by keep a `Map Reference Reference` of type-compatible replacements which we then use in various places (such as the runtime) to do on-the-fly rewriting. + +*Question:* What about "third-party" dependencies? How do those fit in here? *Answer:* These are tracked with first-class imports. + +Assuming that is successful: + +``` +> delete branch scratch +✅ I've deleted the 'scratch' branch. +> git commit push +✅ I've committed and pushed 'series/24' updates (listed below) + to https://github.com/acme/acme + ... +``` + +It's not generally necessary to create a new branch every time, you can also just add definitions directly to the current base branch. + +The `> branch blah` command creates a new branch with no ancestors. You can also create branches whose ancestor is the current branch, which is useful for a refactoring that you eventually want to merge back into the current branch. + +``` +> fork major-refactoring +✅ I've created and switched to new branch 'major-refactoring'. + It's a child of branch 'series/24' version 29381. +> watch foo.u +... +✅ Added definition 'Acme.transmogrify' +> branch series/24 +✅ Switched to 'series/24' branch +> merge major-refactoring +✅ Updated 182 definitions, no conflicts +> save release/24 +✅ Saved 'series/24' as branch 'release/24' +``` + +Note that a `use release/24` in your Unison code can be used to access the namespace of a branch. + +### Publishing + +To publish something for use by others, users just share a URL that links to their GitHub repository. There's no separate step of creating some artifact like a jar and uploading that to some third-party package repository. That URL is something like `https://acme.github.io/unison/QjdBS8sdbWdj`, where the `QjdBS8sdbWdj` is a Base 58 encoding of a particular Unison hash. The GitHub repository format for Unison doubles as a GitHub pages site so anyone can explore the repository from that point, obtaining pretty-printed and hyperlinked source code, pretty HTML documentation, and so on. + +To start using someone else's published code, you can do a `get`: + +``` +> get https://acme.github.io/unison/QjdBS8sdbWdj +About to fetch 'https://acme.github.io/unison/release/24'. +choose a name for the namespace (suggest 'acme'): acme + +Fetching... + +✅ Loaded 1089 definitions into acme/release/24 + Use `> docs acme/release/24` +``` + +The URL here can point to a single definition, in which case it along with its transitive dependencies are added to the local codebase. In this case, it doesn't get a name, but you can refer to it by hash. Nameless code in the codebase probably records the URL where it was loaded from since that URL might have useful information about the hash. We might also by default look for `/docs-**.link` or something to fetch documentation. + +Alternately, we can juse `use` a release URL directly, as a namespace, without a `> get` happening first. Perhaps `use from `. `` includes the hash of the release, which is a Unison Term including the namespace itself and references to a bunch of code. This is downloaded, along with all of its transitive dependencies. The namespace is spliced into the current parsing environment according to the import expression of the `use` statement. + +Question: How do you discover new versions of hashes? (including hashes that refer to docs) + +**Note:** In the event of naming conflicts when doing a `get` (if you already have a branch with that name locally), Unison will force you to pick a different name. + +## Repository format + +A design goal of the repository format is that it can be versioned using Git (or Hg, or whatever), and there should never be merge conflicts when merging two Unison repositories. That is, Git merge conflicts are a bad UX for surfacing concurrent edits that the user may wish to reconcile. We use a few tricks to achieve this property: + + - Sets are represented by directories of immutable empty files whose file names represent the elements of the set - the sets are union'd as a result of a Git merge. Deletions are handled without conflicts as well. + - Likewise, maps are represented by directories with a subdirectory named by each key in the map. The content of each subdirectory represents the value for that key in the map. + - When naming files according to a hash of their content, git will never produce a conflict as a result of a `merge`. + +Here's a proposed repository representation: + +``` text +terms/ + jAjGDJnsdfL/ + compiled.ub -- compiled form of the term + type.ub -- binary representation of the type of the term + index.html -- pretty, hyperlinked source code of the term + reference-english-JasVXOEBBV8.link -- link to docs, in English + reference-spanish-9JasdfjHNBdjj.link -- link to docs, in Spanish + doc-english-OD03VvvsjK.link -- other docs + license-8JSJdkVvvow92.link -- reference to the license for this term + author-38281234jf.link -- link to the hash of the authors list +types/ -- directory of all type declarations + 8sdfA1baBw/ + compiled.ub -- compiled form of the type declaration + index.html -- pretty, hyperlinked source code of the type decl + reference-english-KgLfAIBw312.link -- reference docs + doc-english-8AfjKBCXdkw.link -- other docs + license-8JSJdkVvvow92.link -- reference to the license for this term + author-38281234jf.link -- link to + constructors/ + 0/type.ub -- the type of the first ctor + 1/type.ub -- the type of the second ctor +branches/ + branchGuid7/ + myAwesomeBranch.name + asdf8j23jd.ubf -- unison branch file, named according to its hash (so no conflicts), deserializes to a `Branch` +releases/ + releaseName1/ + asdf8j23jd.ur -- unison release file, named according to its hash, deserializes to a `Release` +``` + +Thought: might want to make `Release` representation more granular, so can pull out the namespace separate from the upgrade function. + +When doing a `git pull` or `git merge`, this can sometimes result in multiple `.ubf` files under a branch. We simply deserialize both `Branch` values, `merge` them, and serialize the result back to a file. The previous `.ubf` files can be deleted. + +Observation: we'll probably want some additional indexing structure (which won't be versioned) which can be cached on disk and derived from the primary repo format. This is useful for answering different queries on the codebase more efficiently. + +## Questions + +Some good questions from @atacratic: + +> What's a typical workflow, say for a few developers working on different topics? + +I think very similar to now in "masterless" development. You create `series/1` branch, branch topics off that and merge into it, cut `release/1`, then create `series/2`, etc. + +To cut a release: + + - Convert `series/1` to `release/1`. + - Create a new branch, `series/2`, which is *empty*. + - Start hacking on `series/2`, likely referencing things by name in `release/1` (`edit release/1/math.random` might be a thing you do to edit a definition from a prior release) + +Questions: + + - Maybe it's fine to just have an indefinitely-long running master branch and just cut releases off of that? This might be equivalent to sequencing all the releases that come before each release (maybe less flexible). + - Let's keep in mind that we might want to expose some simplified workflow for beginners so they aren't forced to learn about all this branch management stuff before even writing "hello world\!" + - Should be easy for advanced users too, no unnecessary juggling. + +> Where in the old ways people would have made a commit, do they now make a `Branch`? How do things proceed as we build up several of those for a topic? + +Same as now. You don't create a branch for every little change necessarily, though you could. You often just make changes to a branch directly. In terms of recording history, we can "git commit" whenever is convenient. + +> How does it work if you're editing "your" code as well as "other" people's code? + +Thought: You can reference any code in any release just with imports. You can also edit any code from any release, even from a release you didn't create. I suspect you'll want to give some qualified name to a definition that you edit which comes from another user's library. (For instance, I might republish a new version of `Runar.sort` under `Paul.patches.Runar.sort` in the branch I'm working on... and then I might contact `Runar` to get that change merged "upstream", something something...) + +> Where can they see their version history? Presumably not in the underlying git repo, if there's a branch for every incremental change? + +To start, git history is probably okay (though we could probably present it nicer). + +> Is the typical github PR now the addition of a branch? Or an in-place update to the master release? + +Might be addition of a new Unison branch, a merge or commits to some Unison branch, or a new Unison release. + +> When is a branch B converted to a release? + +Whenever is convenient or you want to record a snapshot. + +> What are the implications of the loss of all the Causal history at that point? Will other people find it harder to merge onto that release, if they've been working concurrently with what was in B, maybe sharing changes with it? + +Good questions. Maybe convention is to just use a single long-running branch, with all releases cut from that branch (similar to how people use `master` today?) For efficiency, want to have branch representation such that don't have to load it all in memory. + +I think this is overall TBD. + +> I can't actually put my finger on why we need a commutative merge operation. + +It needs to be commutative so that Alice and Bob can apply their changes in either order and still reach the same repository state. + +> Ditto I can't explain why we need Causal. I guess it helps spot when one edit is a merge ancestor of another. But why do we need that? + +So that in merging, we have enough information to know that one edit supercedes another. Similar to Git tracking enough info to be able to do "fast-forward" merges. If we didn't have this, we'd get spurious conflicts when forking off branches and then merging them back in. + +> Why is Causal being applied on a per-name basis? i.e. why is it Map Name Causal (Conflicted Edit) rather than Causal (Map Name (Conflicted Edit))? + +No good reason\! We changed this, to put the `Causal` on the outside. + +> You've got Edit as a forgetful thing - it knows the new term but not the old one. I've got a feeling we're going to want to be able to reverse edits (and hence branch upgrades), so we should store the old value too. + +Now we are keying on `Code` instead of `Name` so I think we have enough information in the current representation to be able to invert a `Branch`? + +> If Alice renames a term from X to Y, and Bob renames it from X to Z, what's their experience when merging? + +They get a conflict which is easy to merge automatically, and you can imagine different choices: a) Allow both names b) Use Alice's name c) Use Bob's name. It's fine to have multiple names for the same code, though you will have to pick one when pretty-printing the code. + +> How does conflict resolution interact with propagation? So, if term f has some conflicting edits, does that mean that all its transitive dependents have conflicts too? How does someone resolve that? + +Yes, but we'll give tooling to help resolve all these conflicts in an efficient order (probably want to resolve conflicts in dependencies of a term before resolving conflicts in the term itself). + +> How are you going to render a Conflicted Edit to the user doing conflict resolution? Surely they want to know which source branches/releases each version of the edit is coming from, but I can't see how you'll know that. + +Good point. We could include some more metadata on each `Edit` to help with this. + +> Is this bit still current? "The namespace of a branch refers to the latest version of everything, propagated as far as possible. Anything else has the prefix old." Is doing propagations going to add a bunch of new names to the namespace automatically? + +No longer current. The branch's namespace is actually minimal and doesn't include any transitive updates by default (though you could "bake" the branch to propagate updates). + +> Is it possible to rename a branch or a release? + +Sure. Might have a GUID for each branch and/or release, with a name that can be changed associated with that GUID. + +> I have an urge to make it turtles all the way down: to make the names of branches and releases part of the namespaces we're trying to manage. Have you explored that line of thinking? + +I like it. It would be cool if the codebase is something you can talk about from within Unison, so `Branch` and `Release` are types in Unison that come with some nice Unison API. + +Not sure if we need to do this right away though. + +> Trying to work out the boundary between the unison codebase editor and the underlying VCS: is there a 'git blame' of any kind, in the new world? is there a history (of a term, a name, or the codebase as a whole)? + +Might track this in the `Edit`, also any new `Code` will have associated metadata such as author, license, timestamp, possibly descendants / ancestors... + +Note: we won't very granular information about who wrote which part of each expression, though we could recover information by doing tree diffs on the history. + +> is there a way to rewind the clock and get access to a previous revision in Unison-land, i.e. without using the VCS? + +Yeah, all branches and releases are accessible to you. But if you want to access a point in time of some branch, you need to use the VCS. Could imagine doing something about that. + +Sketch: + + - Can refer a branch at particular state just by hash, which picks out some subgraph of a `Causal`. But refering to hashes is annoying (though we can view a log of changes). + - Put timestamp and user id in `Causal`, in addition to the hash. + - Now can do queries like "go back in time to 1 week ago". + +> How much of the codebase model will be internalised into Unison? Will I be able to talk about a Namespace or a Branch in Unison code, say if I'm using a Codebase ability? I have a smalltalk-ish desire for the answer to be yes: if Unison can describe its own UI domain model, and is its own domain language, then we might end up with a more consistent and composable world, in which Unison tooling can be written in Unison, and in which people can talk about Unison in the same universe as they talk in Unison. + +I like it. This API should be exposed to Unison so you can write tooling for Unison in Unison. + +> In your code for Semigroup Causal here, I can't work out if it's meant to be right-biased or left-biased - the first two lines make it seem like the former, and the next two the latter. Might have misunderstood though. + +Code might be wrong, but I think the `Causal` semigroup was meant to be a commutative merge operation, but we should make that more explicit (the semigroup calls `Causal.merge` for instance) + +## Notes and ideas + +You can have first-class imports with a type like: + +``` haskell +type Namespace = Map Name (Set Code) -> Map Code [NameEdit] +``` + +There's a nice little combinator library you can write to build up `Namespace` values in various ways, and we can imagine the Unison `use` syntax to be sugar for this library. + +**Arya**: I'm still thinking we'll want something like scopes to be able to apply a branch to a prefix in a "clone package foo.x to foo.y and apply these changes" sort of way. diff --git a/unison-src/transcripts/project-outputs/docs/commandline-editor-dev.output.md b/unison-src/transcripts/project-outputs/docs/commandline-editor-dev.output.md new file mode 100644 index 0000000000..6db18f6768 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/commandline-editor-dev.output.md @@ -0,0 +1,11 @@ +The Unison CLI code is made up of a few components: + +`CommandLine.Main` sets up threads to watch the filesystem and parse `stdin` to produce `Editor.Event`s and `Editor.Input`s respectively. + +`Editor.Input` parsers are defined in InputPattern.hs and InputPatterns.hs. + +`Action.loop` receives `Editor.Event`s and `Editor.Input`s and executes `Editor.Command`s. This loop can't use `IO` or access the `Codebase` -- any access to these things must come from what `Editor.Command` provides. + +`Editor.Command`s are defined in Editor.hs and interpreted by `Editor.commandLine`. `Editor.commandLine` *does* use `IO` and access the `Codebase`.\` + +One of the `Editor.Commands` that can be executed is `Notify`, which presents an `Editor.Output` to the user. Our current implementation is in `OutputMessages.notifyUser`. diff --git a/unison-src/transcripts/project-outputs/docs/comments-and-docs.output.md b/unison-src/transcripts/project-outputs/docs/comments-and-docs.output.md new file mode 100644 index 0000000000..49a7f34635 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/comments-and-docs.output.md @@ -0,0 +1,226 @@ +# Design for Unison documentation and comments + +This is a rough design of a way to supply commentary and formal documentation for Unison code. [Discuss here](https://github.com/unisonweb/unison/issues/462) and also be sure to view the raw markdown file for some embedded comments. + +## Comments + +Comments in Unison can be either line comments or block comments. It’s probably only necessary to implement one of these for a first release of Unison, but ultimately we may want to offer both. + + + +### Line comments + +Line comments can be introduced in code with a special token. For example, if we want Haskell-like syntax, the `--` token introduces a comment: + +``` +foo x y = + -- This is a comment + x + y +``` + +Line comments follow these syntactic rules: + +1. A line comment must occupy the whole line. For simplicity, it’s a syntax error to put a comment at the end of a line that contains anything other than whitespace. +2. The comment is attached to the abstract syntax tree node that is BEGUN by the token following the comment. +3. When rendering comments, the indentation should be the same as the token that follows the comment. + + + +### Block comments + +Block comments can be introduced with special brackets. For example, if we want Haskell-like syntax, the `{-``-}` brackets delimit a block comment: + +``` +foo x y = + {- This is a comment. -} x + y + +foo x y = {- comment -} (x + y) + +foo x y = + {- comment -} + (x + y) + +foo x y = + {- comment -} + x + y +``` + +Block comments follow these syntactic rules: + +1. A block comment can appear anywhere. +2. The comment is attached to the abstract syntax tree node that is BEGUN by the token following the comment. If that's not defined, could be an error, or could just use some ad hoc heuristic to find "nearest" AST node. +3. When rendering comments, the indentation should be the same as the token that follows the comment. + + + +### Comments and code structure + +Comments should not have any effect on the hash of a Unison term or type. I propose that comments be kept as an annotation on the AST rather than as part of the AST itself. This way, comments can be edited, added, or removed, without touching the AST. + + + +### Comments and the codebase + +Comments should be stored in the codebase as annotations on the syntax tree. For example, under the hash for the term (or type), we could add a new file `comments.ub` that contains the comments in pairs of `(AST node index, comment text)`. + +A future version might allow for multiple comment sets (commentary with different purposes or audiences) by adding e.g. a tag field to the comments, or having a whole `comments` directory instead of just one file. + + + +## API documentation + +Any hash in the codebase can have formal API documentation associated with it. This might include basic usage, free-text explanations, examples, links to further reading, and links to related hashes. + +Probably some flavor of Markdown is ideal for API docs. + + + +### The Unison CLI and API docs + +Ultimately we’ll want to have a more visual codebase editor (see e.g. Pharo Smalltalk), but for now we have the Unison CLI. So there ought to be a special syntax for indicating that you want to associate API docs to a definition when you `add` it to the codebase (or `update`). This syntax should be light-weight and easy to type. + +For example: + +``` +{| `foo x y` adds `x` to `y` |} + +foo x y = x + y +``` + +The rule here would be that the documentation block gets associated with the definition that immediately follows. + +Alternatively, something like: + +``` +{foo| `foo x y` adds `x` to `y`|}. +``` + + + +This would associate the documentation block to the hash named `foo` even if that hash isn’t being otherwise edited in the file. + +### Semantic content of API docs + +Wherever docs have code (in Markdown between fences or backticks), Unison should parse that code, resolve names, and substitute hashes for names. + +E.g., the doc might have a usage example: + +``` +{| +Usage: `foo x y` adds `x` to `y`. +|} +``` + +When this doc block gets processed by Unison, it should parse `foo x y` and recognize that `foo`, `x`, and `y` are free. It should replace `foo` with a hyperlink to the hash of `foo`. It should do this for every name that exists in the codebase. + +There should be some syntax to exclude a code block from this processing. + +Alternatively, we could have special syntax to indicate that something should be parsed as a Unison name. E.g. + +``` +{| +Usage: `@foo x y` adds `x` to `y`. +|} +``` + +Where `@foo` indicates that `foo` is a Unison name, we’d like an error if it isn’t, and it should be replaced in the rendered docs with a hyperlink to `foo`. + +### Opinionated doc format + +It’s possible that we’ll want to be very opinionated about how what goes into API documentation, for uniformity across libraries and ease of use. + +For example, we might have API docs support the following fields for a function definition: + + - Usage: How to call the function. E.g. “`foo x y` adds `x` to `y`”. We should maintain the invariant that the usage is correct (that it matches the name of the function and its arity). + - Examples: discussed above. + +Note that author name, time stamp, etc, can be inferred from the codebase. These are data that can be displayed in the API docs when rendered, but don’t need to be written by the author. + + + +## Docbase/Wiki + +Separately from API documentation, it would be good to be able to write tutorials or long-form explanations of Unison libraries, with links into the codebase API docs. + +We’d need to write a tool that can process e.g. Github-flavoured Markdown together with a Unison codebase. The markdown format would have Unison-specific extensions to allow hyperlinking Unison hashes as well as Tut-style evaluation of examples. + +Ideally, the documentation would be kept automatically up to date in the face of renames, etc. + +Processing has to have two distinct phases, authoring and rendering. + + - *Authoring*: you write the markdown document and use Unison human-readable names in your code. When you add your document to the docbase, all the names get replaced with Unison hashes before being stored. + - *Rendering*: A document stored in the docbase could then be rendered as e.g. HTML (or Markdown) where Unison hashes are turned back to human-readable names from the codebase, and hyperlinked to the API documentation for the hashes. + + + +### Transclusion + +A particularly useful feature for this kind of documentation tool would be *transclusion* of code. E.g. with a syntax like… + +``` +{:transclude MyLibrary.myFun} +``` + +The tool could render that as a code block containing the definition of `MyLibrary.myFun`. Ideally that would register this document as a dependency of `MyLibrary.myFun` and propagation of updates could work the same way as for code. + +It would be good to also have a way (as in Elm) of transcluding the API docs of individual types and functions in a document. + +This is a way of keeping documentation automatically up to date, at least partially. diff --git a/unison-src/transcripts/project-outputs/docs/configuration.output.md b/unison-src/transcripts/project-outputs/docs/configuration.output.md new file mode 100644 index 0000000000..0bf4d06de5 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/configuration.output.md @@ -0,0 +1,176 @@ +# Configuration + + - [UCM Configuration](#ucm-configuration) + - [`UNISON_DEBUG`](#unison_debug) + - [`UNISON_PAGER`](#unison_pager) + - [`UNISON_LSP_PORT`](#unison_lsp_port) + - [`UNISON_LSP_ENABLED`](#unison_lsp_enabled) + - [`UNISON_SHARE_HOST`](#unison_share_host) + - [`UNISON_SHARE_ACCESS_TOKEN`](#unison_share_access_token) + - [`UNISON_READONLY`](#unison_readonly) + - [`UNISON_ENTITY_VALIDATION`](#unison_entity_validation) + - [Local Codebase Server](#local-codebase-server) + - [Codebase Configuration](#codebase-configuration) + +## UCM Configuration + +### `UNISON_DEBUG` + +Enable debugging output for various portions of the application. +See `lib/unison-prelude/src/Unison/Debug.hs` for the full list of supported flags. + +E.g. + +``` sh +# Enable ALL debugging flags (likely quite noisy) +$ UNISON_DEBUG= ucm +# Enable timing debugging, printing how long different actions take. +$ UNISON_DEBUG=timing ucm +# Enable LSP and TIMING debugging +$ UNISON_DEBUG=lsp,timing ucm +``` + +### `UNISON_PAGER` + +Allows selecting which pager to use for long command outputs. +Defaults to `less` on Linux & Mac, `more` on Windows + +E.g. + +``` sh +# User more instead of less +$ UNISON_PAGER=more ucm +``` + +### `UNISON_LSP_PORT` + +Allows selecting the port to run the LSP server on. Defaults to `5757`. + +E.g. + +``` sh +$ UNISON_LSP_PORT=8080 ucm +``` + +### `UNISON_LSP_ENABLED` + +Allows explicitly enabling or disabling the LSP server. +Acceptable values are 'true' or 'false' + +Note for Windows users: Due to an outstanding issue with GHC's IO manager on Windows, the LSP is **disabled by default** on Windows machines. +Enabling the LSP on windows can cause UCM to hang on exit and may require the process to be killed by the operating system or via Ctrl-C. +Note that this doesn't pose any risk of codebase corruption or cause any known issues, it's simply an annoyance. + +If you accept this annoyance, you can enable the LSP server on Windows by exporting the `UNISON_LSP_ENABLED=true` environment variable. + +You can set this persistently in powershell using: + +``` powershell +[System.Environment]::SetEnvironmentVariable('UNISON_LSP_ENABLED','true') +``` + +See [this issue](https://github.com/unisonweb/unison/issues/3487) for more details. + +E.g. + +``` sh +$ UNISON_LSP_ENABLED=true ucm +``` + +### `UNISON_SHARE_HOST` + +Allows selecting the location for the default Share server. + +E.g. + +``` sh +$ UNISON_SHARE_HOST="http://localhost:5424" ucm +``` + +### `UNISON_SHARE_ACCESS_TOKEN` + +Allows overriding the credentials used when authenticating with the Share server. + +E.g. + +``` sh +$ UNISON_SHARE_ACCESS_TOKEN="my.token.string" ucm +``` + +### `UNISON_READONLY` + +Force unison to use readonly connections to codebases. + +``` sh +$ UNISON_READONLY="true" ucm +``` + +### `UNISON_ENTITY_VALIDATION` + +Allows disabling validation of entities pulled from a codebase server. +It's generally a good idea to leave this enabled unless you know exactly what you're doing. + +Defaults to enabled. + +``` sh +$ UNISON_ENTITY_VALIDATION="false" ucm +``` + +### `UNISON_PULL_WORKERS` + +Allows setting the number of workers to use when pulling from a codebase server. +Defaults to 5. + +``` sh +$ UNISON_PULL_WORKERS=6 ucm +``` + +### `UNISON_PUSH_WORKERS` + +Allows setting the number of workers to use when pushing to a codebase server. +Defaults to 1. + +``` sh +$ UNISON_PULL_WORKERS=2 ucm +``` + +### `UNISON_SYNC_CHUNK_SIZE` + +Allows setting the chunk size used in requests when syncing a codebase. +Defaults to 50. + +``` sh +$ UNISON_SYNC_CHUNK_SIZE=100 ucm +``` + +### Local Codebase Server + +The port, host and token to be used for the local codebase server can all be configured by providing environment +variables when starting `ucm`, using `UCM_PORT`, `UCM_HOST`, and `UCM_TOKEN`. + +E.g. + +``` sh +UCM_PORT=8080 UCM_HOST=localhost UCM_TOKEN=1234 ucm +``` + +## Codebase Configuration + +Also, see the guide [here](https://www.unison-lang.org/learn/tooling/configuration/) + +The following configuration options can be provided within the `.unisonConfig` file, +which exists within the codebase directory, or at `~/.unisonConfig` for your default codebase. + +``` +# Attach myself as author and use BSD license for all of my contributions +DefaultMetadata = [ ".metadata.authors.chrispenner" + , ".metadata.licenses.chrispenner" ] + +# RemoteMapping allows mapping a path in the codebase to a specific location on share. +# Here I state that I want my .share namespace to push to .chrispenner.public +# Everything inside .share will be mapped accordingly, e.g. .share.foo will map to +# chrispenner.public.foo on share. +RemoteMapping { + share = "chrispenner.public" +} +``` diff --git a/unison-src/transcripts/project-outputs/docs/data-types.output.md b/unison-src/transcripts/project-outputs/docs/data-types.output.md new file mode 100644 index 0000000000..7adf0b87c2 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/data-types.output.md @@ -0,0 +1,34 @@ +# Type declaration hashing and identity + +This doc describes how data types are uniquely identified in Unison. There's been a bunch of discussion on this topic (todo - I can't seem to find the link to past discussions, help\!) but for v1 we'll keep it simple. We may add other ways of generating data type identities if/when we decide we really need it. + +> 🚧 There's duplication between this doc and type-declarations.markdown ([github link](https://github.com/unisonweb/unison/blob/master/docs/type-declarations.markdown)). + +**Background:** In most languages, a data type is uniquely identified by some named type within some package. If either the package name is changed (due to a new numbered release of the package) or the module name or name of the type is changed, this results in a type that the language type system considers to be different. + +In Unison, a type declaration (introduced by either the `type` or `ability` keyword) creates a type which is uniquely identified in one of two ways: + + - A *structural* type declaration is identified by a hash of its structure, exactly as is done for hashing of a term. This is the current default if you just write: `type Blah = ...`. + - A *nominal* type declaration is identified by a GUID generated at the time the declaration. Syntax for this is TBD, but perhaps: `nominal type Blah = ...` + +Notes: + + - Structural types have unordered constructors, and their identity isn't affected by the names chosen, so `type O a = N | S a` is the same type as `type Maybe a = Just a | Nothing`. + - If the user writes a structural type where two constructors have the same structure, that's a type error and the user should be prompted to either make the structure different or choose a different. + - Nominal types have ordered constructors. The order of the constructors is frozen at the time of the creation of the type. The constructors and the type may be renamed, but the GUID associated with the type never changes. + +Nominal types are to be used for things like "days of the week". Structural types are to be used for things like `List` or `Maybe`. + +That's it for now. + +## Other ideas and notes + +Possibly for later: + + - *opaque/whatever* - a newtype with some privileged functions that can treat it as a type alias instead of newtype + - *algebraic* - defined by a set of laws (Monoid, Semilattice, etc) Question around how those laws are encoded + +Other notes: + + - Want a nice story for refactoring: e.g. if I have a conversion from T1 to T2, that can be applied automatically everywhere T1 is in positive position. T2 -\> T1 will cover where T1 is in negative position; isomorphism will cover both. + - Want a nice story for discovery of existing types to limit fragmentation. diff --git a/unison-src/transcripts/project-outputs/docs/distributed-api-discussion-v1.output.md b/unison-src/transcripts/project-outputs/docs/distributed-api-discussion-v1.output.md new file mode 100644 index 0000000000..c859ec1752 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/distributed-api-discussion-v1.output.md @@ -0,0 +1,285 @@ +# Distributed programming API v1 discussion + +``` haskell +type Either a b = Left a | Right b +type Status = Running | Finished | Canceled | Error Error +type Error = + Unknown | Unreachable | Unresponsive | AbilityCheckFailure + +ability Remote location where + fork : location {e} -> '{e} a ->{Remote location} Future a + join : Future a ->{Remote location} Either Error a + status : Future a ->{Remote location} Status + cancel : Future a ->{Remote location} Either Error () + +type Future a = Future + ('{Remote loc} (Either Err a) -- join + ,'{Remote loc} () -- cancel + ,'{Remote loc} Status, -- status + , Duration ->{Remote loc} ()) -- keepalive (seconds 10) +``` + +Feb 11 Q\&A: + + - Do we need `Remote.here`? Thinking is: we don’t, we can just get one when starting the Unison Remote server; can then use that value, or restricted derivatives, in applications. + +``` +Unison.server + -> (Location {e} ->{Remote Location} r) -- local computation + -> {e} r -- rrrrresult +``` + +`handle expression with handler` OR +`with handler handle expression` +\* How do you launch anything? +\* Watch expression lol +\* launch + + - What does it mean to `cancel`? + Proposal: Runtime needs to support this. `fork`-ing in Unison likely works by forking a new instance `t` of Haskell runtime; that Haskell thread `t` can be asynchronously interrupted. So, the implementation of `Future.cancel` just throws a Haskell async exception into `t`, terminating that instance of the runtime. + + - How do decide if a received computation is allowed to be run? (and we are capable of running it?) + + 1. Some Unison term comes over the wire. + 2. \-Decide the type (typecheck? maybe slow? some other proof?)- No, we can use runtime exception. + 3. Scan the term for unknown hashes. (Could we do this lazily? Arya says: that’s crazay \[sic\]\! Rúnar adds: Sounds super fragile.) + - Could speculatively send some dependencies with the initial request, especially if protocol has minimum message size, but maybe not easy to anticipate which dependencies will be needed at remote end. + - If doing this lazily, could spare sending definitions for code paths not used during this particular execution. + - Could get started running the computation if there’s any work that can be done before receiving missing dependencies. Background thread works to populate the term cache from remote sources. + 4. If missing some of the dependencies, send list of references back to originator for definitions. Repeat steps 3–4 until the whole application is loaded / cached / whatever. + 5. Just run it and then complain if encountering an unexpected ability request. + + - How do actually run one? + +----- + +Do we need to choose a representation of `Location` now? + + - No, we can use incrementally more sophisticated representations. e.g., loc can initially be `()` or `Nat`, and the handler can maintain pure maps or whatever. (note: need pure maps). + - Yes, because the entire `Remote` ability needs to be defined up front, but some APIs e.g. relating to “keepalives” only make sense in the context of true multi-node Locations. + +Do we need to choose a representation of `Future` now? + + - Yes, because the entire `Remote` ability needs to be defined up front, but we may need additional remote abilities to operate on `Future`s. + - It can just be `'{Remote loc} a` + - No, this representation doesn’t contain enough info to asynchronously identify the computation, e.g. to support `Remote.status` in a multi-node implementation. + - It can be some kind of handle or GUID. + - Can we index typed results by untyped handle? + +Do we need the ability to automatically clean up zombie tasks? This informs the discussion around keepalives. + + - Yes: + +## Locations + +A Location is simply a computing context with access to certain computational resources. The `Remote` ability is parameterized with a Location type `loc`, giving us significant flexibility in defining various `Remote` interpreters. The interpreter can then require a `loc` that describes resources in whatever way it likes, and the interpreter can be paired with an appropriate implementation for obtaining or generating `loc`s. + +For example: + +``` haskell +runLocal : '{Remote () ()} a -> a +runLocal r = + step nid r = case r of + {a} -> a + {Remote.fork t -> k} -> handle (step nid) in k t + {Remote.spawn -> k} -> handle (step (Node.increment nid)) in k nid + {Remote.at _ t -> k} -> handle (step nid) in k !t + handle (step (Node.Node 0)) in !r +``` + +Its runtime representation is essentially a collection of cryptographic tokens authorizing the use of these resources. + +In Unison code, a Location is represented by a `Loc {e}`. A Unison value of type `Loc {}` supports only pure computations, whereas a `Loc {Remote, GPU}` provides the `Remote` and `GPU` abilities. + +### Locations have a composite runtime representation + +A `Loc` is represented by one or more host / port / auth tokens, along with ability use tokens. The `Remote` handler may use any algorithm in selecting a host to submit a task to, and the receiving host will run the computation provided the accompanying tokens are valid. + +``` haskell +-- Haskell runtime representation +-- individual Tokens should be cryptographically unguessable. +-- Tokens may correspond to or contain quota/other data. +data Loc = Loc Hosts Abilities +type Token = TBD +type Hosts = Map (Hostname,Port) Token +type Abilities = Map Reference Token -- Map Reference (PublicKey, RandomDigits, signature(publicKey, randomDigits <> reference)) +``` + +### What's in a Token? + +In this formulation, Token is a possibly-parameterized catch-all that includes whatever information is necessary to securely authorize some use. + +Stateless tokens will include: + + - A description of the authorized resource/activity, sufficient to be understood by the resource servers. + - A signature by entity trusted by the resource server. + - If the token is composite, each separable piece must be individually signed. Signatures are typically the size of the key (4096 bits = 512 bytes), so they can start to add up. + +They will optionally include: + + - An expiration / validity period - or be valid in perpetuity + - An "audience", identity of the target resource server, in cases where the signature key is too broad to identify the resource server. + +Example: + +``` +Token = + abilities e_1, ..., e_n <> expiration + <> signature ku ([e_1 ... e_n] <> expiration) + <> fingerprint ku + +or: + (e_1 <> expiration <> signature ku (e_1 <> expiration) <> fingerprint ku) +<> ... +<>(e_n <> expiration <> signature ku (e_n <> expiration) <> fingerprint ku) +``` + +This is leading up to an exponential number of signatures, just to support `Loc.restrict`. So, let's look at some schemes for delegation. + +### Elastically producing new Locations + +An elastic compute service “front-end” would expose: +1\. a function to `provision` new locations +2\. a Location at which the function could be run + + - Can I have this `provision` function in my namespace, without having its implementation in my codebase? + + + + - \[ \] The implementation of `provision` would need some way to authenticate and validate the request. + - \[ \] It would need some way to construct a Unison `Loc` value (not yet discussed). + - \[ \] It should provide a way for the front-end to monitor utilization and spin up or shut down physical resources as needed. + +*Idea*: Maybe the `Token` value provided by the front-end is structured in a provider-specific way, with whatever data is needed to make these decisions. Having a distinct `Token` type for distinct providers means another type parameter on the `Loc`, which could answer the question about consolidating `Loc`s on the user side. If two Locations share the same provider type, they can be consolidated (hosts, quotas, abilities); otherwise they obviously couldn’t be. + +``` haskell +Remote.forkAt : Loc {e} p -> '({e} a) ->{Remote} Future a +Location.join : Loc {e} p -> Loc {e2} p -> Loc {e,e2} p +``` + +## Futures + +A `Future` represents an asynchronous computation. `Remote.forkAt` takes a computation and returns immediately with a `Future`. To wait for the computation’s output, use `Future.force`. + +``` haskell +Remote.forkAt : Loc {e} ->'({e} a) ->{Remote} Future a +Future.force : Future a ->{Remote} (Either Err a) +type Err = TBD + +-- example: +f1 = forkAt a 'let + x = longRunningComputation 101 + makeHistogram x +y = otherLongComputation +x = Future.force f1 +Database.save (x, y) +``` + + - How many times can a future be successfully forced? Suppose a future is shared with 5,000 machines. The task backing the future eventually completes, and now what? + - The thought: the machines sending keepalives (subscribers?) are retained at the Location performing the computation; when the computation is complete, the Location should send the result back to those subscribers. The subscribers save the result in their caches until they no longer reference the `Future`. + - Random thing - if 5,000 nodes have a reference to a future, the status update / keepalive protocol should come with a response like "send me another keeplive within X time", where X is influenced by the number of other subscribers / density of keepalives. This prevents flooding the network with keepalives. + +### Supervision and garbage-collection of Futures + +Unison Futures can be monitored or terminated using: + +``` haskell +Future.status : Future a ->{Remote} Future.Status +type Future.Status + = Running LastUpdate | Canceled | Finished + | Unreachable | Unresponsive + +Future.cancel : Future a ->{Remote} (Either Err2 ()) +type Err2 = TBD +``` + +To the extent that an async computation should be canceled if there is no other computation interested in its result, we need some way of determining whether or not this is the case. We discussed having a system of keep-alives, absent which a Future might be canceled by its host: + +``` haskell +-- these likely will just be handled by the interpreter +-- of Remote, not by "user" code. +Future.keepalive : Duration -> Future a ->{Remote} Status +Future.remaining : Future a ->{Remote} Duration +``` + +Moreover, there will be cases where we want to transfer or delegate the keep-alive responsibility for a long-running tasks to a more available location. + +``` haskell +Remote.supervise : Loc {e} -> Future a -> {Remote} () +Remote.unsupervise : Loc {e} -> Future a -> {Remote} () +``` + +> We discussed producing a `Heartbeat` identifier along with any `Future`, but decided there was no benefit to separating the two. + +We haven’t discussed how to prevent a delegate supervisor from accumulating and perpetuating many long-running Futures that will never actually be forced. With this in mind, have we gained anything from a GC perspective? + +## Stationary data + +We will need some notion of data that doesn't just move automatically with the computation, even if the computation references it. We identified two reasons you might want to do this: + + - The data is big, and you don't want to copy it around willy-nilly. + - The data is secret, and you don't want to accidentally ship it to another location, you want to be very explicit about when this happens (for instance, secret keys, etc). + +More generally, we want a way of being explicit about when certain data is moved between locations, rather than implicitly relocating anything in lexical scope (this could be an API thing, a type-system thing, a code-analysis tool). + +----- + +## Notes/Desiderata + + - \[ \] Elastic computation - need to be able to talk about spawning new computing resources, and ideally this compute can be garbage collected as soon as you're done using it. + - \[x\] `fork` a task to run on a separate thread or at another "location" + - \[x\] Different locations may have access to different abilities (just pure computation, `IO`, `GPU`, etc) + - \[x\] Need to be able to respond to location failures, with maximal flexibility. Allow different ways of doing failure detection/recovery. + + + + - Locations are first-class, permissions, tasks, are first-class + - \[x\] locations + - \[ \] permissions? + - \[x\] tasks (futures) + + + + - \[ \] Some notion of data that doesn't just move automatically with the computation, even if the computation references it. + + - e.g., The data is big, and you don't want to copy it around willy nilly. + - e.g., The data is secret, and you don't want to accidentally ship it to another location, you want to be very explicit about when this happens (for instance, secret keys, etc). + - Might more generally want a way of being explicit about when data is moved to a location rather than just implicitly relocating anything in lexical scope (could be an API thing, a type system thing, a tool). + + - \[x\] Need to be able to launch a long-running computation and have it outlive the task / location / node that launches it. But then how do you interact with this computation later? (Say, to cancel it? Or to check if it's finished? Or more generally, how do you monitor it?) + + - \[ \] Need to be able to hash and serialize any Unison value, so that storage API(s) can be implemented in pure Unison. + + - Should the hash of a value know the type of the value? (`hash : a -> Hash a`) + + - \[x\] How do you represent `Loc{e}` to be securely verified by the receiving node? The `Loc{e}` must be unguessable and tamper-proof. + + - This is achieved by making the component `Token`s unguessable and tamper-proof. + + - \[ \] Must be safe to say `at loc1 loc2` without allowing nefarious loc1 to abuse loc2. (Needs clarification.) + + - \[x\] The runtime needs an unguessable way (crypto?) to represent Locations and their abilities. + + - \[ \] Not all computations should have access to all data. + + - file system + - individual durables + + - \[x\] Not all Locations should provide unlimited resources to all users (arbitrary computation, time, storage, bandwidth, priority). + + - \[ \] Not all data should be portable to arbitrary locations (think secret keys, top secret clearance, hipaa). + +*Misc?*: + + - Mutable typed (durable if needed) state at each location + - For v1, could not have this, just focus on batch computation + - Dealing with weird networks? (nat-busting) + - Maybe in implementation, but not explicit in v1 API + - Well-defined semantics not just a bunch of implementation-defined gobbledygook + - Do we need globally-addressed mutable state? e.g. node `a` can refer to mutable data on node `b`; or node `c` can mutate data on node `d`. Yes, probably. + +## Choices + + - We decided that automatically cancelling a child computation when its parent terminates or delaying termination of of the parent until its children complete would break associativity in terms of parallelism when chaining computations, therefore `forkAt` doesn’t enforce any such conditions. See more about cancellation & termination below, in “Supervision and garbage-collection of Futures” + +\#unison diff --git a/unison-src/transcripts/project-outputs/docs/distributed-garbage-collection.output.md b/unison-src/transcripts/project-outputs/docs/distributed-garbage-collection.output.md new file mode 100644 index 0000000000..facbfb93cd --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/distributed-garbage-collection.output.md @@ -0,0 +1,94 @@ +## Distributed Garbage Collection + +We use a weak `B` map, to track local boxes (entries are removed by virtue of being a weak map once they are no longer referenced in local heap / boxes): + +``` haskell +B_map :: WeakMap BoxId (MVar Value) +``` + +and a weak `C` set, tracking all remote boxes referenced by local heap / boxes: + +``` haskell +type RemoteBox = (BoxId, Node) +C_set :: WeakMap RemoteBox +``` + +Each local box `b` has an associated value, and associated set of boxes referenced by its contents, `b_subs`. + +``` haskell +let keepaliveDuration = 20.seconds -- or whatever +type Keepalive = Keepalive { b :: BoxId, visited :: Set RemoteBox } +``` + +**Receiving Keepalives** +When node `n` receives a keepalive message for BoxId `b` + +1. If `n` doesn't own `b`, disregard (shouldn't occur) +2. Else if `(b,n)` ∈ `visited`, disregard (normal occurrence) +3. Else + 1. Create a strong reference to `b` for a fixed period of time (`keepaliveDuration`) + 2. Let `b_subs` be the set of all boxes (local and remote) referenced by `b`. + 1. If `b_subs` is not cached, and no existing process is indexing `b`, starting indexing `b` and cache the result when complete. + 2. If indexing does not complete in time, do not interrupt indexing, but use `C_set` as an approximation of `b_subs` for the purposes of processing this particular keepalive message. + 3. For each `b_i` ∈ `b_subs`, + 1. If `b_i` is a remote box, send `(Keepalive b_i (Set.insert (b,n) visited))` to the owner of `b_i`. + 2. If `b_i` is a local box, process `(Keepalive b_i (Set.insert (b,n) visited))` locally. Whether or not you hit the network is up to you, but in this scheme, we do need to recursively propagate keepalives through local boxes. + +To compute `b_subs` (set of boxes referenced by the value inside the `b` box): + +1. Keep mutable cache `Optional [BoxId]` for each runtime value, `v`, tracking boxes referenced transitively by `v`. +2. Do a deep scan of the `v` inside the box to fully populate caches, recursively. +3. Avoid revisiting subtrees that already have a computed cache. + +**Receiving Continuations or Box Updates** +When a continuation `c` is transferred from node `x` to node `y`, or when value `c` is `Box.put` from node `x` to node `y`, node `y` adds non-local boxes referenced by `c` to `C_set`. (This indexing may be done as part of the network deserialization.) + +We must ensure that boxes referenced by `c` are not GCed before `y` can issue keepalives; this means that node `x` must send keep-alives to any boxes referenced by `c` during the transfer (this should already happen without special care) and at least once more after the transfer has completed, to avoid a race condition while `y` takes over the keepalives. This may mean that both nodes `x` and `y` must also index `c` while it is being transferred. + +**FAQ** +Q: Will `C_set` contain all of the remote boxes referenced by local boxes? +A: Yes: to store a value into `b`, the value must be constructed within some continuation. Remote box references can only exist in a continuation transferred from a remote node, or a value `Box.put` from a remote node. In both of these cases, any remote boxes referenced in the transfer are indexed into `C`, per "Receiving Continuations or Box Updates" above. + +Q: Can we say that durable values don't keep boxes alive? That a durable shouldn't expect any particular value to be preserved in a referenced box? +A: ... + +Q: If a remote node has computed the `Optional [BoxId]` for a runtime value, should the remote node transfer that cache to me? +A: ... + +**Optimizations** + + - Avoid allocating boxes to B-map and C-set until first transfer. Until first transfer, boxes are just a regular `MVar` on the stack. + +\*\* Example reference graph\*\* + +``` haskell +type Foo = Ref (Box Foo) | No_Ref + +do Remote + Remote.transfer x + q := Box.make + r := Box.make + Remote.transfer y + s := Box.make + t := Box.make + Remote.fork <| do Remote + sleep-random-duration + Box.take t + Box.put q (Ref s) + Box.put s (Ref r) + Box.put r (Ref t) + Box.put t (Ref q) + Box.put t No_Ref -- maintains cycle until Box.take t, then breaks cycle +``` + +``` text + x y + ┌─┐ ┌─┐ + ┌>│q│──>│s│ + │ ├─┤ /├─┤ + │ │ │ / │ │ + │ ├─┤└ ├─┤ + │ │r│──>│t│ + │ └─┘ └─┘ + └────────┘ +``` diff --git a/unison-src/transcripts/project-outputs/docs/distributed-programming-rfc.output.md b/unison-src/transcripts/project-outputs/docs/distributed-programming-rfc.output.md new file mode 100644 index 0000000000..4ffa4b2108 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/distributed-programming-rfc.output.md @@ -0,0 +1,223 @@ +This document describes a set of core Unison functions for expressing fault-tolerant multi-node systems, including systems that must be dynamically updated and redeployed without downtime. + +Remarks: + + - There's a mixture of old and new stuff here, see the [history section](#history) for background. + - Some version of these APIs will be implemented on the new Unison runtime. We are looking to gather design feedback and possibly iterate the design before starting on the implementation. + - Some of these primitives are rather low-level and imperative; it's expected that people will use them to build nicer APIs in pure Unison. + - Questions are good if you have them; ask away in the comments and we'll curate that into a Q\&A section of the document. + +Lastly, thank you to all who have contributed to this design or worked on earlier iterations\! + +### The API + +Unison computations can hop between nodes, can fail, can be forked to execute asynchronously, and can be supervised: + +``` Haskell +-- Promote a pure value to `Remote` +Remote.pure : ∀ a . a -> Remote a + +-- Sequencing of remote computations +Remote.bind : ∀ a b . (a -> Remote b) -> Remote a -> Remote b + +-- The current node where the computation is executing +Remote.here : Remote Node + +-- Transfer control of remainder of computation to target node +Remote.transfer : Node -> Remote Unit + +-- Explicitly fail a computation for the provided reason +Remote.fail : ∀ a . Text -> Remote a + +-- Sleep the current computation for the given duration +Remote.sleep : Duration -> Remote Unit + +-- Start running a remote computation asynchronously, returning +-- a `Task` value that can be used for supervision +Remote.fork : ∀ a . Remote a -> Remote Task + +-- Halt a running task (and any running subtasks) using the provided `Cause` +Task.stop : Cause -> Task -> Remote Unit + +-- Obtain the `Cause` that caused a running task to complete +Task.supervise : Task -> Remote (Remote Cause) + +-- Create a duration from a number of seconds +Duration.seconds : Number -> Duration + +-- this is TBD +type Cause = Error Text Node | Completed | Cancelled | Unresponsive Node +``` + +Unison computations can provision new nodes: + +``` Haskell +-- Like `Remote.spawn`, but create the node inside a fresh sandbox +Remote.spawn-sandboxed : Sandbox -> Remote Node + +-- Like `Remote.spawn-sandboxed`, but use the provided symmetric key +-- to communicate with the returned `Node` +Remote.spawn-sandboxed' : Key -> Sandbox -> Remote Node + +-- Create a new node 'in the same location' as the current node, sharing +-- current sandbox resources +Remote.spawn : Remote Node + +-- Like `Remote.spawn`, but use the provided symmetric key +-- to communicate with the returned `Node`. +Remote.spawn' : Key -> Remote Node + +-- Statically provision a `personal-info : Node` +node personal-info -- layout block starts here + Sandbox 5% 10MB 3GB accept-from + +-- TBD +type Sandbox = + Sandbox CPU% Memory Storage (∀ a . Node -> Remote a -> Remote a) +``` + +We can encrypt / decrypt any value at all: + +``` Haskell +-- Encrypt a value, requires `Remote` since we use random IV / nonce +encrypt : ∀ a . Key -> a -> Remote (Encrypted a) + +-- Decrypt a value, or return `None` if key is incorrect +decrypt : ∀ a . Key -> Encrypted a -> Either DecryptionFailure a + +-- `Key` is just a symmetric encryption key. We might generate keys via: + +AES256.key : Remote Key +Blowfish.key : Remote Key +-- etc + +-- TBD +type DecryptionFailure = WrongKey | AlgorithmMismatch | IntegrityFailure +``` + +Unison programs have access to mutable variables, which also serve as a concurrency primitive: + +``` Haskell +-- Create an ephemeral `Box` on the current node; just a (GUID, Node) at runtime +Box.empty : ∀ a . Remote (Box a) + +-- Put a value into the box, or if the box is full, +-- wait until a `Box.take` empties the box. +Box.put : ∀ a . a -> Box a -> Remote Unit + +-- Remove and return the value in the box, or if the box is empty, +-- wait until a `Box.put` fills the box. +Box.take : ∀ a . Box a -> Remote a + +-- Like `Box.take`, but leaves the value inside the box +Box.read : ∀ a . Box a -> Remote a + +-- Read the current value inside the box or return `None` immediately. +-- Also returns a setter which returns `True` if the set was successful. +-- The `set` is successful only if the value inside the box has not +-- otherwise changed since the read, so this can be used to implement +-- "optimistic" atomic modifies. +Box.access : ∀ a . Box a -> Remote (Optional a, a -> Remote Bool) +``` + +Unison can resolve references dynamically on a node: + +``` Haskell +-- Create a `Name`, which is a typed reference to a node-local value. +Name.make : ∀ a . Remote (Name a) + +-- Lookup the node-local value associated with the `Name`. +Name.resolve : ∀ a . Name a -> Remote (Box a) + +-- Declare `bob : Name Number` statically. The value bound to +-- the `Name` does not survive node restarting. +ephemeral name bob : Number + +-- Declare `cluster-peers : Name (Vector Node)` statically. The current +-- value of `cluster-peers` survives node restarting. +durable name cluster-peers : Vector Node +``` + +Unison can make any value durable. `Durable` values are immutable: + +``` Haskell +-- Move any value from RAM to local durable storage +Durable.store : ∀ a . a -> Remote (Durable a) + +-- Synchronize any value AND ALL TRANSITIVE DEPENDENCIES +-- to local durable storage, returning `True` if the given `Node` +-- has that `Durable a` locally and the sync was successful. +Durable.sync-from : ∀ a . Node -> Durable a -> Remote Boolean + +-- Load a durable value into RAM, assuming it exists on the given node +Durable.load-from : ∀ a . Node -> Durable a -> Remote (Optional a) + +-- Returns a list of nodes that the Unison runtime believes could +-- successfully `Durable.load-from` or `Durable.sync-from` for the +-- given `Durable`. +Durable.peers : ∀ a . Durable a -> Remote (Vector Node) +``` + +Lastly, we can declare foreign functions: + +``` Haskell +-- Declare `my-fn : Foreign (Number -> Remote Number)` statically +-- Bindings for some of these foreign declarations would be done +-- in some implementation-dependent way on Unison node container startup. +foreign my-fn : Number -> Remote Number + +-- Ask the current node if it has a binding for a `Foreign a` +Foreign.ask : forall a . Foreign a -> Remote (Optional a) +``` + +## Notes on semantics and implementation details + +A basic design principle: the Unison runtime should never contact another Unison node unless the user's program explicitly indicates that node should be contacted. Thus, the runtime cannot run any sort of background task that contacts other nodes (like upkeep for a DHT), nor can it implicitly choose which nodes to contact (like doing some sort of autodiscovery to find "good" peers). The idea here is to make the runtime "as dumb as possible", and move all intelligence to regular Unison libraries. + +The `Task` returned by `Remote.fork` controls the entirety of the computation forked, including any subtasks forked. Stopping that `Task` stops anything that may be running underneath this fork. + +Implementation notes on `Task.supervise`: + + - At runtime, a `Task` value contains a `Node` reference where the `Task` was originally forked. + - To implement `Task.supervise`, the runtime maintains at each node a `Map Task (Timestamp, Status, Optional Node)`, tracking for each task a timestamped last update for that task (when it was running on the current node), and an `Optional Node` if the computation was transferred elsewhere. This `Map` can be pruned using some ad hoc policy (like retain 30s of data or 5000 entries). `Task.supervise` then just chases the computation, following these transfer links until it obtains a "recent enough" status update for the computation. If a node is unresponsive or unreachable, this eventually leads to an `Unresponsive` error being passed to the supervisor. + +On node local storage: + + - The association between a `Name` and a `Box` is *local to the node*. Conceptually, each node has its own durable and ephemeral storage. There is no storage concept exposed by Unison at any granularity beyond nodes (though of course you can write multi-node storage as regular Unison libraries). Nodes are isolated from each other and must communicate explicitly (even if the nodes are all spawned in a single sandbox). + - The `durable name blah : Name Number` is somewhat analogous to a typed file name. It can be resolved on any node to a `Box Number`, and the state of that `Box Number` (whether it is empty or full) will survive node restarts. + - The `node node-name` block declares a node statically, by proving a `Sandbox`. + - The various `Durable` functions give some flexibility to Unison programs in how they resolve `Durable` values and where they load them from. + +On storage and discovery of `Durable` values: + + - It's expected that `Durable.load : Durable a -> Remote a` could be implemented in terms of `Remote.load-from` and `Durable.peers` (with a small chance of failure if all nodes delete durable data stored elsewhere). + - A sketch of how `Durable.peers` map gets updated: + - Any call to `Durable.load-from n1 d` for a `d` not already present on the current node gets an entry in the peers map. + - When receiving a continuation via `Remote.transfer`, entries are added to the peers map for any durables not present on the receiving node. So if the continuation references `d : Durable Number`, and the sender's peer map for `d` was `[alice, bob, carol]`, then `[alice, bob, carol]` would be added to the recipient's peer map for `d`. If the sender's peer map is empty (because the sender has the `Durable` locally), we'd just add the sender to the peer map. + - Successful calls to `Durable.sync-from` clear out peers map entries for that `Durable` and its transitive dependencies, since once it's stored locally, we stop caring where else we could get it from. + - May want to prune the number of peers stored for a given `Durable`, if lots of peers have it. + +### Appendix: History and context + +**Most recently (after discussion in [\#142](https://github.com/unisonweb/unison/issues/142)):** + + - Split `Capability` into `Foreign` (for the foreign function interface) and `Name`, for locally bound names. + - Loading of `Durable` values is more explicit about *where* the values are being loaded from, but runtime provides enough info to implement good heuristics for discovering `Durable` values from peers more implicitly. + - There's now a way to statically declare a `Node`, which is important for bootstrapping a system. + +**V2 (after discussion in [\#141](https://github.com/unisonweb/unison/issues/141)):** + + - Got rid of `Clock` and `Index` in favor of immutable durable storage concept + mutable pointers. + - Got rid of `Channel` in favor of `Box`, also simplified `Capability` API to just build on `Box` directly. + - Got rid of `Heartbeat` arguments to a whole bunch of functions (like `Box.take`, etc), opting for just using the ambient lexically-scoped heartbeat established via `Remote.link`. 99% of the time this is what you want, and you can always push another `Heartbeat` onto the stack via a nested `Remote.link`. + - Clarified behavior around lifetimes of `Remote.fork`-ed computations and `Remote.spawn*` nodes--they always inherit the current ambient heartbeat. I believe this is key for composability, since it makes the interface for shutting down a subcomputation completely uniform. + +**Previously:** + +[This post](http://unisonweb.org/2015-06-02/distributed-evaluation.html) has an early writeup of how Unison's hashing scheme could be used to build a robust multi-node computation story. That eventually got an implementation, and as a demo I put together [a simple multi-node search engine](http://unisonweb.org/2016-10-12/search.html#post-start) in Unison. That raised a couple issues and questions, some discussed in that post, some discussed [in this post about microservices](http://unisonweb.org/2016-10-12/microservices.html#post-start), and some that I have just been ruminating on. 🤔 + +The big questions were around: + + - Lifecycle management of nodes and durable data---when is durable data destroyed, and when are nodes destroyed? This led to the `Heartbeat` design (which was later scrapped). + - Encryption: how are things encrypted, both at rest (in durable storage) and in transit (when moving between nodes). The solution given here is to have 'in transit' encryption handled transparently by the runtime, but to have encryption keys for durable state to be managed explicitly by the programmer. This allows for multiple nodes to use a common storage layer, without all reads needing to go through a common node. + - Dynamic updates and redeployment---how is this done? Solution given is the `Capability` stuff. diff --git a/unison-src/transcripts/project-outputs/docs/github-actions-help.output.md b/unison-src/transcripts/project-outputs/docs/github-actions-help.output.md new file mode 100644 index 0000000000..63eb0c717d --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/github-actions-help.output.md @@ -0,0 +1,92 @@ +## Some things I wish I'd known about Github Actions + +You can't have an `env:` key defined in terms of another `env` key, but you can use `$GITHUB_ENV` to get around this. + +You can't define a `matrix` at the top level, it has to be defined within a `job`'s `strategy`. + +`runs-on:` doesn't allow `env` for some reason. + +Strings don't need quotes, unless you need to force something to be a string. + +A `@ref` is always needed on a remote action. + +Windows doesn't seem to honor the `default: run: shell:` setting, so you need to set the `shell:` on `run:` manually? + +Don't hesitate to do a lot with `run:` blocks aka bash scripts — at least bash is mature and well documented. + +e.g. +echo "bar=whatever" \>\> $GITHUB\_OUTPUT +\# access with `steps..outputs.bar` in yaml strings + +``` +echo "foo=whatever" >> $GITHUB_ENV +# access with `env.foo` in yaml strings, or `$foo` in bash +``` + +`$GITHUB_ENV` updates the `env` context between steps, but not in the middle of a step. Obvious in retrospect. + +It's not clear to me when to use `$GITHUB_OUTPUT` vs `$GITHUB_ENV`, but I have been favoring `$GITHUB_ENV` because it requires fewer characters to access. +However, it seems a little wrong. + +### `hashFiles()` + +`hashFiles()` can only access files inside of and relative to `$GITHUB_WORKSPACE`. + +### `if:` + +Although the type rules don't totally make sense in Github Actions, `if:` takes a Boolean. + +Therefore, I think the String interpolation in `if: ${{runner.os}} != 'Windows'` causes the whole expression to become a String, which is coerced to `true`, when you definitely didn't mean `if: true`. So don't use `${{}}` here. + +### Job names + +Job names will automatically get `(${{matrix.os}})` if you don't use `${{matrix.os}}` somewhere in the name. + +### Windows + +The whole thing with `.exe` is a mess. Unix commands typically drop and add `.exe` correctly as needed, but Github Actions (e.g. `actions/upload-artifact`?) don't. + +### Cache + +When using the `cache` action, getting a cache hit on the primary key means you won't update the cache with any changes. + +When picking a key, you have to ask, "Which key, if exactly matched, would mean that I'm already so done that I don't even want to save anything new from this run." + +Similarly, `save-always: true` only if a key hit means there will be nothing new to save, even if a previous run failed AND a failed result is worth starting with. + +Backup restore keys: "Is there a prior run that would be worth starting out from? With the caveat that any irrelevant garbage it includes will be saved into this run too." + +### Upload Artifact + +I suspect on Windows it can't support paths that select a drive in a Unix-y way, +like `/c/asdf` or `/d/asdf`. It's got to be `C:/asdf` or `C:\asdf` etc. + +Upload will complain if any + +Upload and Download plugin versions have to match. + +### Reusability + +Github supports splitting off "reusable workflows" (`jobs` that can be imported into another workflow), and "composite actions" (multi-step `steps` that can be imported into another `job`). + +#### Composite actions + +Needs to have `shell:` specified on every `run:` + +#### Reusable workflows + +These have to be in `.github/workflows`, you can't organize them deeper, or elsewhere. + +### Reference + +Default Environment Variables: +https://docs.github.com/en/actions/learn-github-actions/variables\#default-environment-variables + +Workflow syntax: +https://docs.github.com/en/actions/using-workflows/workflow-syntax-for-github-actions + +Reusable workflows: +https://docs.github.com/en/actions/using-workflows/reusing-workflows + +Composite actions: +https://docs.github.com/en/actions/creating-actions/creating-a-composite-action diff --git a/unison-src/transcripts/project-outputs/docs/language-server.output.md b/unison-src/transcripts/project-outputs/docs/language-server.output.md new file mode 100644 index 0000000000..2e766d2256 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/language-server.output.md @@ -0,0 +1,223 @@ +# Unison Language Server + +[![asciicast](https://asciinema.org/a/Kwa7NscffA3R8KCHxq1OavRm0.svg)](https://asciinema.org/a/Kwa7NscffA3R8KCHxq1OavRm0) + + - [Overview](#overview) + - [Installation and setup](#installation-and-setup) + - [NeoVim](#neovim) + - [VSCode](#vscode) + - [Helix Editor](#helix-editor) + - [Emacs](#emacs) + - [other editors](#other-editors) + - [Configuration](#configuration) + +## Overview + +Supported features: + + - Autocompletion + - Inline type and parser error messages + - Format on save (you can disable this in your editor if you like) + - Show type on hover + +Notes: + + - The LSP listens for changes from the UCM it's linked to, so name resolution is dependent on your current UCM path. + +## Installation and setup + +Currently the only supported configuration is to connect to the LSP via a specified port, not all LSP implementations support this configuration. + +By default the LSP is hosted at `127.0.0.1:5757`, but you can change the port using `UNISON_LSP_PORT=1234`. + +Note for Windows users: Due to an outstanding issue with GHC's IO manager on Windows, the LSP is **disabled by default** on Windows machines. +Enabling the LSP on windows can cause UCM to hang on exit and may require the process to be killed by the operating system or via Ctrl-C. +Note that this doesn't pose any risk of codebase corruption or cause any known issues, it's simply an annoyance. + +If you accept this annoyance, you can enable the LSP server on Windows by exporting the `UNISON_LSP_ENABLED=true` environment variable. + +You can set this persistently in powershell using: + +``` powershell +[System.Environment]::SetEnvironmentVariable('UNISON_LSP_ENABLED','true') +``` + +See [this issue](https://github.com/unisonweb/unison/issues/3487) for more details. + +### NeoVim + +Before configuring the LSP, install the Vim plugin for filetype detection and syntax highlighting. +For [Packer](https://github.com/wbthomason/packer.nvim) you can install the package as follow: + +``` lua +-- You may need to increase the git clone timeout setting in Packer! +use { + "unisonweb/unison", + branch = "trunk", + rtp = "/editor-support/vim" +} +``` + +or [Plug](https://github.com/junegunn/vim-plug): + +``` vim +Plug 'unisonweb/unison', { 'branch': 'trunk', 'rtp': 'editor-support/vim' } +``` + +or [Lazy](https://github.com/folke/lazy.nvim/): + +``` lua +{ + "unisonweb/unison", + branch = "trunk", + config = function(plugin) + vim.opt.rtp:append(plugin.dir .. "/editor-support/vim") + require("lazy.core.loader").packadd(plugin.dir .. "/editor-support/vim") + end, + init = function(plugin) + require("lazy.core.loader").ftdetect(plugin.dir .. "/editor-support/vim") + end, +} +``` + +Configuration for [coc-nvim](https://github.com/neoclide/coc.nvim), enter the following in the relevant place of your CocConfig + +``` + "languageserver": { + "unison": { + "filetypes": ["unison"], + "host": "127.0.0.1", + "port": 5757, + "settings": {} + } + } +``` + +For [lspconfig](https://github.com/neovim/nvim-lspconfig) with optional autocomplete [nvim-cmp](https://github.com/hrsh7th/nvim-cmp) for LSP +[cmp-nvim-lsp](https://github.com/hrsh7th/cmp-nvim-lsp), you can use the following setup function(s): + +``` lua +-- This function is for configuring a buffer when an LSP is attached +local on_attach = function(client, bufnr) + -- Always show the signcolumn, otherwise it would shift the text each time + -- diagnostics appear/become resolved + vim.o.signcolumn = 'yes' + + -- Update the cursor hover location every 1/4 of a second + vim.o.updatetime = 250 + + -- Disable appending of the error text at the offending line + vim.diagnostic.config({virtual_text=false}) + + -- Enable a floating window containing the error text when hovering over an error + vim.api.nvim_create_autocmd("CursorHold", { + buffer = bufnr, + callback = function() + local opts = { + focusable = false, + close_events = { "BufLeave", "CursorMoved", "InsertEnter", "FocusLost" }, + border = 'rounded', + source = 'always', + prefix = ' ', + scope = 'cursor', + } + vim.diagnostic.open_float(nil, opts) + end + }) + + -- This setting is to display hover information about the symbol under the cursor + vim.keymap.set('n', 'K', vim.lsp.buf.hover) + +end + +-- Setup the Unison LSP +require('lspconfig')['unison'].setup{ + on_attach = on_attach, +} +``` + +``` lua +-- This is NVim Autocompletion support +local cmp = require 'cmp' + +-- This function sets up autocompletion +cmp.setup { + + -- This mapping affects the autocompletion choices menu + mapping = cmp.mapping.preset.insert(), + + -- This table names the sources for autocompletion + sources = { + { name = 'nvim_lsp' }, + }, +} + +``` + +Note that you'll need to start UCM *before* you try connecting to it in your editor or your editor might give up. + +### VSCode + +Simply install the [Unison Language VSCode extension](https://marketplace.visualstudio.com/items?itemName=unison-lang.unison). + +### Helix Editor + +To `~/.config/helix/languages.toml` append this code: + +``` toml +[language-server.ucm] +command = "nc" # or 'ncat' or 'netcat' +args = ["localhost", "5757"] + +[[language]] +name = "unison" +scope = "source.unison" +injection-regex = "unison" +file-types = ["u"] +shebangs = [] +roots = [] +auto-format = false +comment-token = "--" +indent = { tab-width = 4, unit = " " } +language-servers = [ "ucm" ] + +``` + +or follow the instructions for Unison in "[How to install the default language servers](https://github.com/helix-editor/helix/wiki/How-to-install-the-default-language-servers#unison)" wiki page. + +### Emacs + +In Emacs 29 (or earlier, if you install the [Eglot](https://elpa.gnu.org/packages/eglot.html) package), add the following to your init file: + +``` elisp +(push '((unison-ts-mode unisonlang-mode) "127.0.0.1" 5757) + eglot-server-programs) +``` + +This requires having either [unison-ts-mode](https://github.com/fmguerreiro/unison-ts-mode) or [unisonlang-mode](https://melpa.org/#/unisonlang-mode) installed. unison-ts-mode is newer, supported, and more complete, but isn’t in [MELPA](https://melpa.org/) yet and requires a couple commands to set up [tree-sitter-unison](https://github.com/kylegoetz/tree-sitter-unison). + +You can then use `M-x eglot` in a Unison scratch file buffer. You can also [configure Eglot to start automatically](https://www.gnu.org/software/emacs/manual/html_node/eglot/Starting-Eglot.html). + +### Other Editors + +If your editor provides a mechanism for connecting to a host and port, provide a host of `127.0.0.1` and port `5757`. + +If your editor requires a command to run, you can provide the command `nc localhost 5757` on Mac, or `netcat localhost 5757` on linux. +Note that some editors require passing the command and arguments as separate parameters. + +## Configuration + +Supported settings and their defaults. See information for your language server client about where to provide these. + + - `formattingWidth`: A suggestion for the formatter about how wide (in columns) to print definitions. + + - `maxCompletions`: The number of completions the server should collect and send based on a single query. Increasing this limit will provide more completion results, but at the cost of being slower to respond. + + If explicitly set to `null` the server will return ALL completions available. + +``` json +{ + "formattingWidth": 80, + "maxCompletions": 100 +} +``` diff --git a/unison-src/transcripts/project-outputs/docs/metadata.output.md b/unison-src/transcripts/project-outputs/docs/metadata.output.md new file mode 100644 index 0000000000..5a69896347 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/metadata.output.md @@ -0,0 +1,34 @@ +The Unison codebase format needs to be able to store metadata about definitions it contains, such as: + + - Author, copyright holder + - Creation date + - License + - API docs + - Boolean indicating whether a definition is a test, needed to support incremental test evaluation + - Comments that annotate subpaths of the definition + - ... + +Some desired features: + + - We probably won't know all the kinds of metadata in advance, so having it be extensible would be good. + - Metadata should probably be versioned. (Example: what if you want to change the license of a definition?) + +A simple proposal is to just add metadata information at each level of the versioned namespace tree: + +``` Haskell +-- Metadata is always just a link to some other term +newtype Metadata = Metadata Reference +newtype MetadataType = MetadataType Text -- "License", "Creation date", etc + +data Branch0 = + Branch0 { _terms :: Relation NameSegment Referent + , _types :: Relation NameSegment Reference + , _edits :: ... + , _metadata :: Relation (MetadataType, Referent) Metadata } +``` + +That's it. Metadata is just a "link", a lightweight reference to some other definition. + +We don't try to make `MetadataType` more strongly typed. It's just a string, its meaning determined by convention. For instance, the default CLI viewer can look for an "API docs" key, and use that in its display. + +Nothing special for the on disk format, it can just be encoded the same way as the other relations in the Branch0. diff --git a/unison-src/transcripts/project-outputs/docs/nix.output.md b/unison-src/transcripts/project-outputs/docs/nix.output.md new file mode 100644 index 0000000000..f325a83384 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/nix.output.md @@ -0,0 +1,65 @@ +(Todo: it might be nice to have a gentle and concise introduction into why Unison does anything with Nix and what cachix is.) + +We can push any nix store path into our cachix cache. This is typically done with `cachix push unison `. + +Some ways to come up with a store path: + +1. If you build something you get a symlink to the store path of the built thing, named `result` by default. +2. With `nix path-info` + +So, you could push the unison executable with the cache with + +``` nix +nix build -o my-little-unison-store-path +cachix push unison my-little-unison-store-path +``` + +or + +``` nix +nix build | cachix push unison +``` + +We want to cache the \[immediate\] build dependencies of our build products, because those are the only ones actually needed to build our build products. + +``` nix +nix-store --query --references $(nix path-info --derivation) | xargs nix-store --realize | cachix push unison +``` + +Breaking down the above: + +``` nix +nix path-info --derivation +``` + +gets the store path of the derivation of the unison executable + +``` nix +nix-store --query --references $(nix path-info --derivation) +``` + +gets the store paths of the derivations of immediate dependencies of the unison executable derivation. + +``` nix +nix-store --query --references $(nix path-info --derivation) | xargs nix-store --realize +``` + +builds the above derivations if necessary and writes the resulting store paths to stdout + +These paths are then fed to cachix with `| cachix push unison`. + +Development environments are defined in the flake under the `devShells` key. There are a number of different development environments, and they can be entered by giving a different argument to `nix develop`. If you want to push a development environment you could do so with something like: + +``` nix +nix build --no-link '.#devShells.x86_64-linux.default' | cachix push unison +``` + +and you could push the build dependencies of the default shell with something like + +``` nix +nix-store --query --references $(nix path-info --derivation '.#devShells.x86_64-linux.default') | xargs nix-store --realize | cachix push unison +``` + +``` nix +nix-store --query --references $(nix path-info --derivation '.#devShells.aarch64-darwin.default') | xargs nix-store --realize | cachix push unison +``` diff --git a/unison-src/transcripts/project-outputs/docs/publishing-library1.output.md b/unison-src/transcripts/project-outputs/docs/publishing-library1.output.md new file mode 100644 index 0000000000..c01a49adbe --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/publishing-library1.output.md @@ -0,0 +1,389 @@ +# Using library code in my application + +## Current status + +We've thought of library code as coming from a different branch, which we incorporate by merging branches. (There's no other way to utilize a branch, except to merge it.) + +Branches come from the `.unison` directory on disk, and `.unison` directories from external sources can be merged externally by recursively merging the directories. When two `.unison` directories each contain a branch with a given name, the two branches are merged by the `unison` tool. + +Each branch consists roughly of a `(Name, Reference)` "namespace" relation, and an `(Reference, Replacement)` "edits" relation. + +### Some problems with this + + - There are a lot of steps: + - Download someone's repo + - Make a new dir and git clone to it? + - Figure out how to recursively merge directories + - Maybe that's not that many steps. + - We incorporate all of the incoming branch's names (including dependency names?), whether you want them or not. + - This by itself isn't necessarily a dealbreaker, but it implies a lot of energy (or tooling) will be needed to provide immaculate namespaces in published libraries. + - We incorporate and activate all of the incoming branch's edits, whether you want them or not. + - Ditto + +### Question about collaborative edit semantics + +If you rename `foo` to `bar`, and I upgrade `foo#a` to `foo#b` and share my work with you, should you end up with `bar#a` and `foo#b`, or just `bar#b`? + +## What might be nicer? + +### A built-in way to get a published branch + +#### Idea: Provide a command to create a local branch from a Github repo + +``` +app> branch.clone gh:/[:ghbranch][/] lib + + Got 17 definitions from gh:user/ghrepo:ghbranch/ubranch + +lib> +``` + +#### Idea: Let existing branch commands support `gh:` scheme + +``` xml +branchspec + := 'gh:' '/' [ ':' ] [ '/' ] + | +``` + +``` +master> branch.checkout gh:aryairani/either + + Synced 23 definitions. -- example output, idk + +gh:aryairani/either> branch.checkout meetup3 + + Ok. + +meetup3> +``` + +Question: Can the "current" branch be remote, or do we need to introduce remote-tracking branches like git does; the former seems simpler IMO. We would need an offline mode for a branch, and it should be as transparent to the user as possible. + +### Use a branch without first merging? + +#### Idea: Reference other branches via qualified imports + +``` +prefix := wordyId [ '.' prefix ] +id := [ prefix '.' ] ( wordyId | '(' symbolyId ')' +ids := id [ ' ' ids ] + +importspec + := 'import ' branchspec [ '/' prefix ] [ '(' ids ')' ] [ ' hiding (' ids ')' ] + | 'import ' branchspec [ '/' prefix ] [ ' as ' prefix ] +``` + +Sample program: + +``` +import experiment2 as e2 -- embed a local branch into the current namespace +import gh:aryairani/either as Either -- embed a git branch into the cur. namespace + +foo = Either1.Either.rightToOptional (e2.runExperiment data) +``` + +##### Redundant qualifiers? + + - Adding another (qualified) prefix to identifiers in a branch without also removing some leads to unnecessary line noise: `Either.Either.rightToOptional`. + + - We could reference deeper into a branch for our qualified imports: + + ``` + import gh:aryairani/either/Either as Either + foo = Either1.rightToOptional + ``` + + Now we've imported only names prefixed with '`Either.`' from `aryairani/either`, and can refer to them by prefixing them with '`Either.`', i.e. `Either.rightToOptional` instead of `Either.Either.rightToOptional` in the previous example. + +#### Idea: Branch-qualified identifiers + +We can add a syntax for branch-qualified identifiers, then proceed with normal branch-management commands, then proceed with normal branch-management commands. + +``` +meetup3> alias gh:aryairani/either/Either.rightToOptional Either.rightMay + ┌ + │ ✅ + │ + │ I aliased the term gh:aryairani/either/Either.rightToOptional to + │ Either.rightMay. + └ + +meetup3> +``` + +This is pretty first-order and terrible. + +#### Idea: Merge libraries not at their roots + +``` +meetup3> merge gh:aryairani/either as Arya + + Copied 17 names. Use `details` to list them. + +meetup3> view Arya. + + Arya.Either.rightToOption : Either a b -> Option b + Arya.Either.leftToOption : Either a b -> Option a + ... + +meetup3> +``` + +#### Idea: `import` statements are 1st class entities + +`import` statements could be first-class things that are added to the namespace on an `add`. + +> Side note: This reminds me, I think there are reasons to reconsider adding support for `add`ing individual definitions from .u to branch. I have a WIP for this, but it doesn't work. 😅 Could probably knock it out quickly by pairing. + +Anyway, if we `>add` on this file, + +``` haskell +import gh:ghuser/ghrepo:treeish/unisonbranch as Foo +import gh:arya/either:either//Either as E -- 🤔 so many "either" +bar x = E.fromJust (Foo.foo x) + 1 +``` + +we also add an entry to the namespace: + +``` haskell +("Foo", QualifiedImport (Github "ghuser" "ghrepo" (Just treeish) "unisonbranch") Nothing) +("E", QualifiedImport + (Github "aryairani" "either" Nothing "default?master?") + (Just "Either") ) +``` + +where + +``` haskell +data BranchSpec + = Local UBranchName + | Github Username Repo (Maybe Treeish) UBranchName + +data QualifiedImport = QualifiedImport + { branchSpec :: BranchSpec + , from :: Maybe Prefix + , as :: Prefix + } +``` + +This could be a Haskell value or a Unison term. `import` could also be a CLI command (syntax tbd). + +We can copy any remote data to a github cache under `.unison/cache/gh/gh-commit-id` or `.unison/cache/gh/ghuser/ghrepo/gh-commit-id` or whatever, and reuse it from there, or refresh it according to some protocol. + +When I reference `E.fromJust` or `Foo.foo` it looks in the branches it downloaded from github. The names of transitive dependents are added to "oldnames", so if the remote name goes away, or the link is deleted, we still have some text to display. If `treeish` is a git hash, it would refer to an immutable thing, so it could be cached permanently. + +#### Idea: First class namespace — move this to publishing section? + +This is basically the previous idea but allowing for more complex structure. Instead of just being a link to a remote namespace in its entirety, we could have a single value that describes many imports; these structures can be imported in the same way within .u files, Github gists, etc. + +``` +prefix := wordyId [ '.' prefix ] +id := [ prefix '.' ] ( wordyId | '(' symbolyId ')' +ids := id [ ' ' ids ] + +importspec + := 'import ' branchspec [ '/' prefix ] [ '(' ids ')' ] [ ' hiding (' ids ')' ] + | 'import ' branchspec [ '/' prefix ] [ ' as ' prefix ] + +namespace := 'namespace ' id ' where' [ imports, defs ] +``` + +Sample program: + +``` haskell +namespace AryaPack where + -- can reference local branch experiment1's `dataset` as `e1.dataset` + import experiment1 as e1 -- embed a local branch into the AryaPack namespace + -- Can reference runar's Multiset.Multiset.empty as Multiset.empty + import gh:runarorama/Multiset (Multiset.fromList) + -- Can reference paul's Simple.Example.Example1 as AryaPack.Example1 + import gh:pchiusano/EasyTest/Simple.Example as Example + + myFunc = Multiset.fromList (Example.summarize e1.dataset) +``` + +The above becomes a term named `AryaPack : Namespace`, which I somehow get into my github aryairani/AryaPack project. + + - Basically this is syntax sugar for defining a special Unison object. We could also define it with normal Unison constructors, although it would probably be uglier. + - The above program includes a definition along with the imports, but that doesn't have to be allowed. + +Then the program below works: + +``` haskell +import experiment2 as e2 -- embed a local branch into the current namespace +import gh:eed3si9n/hello as Hello -- embed a git branch into the cur. namespace +from gh:aryairani/AryaPack/AryaPack import myFunc +-- ^^ repo ^^ branch ^^ term; in this case, a namespace +``` + +## + +#### Question: When do we actually download stuff? + +When do we actually bring those names/definitions into the local codebase, so we can view dependents without being online, or if the import statements are removed from .u file? + +##### Idea: Copy referenced names/defs into the branch + +If we `>add` on this file: + +``` +import gh:aryairani/either/Either as Either +foo = Either1.rightToOptional +``` + +we get a temporary copy of the `gh:aryairani/either` branch (maybe greedily get the whole remote codebase, or maybe stream data as needed), use it to retrieve names and dependencies of any symbols we may try to resolve against it. If `foo` is added to the local branch, then we save the names of those remote dependencies into the local branch as well. + +###### Question: What names do we assign to unreferenced dependencies? + +### What if the codebase were a tree, rather than a list of branches? + +\#\#\#\#Hand-wavy example + +``` +/> clone gh:aryairani/libfoo + Copied gh:aryairani/libfoo blah blah to /libfoo +/> undo +/> clone gh:aryairani/libfoo /libs/DeepLearning/Foo + Copied gh:aryairani/libfoo blah blah to /libs/DeepLearning/Foo +/> +``` + +Sorry that I am using `/` and `.` interchangeably. + +I'm using `.`, because it's the typical code identifier separator we're used to, and I'm using `/` because it looks like directories and also commonly represents a tree root. `.` doesn't feel good as a tree root, because it common represents the "current" node in a tree. There's also the Scala route of `.` separator and `_root_` means the tree root. 😅 + +Anyway, we have some kind of structure like: + +``` +/Builtin +/libs/UJson +/libs/Stream +/libs/DeepLearning/Bar +/libs/DeepLearning/Foo +/projects/BoringCrudApp +/projects/ChordProgressions +/projects/FaceDetector +``` + +``` +/> cd projects +/projects> rename FaceDetector FaceDetector/V1 +/projects> cd FaceDetector +/projects/FaceDetector> cp V1 V2 +-- +/projects/FaceDetector> replace.scoped V2 /libs/DeepLearning/Foo/thing1 mything1 + + Noted replacement of thing1#af2 with mything#i9d within /projects/FaceDetector/V2. + +/projects/FaceDetector> todo + ...7 things... +/projects/FaceDetector> todo / + ...33 things... +/projects/FaceDetector> +``` + +#### How do you reference code in a system like this? + +##### Idea: Absolute imports + +.u: + +``` haskell +import /projects/FaceDetector/V1 as V1 +-- or: import _root_.FaceDetector.V1 as V1 +compareResult = foo V1.result result +``` + +CLI: + +``` +projects/FaceDetector/v2> + Typechecked the following definition: + compareResult : Result +``` + +vs + +``` +projects/FaceDetector> + Typechecked the following definition: + compareResult : V2.Result +``` + +##### Idea: Relative imports + +``` haskell +import ../V1 as V1 +-- or: import _parent_.V1 as V1 +``` + +##### Also: TDNR + +Given: + +``` +/foo/bar/Bar.baz -- #abc +/blah/wah/Bar.baz -- #xyz +``` + +TDNR candidates are `foo.bar.Bar.baz` and `blah.wah.Bar.baz` + +##### Benefit: Organize your shared repo to arbitrary depth + +``` haskell +import gh:aryairani/awesome-unison/alltheparsers/specificparser/submodule as M +``` + +#### What are the units of code sharing and collaboration? + +You can easily imagine exporting a subtree, but what if that subtree references definitions that are outside of it? e.g. you want to share `/Foo/`, but `Foo.bar` references `/Quuz.quuzCount`? + + - Unison could warn you, and help you stage a subtree to publish. "I can collect all these referenced names into a subtree for you to bulk edit" + + - Unison could make up / choose some appropriate names based on the current tree: + + ``` haskell + namespace Dependencies where + static import /libs/Foo as Abc -- this is replaced by a full/static copy of the names + static import /temp/Bar as Xyz -- some other library code in this subtree uses + ``` + + In this next syntax block, I'm tagging subtrees with a publication location, to avoid needing to have separate unison repos on your local machine for each project. e.g. One repo would have all your preferred customizations. + + ``` + /projects/FaceDetector/V2> publish.set-destination.scoped .. gh:aryairani/face-detector + I will publish /projects/FaceDetector to gh:aryairani/face-detector + /projects/FaceDetector/V2> publish + + Syncing /projects/FaceDetector to gh:aryairani/face-detector + Syncing / to gh:aryairani/private-repo + + /projects/FaceDetector/V2> + ``` + + Elsewhere: + + ``` + libs> clone gh:aryairani/face-detector FaceDetector + libs> ls FaceDetector + + Dependencies.Abc.asdf : Blah -> Blah + Dependencies.Abc.ghjk : Blah -> Blah + Dependencies.Xyz.awww : Blah -> Blah + V1.result + ... + V2.result + ... + libs> + ``` + +# Sharing my code as library + +TBD, but it will include: + + - specifying which code + - specifying the publication destination + - juggling some credentials for the destination + +Next: [Updating my library & sharing an updated library](publishing-library2.md) diff --git a/unison-src/transcripts/project-outputs/docs/publishing-library2.output.md b/unison-src/transcripts/project-outputs/docs/publishing-library2.output.md new file mode 100644 index 0000000000..8f7fa1d466 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/publishing-library2.output.md @@ -0,0 +1,179 @@ +previous: [Using library code in my application & sharing my application as a library](publishing-library1.md) + +# Updating my library & sharing the updates + +We can imagine a number of potential classes of structured edits to the codebase, each requiring their own supporting data and DX design. Like the ability to assign of names to references, these aren't fundamental to Unison; but they are critical to usability. + +In designing our codebase representation, we should remember that **the set of edit helpers will likely change over time**. Although the codebase editor will have to change to support new edit classes, **the codebase format may not need to**. i.e. each edit class could have some ID as part of its supporting data, and data for edit classes not supported by a particular codebase editor could be gracefully ignored. + +## Replacement & deprecation of definitions + +The first structured edit we've begun to tackle is: replacement and deprecation of definitions, propagated to dependents within the scope defined by a branch's namespace. + +Currently, we accumulate "edit" directives as part of a branch: + +``` haskell +editedTerms :: Branch0 -> Relation Reference TermEdit +editedTypes :: Branch0 -> Relation Reference TypeEdit +data TypeEdit = Replace Reference | Deprecate +data TermEdit = Replace Reference Typing | Deprecate +data Typing = Same | Subtype | Different +``` + +A relation `(r, edit)` indicates that we are working to remove `r` from the edit scope (currently: the branch `Namespace`). + + - These edits are simply metadata used by the `todo` and (unused/obsolete?) `propagate` commands. + - These edits currently accumulate forever and are applied in perpetuity. + - Edits are meant to be used to help users of a library to upgrade between versions, by describing how to rewrite their usage sites. + +We are going to want to do some or all of the following: + + - Define/use short-term edits + - Define edits within a limited set of code + - Share with others how to upgrade their own dependents of our code, *in a way that allows them to understand what's going to happen and then choose to opt-in*. + +### Short-term edits + +We can quick-fix the "in perpetuity" part by giving the user an `edit.clear` command to "forget" an edit directive in a branch. There are potentially a huge number of edits for the user to select among, but we can help a little with that by utilizing the same numbered-args scheme as `ls` currently uses, and/or by offering different ways of sorting: by name, by recency, other? + +### Making managing edits manageable + +If a human is meant to maintain this list by manually culling edit directives, he will need more context than a list of `Reference` pairs. e.g.: Where did this edit come from? Was it created by the `update` command on a .u file, or the \[likely not yet implemented\] `replace` command in the code editor? Or by auto-propagation? By whom? When? Other? We should add at least a flag to indicate whether the update was manual or auto-propagated. Maybe even a human-readable message: + +``` haskell +data EditSource = ManualUpdate | ManualReplace | AutoPropagate +data EditReason = EditReason EditSource (Optional Text) +``` + +### Managing multiple sets of edits + +Here is a hand-wavy, imagined script for managing multiple sets of edits: + +``` +master> + ┌ + │ ✅ + │ + │ I found and typechecked these definitions in Base.u: + │ + │ Sequence.map : c -> (a -> b) -> [a] -> [b] + │ + │ Now evaluating any watch expressions (lines starting with `>`)... + └ +master> edit.set-reason adding a silly parameter to Sequence.map +master> update + ┌ + │ ✅ + │ + │ I updated these definitions as part of "adding a silly parameter to + │ Sequence". + │ + │ Sequence.map : c -> (a -> b) -> [a] -> [b] + └ +master> edit.list + + "adding a silly parameter to sequence": + Terms: + Sequence.map#31q -> Sequence.map + Sequence.map#aa4 -> Sequence.map#31q + +master> edit.elide Sequence.map#31q + + You still have 6 dependents of Sequence.map#31q in this branch. + + Repeat the same command to proceed anyway. + + Tip: Use `todo` to see what's left to do in the refactor. + + Tip: Use `edit.clear Sequence.map#31q` to cancel refactoring its dependents. + +master> edits.save Sequence.wip20190315 + + 2 edits saved as Sequence.wip20190315 + +master> edit.elide Sequence.map#31q + + You still have 6 dependents repeat the same command to proceed anyway. + +master> edit.elide Sequence.map#31q + + Cleared: + Sequence.map#31q -> Sequence.map + Sequence.map#aa4 -> Sequence.map#31q + + Added: + Sequence.map#aa4 -> Sequence.map + + +master> edits.save Sequence.upgrade20190315 + + 1 edit saved as Sequence.ugprade20190315 + +master> publish gh:aryairani/Sequence:sequence + + Pushed 2 new definitions to gh:aryairani/Sequence/sequence + +master>^C +``` + +Then, elsewhere: + +``` haskell +import gh:aryairani/Sequence:master/Sequence as Sequence +``` + +``` +master> add +``` + +``` +master> edits.activate git:runarorama/Multiset/Multiset.upgrade2_3 + + Activated 6 edit directives. + + Your branch has 37 affected dependents, 35 of which can be upgraded automatically. + + Tip: Use `view git:runarorama/Multiset/Multiset.upgrade2_3` to summarize the changes. + + Tip: Use `todo` to see what's left to complete these edits. + +master> todo +``` + +### First-class edits + +An edit set could be represented by a Unison term. The previous example is meant to be ambiguous as to whether or not that is the case, but it could be, and I suspect + +### How do we manage secondary edits? + +Working through one set of edits/upgrades produces a secondary set of edits. Where, if anywhere should this secondary set be saved long-term? What effect will it have on bookkeeping if a user wants to process more than one first-class edit sets at the same time? i.e. in the course of processing updates from library Foo to library Foo', and library Bar to library Bar', if I update App.func1 to App.func1', to which library update can I attribute that change? Well, we haven't discussed anything about attributing application changes to library changes, but + +## Curating edits + +The user should be able to curate the list of edits that are in the branch, like what we do when auditing an unsubmitted Github PR. The example script in the earlier section explores this a bit, but if the edit lists could be edited in the `.u`, or by Unison code at some point in the future, that will probably be much more convenient than implementing a ton of CLI commands to manipulate the list(s). + +### Curating name changes + +Could the branch/namespace also be a first-class Unison term? How would that ground out? + +## Publishing a set of edits + +If a set of edits is just a Unison term that the CLI knows about, then you can publish it in the same way you publish unison terms; TBD once we confirm the branch/repo format. + +## Using an updated library + +The example above touched on this in the example above, with + +``` +> edits.activate gh:runarorama/Multiset/Multiset.upgrade2_3 +``` + +or, having linked `/libs/Multiset` to `gh:runarorama/Multiset/...`: + +``` +> edits.activate /libs/Multiset/upgrade2_3 +``` + +We can collect additional questions here. + + diff --git a/unison-src/transcripts/project-outputs/docs/publishing.output.md b/unison-src/transcripts/project-outputs/docs/publishing.output.md new file mode 100644 index 0000000000..b961d886d3 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/publishing.output.md @@ -0,0 +1,10 @@ +# Publishing Unison code + +Thinking about a design for publishing Unison code revealed a nest of interrelated concerns: + + - [Using library code in my application & sharing my application as a library](publishing-library1.md) + - [Updating my library & sharing an updated library](publishing-library2.md) + + + +Each of these linked subtopics presents concerns, questions, and ideas, which we can weigh and collect into [our M1 proposal](publishing-M1.md). diff --git a/unison-src/transcripts/project-outputs/docs/release-steps.output.md b/unison-src/transcripts/project-outputs/docs/release-steps.output.md new file mode 100644 index 0000000000..52eb16ab5d --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/release-steps.output.md @@ -0,0 +1,92 @@ +# Release Steps + +## 1\. (Major milestones only) New Base Release + +Cut a release of base. @runarorama does this usually. + +``` +.> pull git(git@github.com:unisonweb/base) basedev.release +.> cd .basedev.release +.basedev.release> delete.namespace releases._latest +.basedev.release> squash trunk releases._ +``` + +Edit `releases._.README` to include `Release: `. + +``` +.basedev.release> fork releases._ releases._latest +.basedev.release> push git(git@github.com:unisonweb/base) +``` + +## 2\. Run Release script + + - **Milestone Release**: Look up the most recent release; bump the number and remove any trailing letters, e.g. `./scripts/make-release release/M5 trunk` + - **Minor Release**: Increment the trailing letter of the previous release, or add an `a` to the previous milestone release, e.g. `./scripts/make-release release/M5a trunk` + +Then, using the new release version, from the root of the `unisonweb/unison` project run: + +``` sh +./scripts/make_release.sh [TARGET (defaults to trunk)] +``` + +This will tag the appropriate versions in all the required projects, and kick off all of the necessary CI jobs to ship a release. + +Including: + + - A release workflow in `unisonweb/unison` to build UCM on multiple platforms, create a release with appropriate release notes from the previous release, and upload the artifacts to that release. + - A release workflow in `unison-local-ui` to build UCM on multiple platforms, create a release with appropriate release notes from the previous release, and upload the artifacts to that release. + - A release workflow in `homebrew-unison` to wait for artifacts to be uploaded, then download those artifacts, get the checksums, and create an up-to-date homebrew formula. + +After successfully executing the script you just have to sit tight and wait for all the jobs to complete. + +## 3 + +Smoke test of the new release. Try `brew upgrade unison-language`, launch it, launch `ui`. + +## 4 + +Write up release notes, template below. + +Preview the markdown in Slack \#general and tag @paul. + +## 5 + +If there are new builtins, redeploy Share. + +## 6 + +Announce on \#general Discord channel. + +----- + +@everyone We've just released a new version of Unison, $RELEASE\_NAME. + +----- + +**macOS or Linux w/ Homebrew:** +Install or upgrade is just `brew upgrade unisonweb/unison/unison-language`. + +**macOS or Linux manual install:** +macOS + +``` +mkdir -p unisonlanguage && cd unisonlanguage +curl -L https://github.com/unisonweb/unison/releases/latest/download/ucm-macos.tar.gz \ + | tar -xz +./ucm +``` + +Linux + +``` +mkdir -p unisonlanguage && cd unisonlanguage +curl -L https://github.com/unisonweb/unison/releases/latest/download/ucm-linux.tar.gz \ + | tar -xz +./ucm +``` + +**Windows manual install:** + + - Recommended: [Set your default Terminal application](https://devblogs.microsoft.com/commandline/windows-terminal-as-your-default-command-line-experience/) to “Windows Terminal”. + - Download [the release](https://github.com/unisonweb/unison/releases/latest/download/ucm-windows.zip) and extract it to a location of your choosing. + - Run `ucm.exe` diff --git a/unison-src/transcripts/project-outputs/docs/runtime-calling-conventions.output.md b/unison-src/transcripts/project-outputs/docs/runtime-calling-conventions.output.md new file mode 100644 index 0000000000..9b1fb09e2a --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/runtime-calling-conventions.output.md @@ -0,0 +1,51 @@ +### Lambda + + - called with arguments in declared order. + - whenever a lambda is called, it takes itself as `rec` + - it evaluates the body passing the bound lambda parameters on the stack + +### Computation + + - bound variables passed on stack with innermost scope closest to index 0 + - "rec" is passed as well (?) + - evaluations in nontail positions need to catch handle TC because their "frame" + has more work and shouldn't be thrown away; evaluations in tail positions can + throw their tailcalls upward and discard their frame + - let1/letrec evaluate the bindings with the existing stack (bound variables in their scope); + body is called with bindings prepended to stack + - compilevar returns rec if its name matches currentRec, + otherwise looks up a value on the bindings stack + - compilelambda returns a computation that will produce a lambda when evaluated + - apply + - if fn name matches currentRec, then staticRecCall + - staticRecTailCall + - throw selfTailCall with evaluated args (seems like this would not do anything) (?) + - staticRecNonTailCall + - call (rec: Lambda) with evaluated args + - a SelfCall exception should never escape the wrapper lambda + - else compile fn + - if compiled fn is Return(Lambda) + - staticTailCall + - throw tailcall with fn + - staticNonTailCall + - call fn with rec = fn + - else compiled fn is not yet a lambda, and needs to be evaluated again (at least once) + - dynamicTailCall + - eval mkFn and assume it produces a lambda (it should) + - throw tailcall with lambda and eval'd args + - dynamicNontailCall + - eval mkFn and assume it produces a lambda (it should\!) + - call lambda with evaluated args + +### Tail calls + +tailcall throws an exception with the target function & args +selfTailCall throws a tailcall with null(implied?) function + +when a tailcall exception is caught, we enter a while loop which calls the +target function and continues to catch tail calls until the target function +is null. + +note that the selftailcall begins with null. (?) don't understand + +### annotated bounds diff --git a/unison-src/transcripts/project-outputs/docs/sharing-code.output.md b/unison-src/transcripts/project-outputs/docs/sharing-code.output.md new file mode 100644 index 0000000000..7ff0619231 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/sharing-code.output.md @@ -0,0 +1,135 @@ +# Sharing code + +``` haskell +data Causal m e + = One { currentHash :: Hash, head :: e } + | Cons { currentHash :: Hash, head :: e, tail :: m (Causal e) } + -- The merge operation `<>` flattens and normalizes for order + | Merge { currentHash :: Hash, head :: e, tails :: Map Hash (m (Causal e)) } + +-- just one level of name, like Foo or Bar, but not Foo.Bar +newtype NameSegment = NameSegment { toText :: Text } +newtype Path = Path { toList :: [NameSegment] } + +data Namespace m = Namespace + { terms :: Relation NameSegment Referent + , types :: Relation NameSegment Reference + , children :: Relation NameSegment (Codetree m) + } + +data Codetree m = Codetree (Causal m Namespace) + +data RemotePath = RemotePath RemoteRef Path +data RemoteRef = GithubRef { username :: Text, repo :: Text, treeish :: Text } + -- | ... +-- "gh:/[/][?ref=] -- treeish defaults to repo's `default_branch` +-- "gh:aryairani/unison/libs?ref=topic/370" becomes +-- RemotePath (GithubRef "aryairani" "unison" "topic/370") (Path ["libs"]) + +newtype EditMap = EditMap { toMap :: Map GUID (Causal Edits) } +data Edits = Edits + { terms :: Relation Reference TermEdit + , types :: Relation Reference TypeEdit + } + +-- maps local paths to remote paths +data RemoteStatus = Map Path RemoteSpec +``` + +A couple of important points: + + - A namespace is "just" part of your preferences for parsing (and to some extent, rendering) code. + - Edits as we know them are just state for edit helper commands, like "todo" and "propagate" + - We should consider making the codebase representation of this data modular, since they really can be separated; they are likely still meaningful even in the presence of unexpected state/preferences that might exist in the future to support other features of future versions of the editor. + - We use `Causal` to represent a shareable data structure — shareable in the sense that which can tell whether a certain change came after another. + +Questions: + + - Do we want to distinguish between `/` paths and `.` separators in names? + + - Should a type `A` be at the same level as + + - On one hand, you probably don't need to separate a type `A` from its constructor `A.A`. You wouldn't be able to export the constructor without the type which resides a level up in the namespace. + + - Maybe the type `A` should organically be organized as `A/A`, and its constructor also as `A/A`. This is reminiscent of having a separate module per type in Haskell, except that a reorganization could be done more easily: + + ``` + /mycode> mv ClassA* ClassA/ + /mycode> mv ClassB* ClassB/ + /mycode> cd ClassA + /mycode/ClassA> ls + ``` + + - ``` + + ``` + +## NameTree representation + +examples: + +``` + + +/A (type) +/A (term) +/A/A (ctor) + + + +``` + +``` haskell +data NameTree a = Causal (Relation Name (NameTree a)) +``` + +or + +``` haskell +data NameTree a + = Leaf a + | Branch (Relation Name (NameTree a)) + | SharePoint (Causal (NameTree a)) +``` + +## Github Notes + +Base: https://api.github.com/repos/unisonweb/unison/ + +Branches: https://api.github.com/repos/unisonweb/unison/branches + +A directory: + +``` +url: +https://api.github.com/repos/unisonweb/unison/contents/unison-src/demo?ref=master + +html_url: +https://github.com/unisonweb/unison/tree/master/unison-src/demo + +git_url +https://api.github.com/repos/unisonweb/unison/git/trees/f8d91c6cc2ee1bc8f2bfc759e328a851d0df3b95 +``` + +A file: + +``` +url: +https://api.github.com/repos/unisonweb/unison/contents/unison-src/Base.u?ref=master + +html_url: +https://github.com/unisonweb/unison/blob/master/unison-src/Base.u + +git_url: https://api.github.com/repos/unisonweb/unison/git/blobs/e617fbad4e32d25380f536179f558f9213cd4bad + +download_url: +https://raw.githubusercontent.com/unisonweb/unison/master/unison-src/Base.u +``` + +Note that `treeish` (in this example, `master`) can contain slashes, such as `topic/370`. This makes parsing a little tricky. Fortunately, if you have a git branch `a/b` then it's not possible to create branches `a` or `a/b/c`. So you can load the list of branches, and then test them against that treeish-prefixed path: + +`https://github.com///<"tree" or "blob">/` + +If any of the branch names + `/` form a prefix of `treeish-prefixed-path`, then the suffix is the path into the causal. Crap, wait. The github HTML UI isn't going to be showing Unison paths at all. + +So, we could use out made up `gh:username/repo[:treeish][/path]` URI scheme; can support others as desired. Maybe our Javascript viewer will create URLs with query params that can indicate the Unison path. diff --git a/unison-src/transcripts/project-outputs/docs/testing.output.md b/unison-src/transcripts/project-outputs/docs/testing.output.md new file mode 100644 index 0000000000..0ac2a53377 --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/testing.output.md @@ -0,0 +1,57 @@ +### Testing and watch expression caching + +First, let's get this out of the way. One uncontroversial, status quo way to do testing in Unison: just use a regular main function. So, by convention, your branch might have a term, `tests : '{IO} Boolean` or perhaps `[Text] ->{IO} Boolean`, if it has an EasyTest-like interface where you can select scopes dynamically. You then do: + +``` +> execute tests +``` + +In your branch and it runs your tests and prints out some nice emojis. If you're running `tests` standalone and care about exit codes, you probably take the `Boolean` you get, where `true` indicates success and `false` indicates a failure, and convert that to an exit code. Assuming `IO` has some way of exiting with an exit code. + +(Note, we don't have a way of launching `unison` to run some commands on a branch then quit yet, but we probably will have something like `unison mybranch execute tests ["math"]`.) + +Easy peasy. Nothing special we need to do to enable this mode of working, and it's going to be how you do any sort of integration tests that need to talk to the outside world. + +### Easy incremental testing for pure tests (the "tests cache") + +But, when tests *aren't* in `IO`, there's no need to rerun them unless one of their dependencies changes (though you can if you want to). A simple proposal which lets us take advantage of this is we allow watch expressions to be marked as tests. They have to be of type `Test.Status`: + +``` +type Test.Status = Failed Text | Passed Text +``` + +> We debated whether to make tests have more structure and came down on "no" - different testing combinator libraries or abilities can handle all that, and this `Test.Status` is more like a final compilation target for different testing APIs: the test passed or failed, and has some human-readable information in it. That's it. + +And to mark a watch expression as a test, you say: + +``` Haskell +test> Test.equal (sort [3,1,2]) [1,2,3] +``` + +> Hmm, what if your test needs a whole bunch of auxiliary definitions and doesn't fit in a single watch expression? Easy, just introduce regular definitions for these, perhaps with some simple naming convention (like I'd prefix these testing helper definition names with `tests.`). + +> Did you consider just keying off the type of the watch, like if it's of type `Test.Status`, assume it's a test? Yes we did, but we decided being explicit was better. Also by communicating your intent up front, you can get better feedback from the tool ("er, looks like this isn't a test, here's how you can make it one") vs silently ignoring the thing the user thought was a test and just not adding it to the branch. + +On `add`, these `test>` watches are added to the codebase. Watch expressions marked as `test>` are also added to the namespace of the branch and given some autogenerated unique name (perhaps just computed from the hash of the test itself), unless the watch expression picks a name as in `test> test.sortEx1 = ...`. The user is told these names on `add`/`update` and can always rename them later if they like. Don't forget that in the event of a test failure, Unison can also show you the full source of the failed watch expression. Also note that the `Passed` and `Failed` cases might include the name of the "scope" of the test or other relevant info. So I'm not sure how important these names will be in practice + +There's a directory, `tests/`, containing files of the form `.ub`. The `hashXYZ` is a reference to the source of the original watch expression (in this case, the `Test.equal (sort [3,1,2]) [1,2,3]`), and the `.ub` file itself is a serialized `Test.Status`. We can ask if a branch is passing just by taking the intersection of the hashes in the branch with the hashes in this directory and seeing if all the `Test.Status` values for the branch are `Passed`. Notice this doesn't involve running any of the tests\! + +Since these test watches are part of the branch, they get refactored just like everything else when their dependencies change. Nothing special there, which is nice. We suggest that `update` rerun any changed tests by default. Here's how that works: + + - On `update`, we check the `tests/` directory and compare the hashes there to the edits list in the branch. If there's a file `.ub`, and the branch has an edit `hashXYZ -> hashPQR`, we lookup the source of `hashPQR` and evaluate it, and store the result in `.ub`. We do this for any affected tests. + +The `tests/` directory will be versioned, so everyone collaborating on the code shares a cache of test results. As the tests are 100% deterministic, this is fine, unless of course someone manually mucks with that directory to doctor some test results, or if like a freak gamma ray corrupts your test as it's running and gives the wrong result. But note that you can always choose to rerun some or all of your tests, ignoring the cache - just lookup the source of the `` and recompute it. (And perhaps there's a command to do that in bulk for a whole branch.) If it doesn't match, you can then hunt down the person who added that bogus test result. :) + +### Caching watch expressions (the "watches cache") + +Same idea, except that the source of a watch expression isn't added to the codebase. We just have a `watches/` directory in the same spot, with files `.ub` in it, which contain the evaluated result of the watch whose source was `hashXYZ`. Optionally, `watches/` directory could be in some other user-configurable location. + +When evaluating a Unison file, we have to hash all its definitions. If one of those hashes matches a hash in the `watches/` directory, we skip its evaluation and return the cached value. + +This caching can be done by default, but I suggest that the `watches` directory *not* be versioned as the values might be quite large. However, I could see people wanting to share their watches cache and sticking it on some shared file system. + +### Implementation notes and remarks + +We will neeed the list of watches in `UnisonFile` to include extra information: what kind of watch expression is it? A test or a regular watch? We'll then need to make use of this information on `add` and `update`. And we might want to expose other commands for rerunning tests anyway. + +Aside: I kinda like the "trust but occasionally reverify" model for this kind of caching. So every once in a while, pick a random test to rerun and make sure it checks out. With statistics, over time, it becomes exceedingly likely that the cache is good and any somehow incorrect results will be caught. Pessimistically rerunning all the tests, all the time, is Right Out. :) diff --git a/unison-src/transcripts/project-outputs/docs/type-declarations.output.md b/unison-src/transcripts/project-outputs/docs/type-declarations.output.md new file mode 100644 index 0000000000..09ff26703a --- /dev/null +++ b/unison-src/transcripts/project-outputs/docs/type-declarations.output.md @@ -0,0 +1,150 @@ +draft draft draft + +# Type Declarations in Unison + +``` haskell +data DataDeclaration' v a = DataDeclaration { + annotation :: a, + bound :: [v], + constructors' :: [(a, v, AnnotatedType v a)] + -- isStructural :: IsStructural + -- isOpaque :: Set (AnnotatedTerm v a) +} deriving (Eq, Show, Functor) + +-- type IsStructural = Structural | Unique GUID +``` + +> There is some discussion history on this doc in the comment threads [here](https://github.com/unisonweb/unison/commit/bc65f460a7b6a6c0dec7f3028680d55f0372123e#comments) and [here](https://github.com/unisonweb/unison/commit/6be8cba7e7fde29cf87af7fb28f2b30185c40c89#commitcomment-33025457). + +## Structural Types + +> 👉 These got implemented - it's the default, so there's no `structural` keyword. + +Structural types are defined uniquely by their structure. Every constructor has a unique signature, which intrinsically defines the meaning of the constructor. For example, the following types are identical and interoperable: + +``` haskell +structural type Maybe a = Nothing | Just a +structural type Optional t = Some t | None +``` + +These definitions would also be identical and interoperable (although they maybe shouldn't be): + +``` haskell +structural type Validation e a = Success a | Failure e +structural type Either a b = Left a | Right b +``` + +It should be an error if two constructors of a structural type have the same signature, indicating that the semantics are defined outside of the structure. + +The identity of a structural type is determined by normalizing the constructor order by \ and then hashing their types. + +## Unique types + +> 👉 This got implemented - see [here](https://www.unison-lang.org/learn/language-reference/unique-types/). + +Unique types have extrinsic semantics, not completely defined by the constructor types. Their representation includes a GUID, along with the constructors. The constructors types need not be unique. The GUID is typically auto-generated, but can be specified as part of the type declaration, in order to use a textual representation to declare an identical type. + +``` haskell +unique type Day = Mon | Tue | Wed | ... + +unique[] +type Day = Mon | Tue | Wed | ... +``` + +Order of constructors having the same type is stable, but the relative constructor order of differently typed constructors is (currently) unspecified. + +## Opaque Types + +How do we support modularity? That is, how do we let people expose a 'public API' to their library, and avoid exposing the internals behind it, so that (a) you can keep your library's internal data invariants intact without having to explain them, (b) you're free to change the internals without breaking client code that uses the API, and (c) you can tame complexity in the overall system by decoupling client code from library code? + +The key thing is to control access to the introduction and elimination of data types: who is allowed to create, and to pattern-match on, a value of your type? Both of those necessarily expose the guts of the representation of the type. + +An opaque type has a structure and a block of terms that can inspect structure. The hash of those terms is part of the type ID. They have a flag in the decl so typechecker can prevent access. + +``` haskell +opaque type Socket = Socket Nat +opaque type Handle = Handle Text +``` + +Q: How do you declare a definition that can inspect two opaque types? +Q: How do *we* create and inspect Sockets? We don't want to create public accessors, but we do want some way for privileged code to construct those values. I guess it's straightforward for types with a single constructor, but we may end up needing some deterministic way of distinguishing the other constructors. + +For reference and comparison: https://docs.scala-lang.org/sips/opaque-types.html +Notes re Scala opaque types: + + - They are a type alias (no boxing) that is only equal for definitions inside a corresponding companion object/module. + - We (Unison) do need to "box" values within a constructor to give them a hash corresponding to their type identity. + +### Alternative take on opaque types + +The thread starting [here](https://unisonlanguage.slack.com/archives/CLKV43YE4/p1565135564409000) makes the case that it's not very 'open world' to force people to change your type's identity in order to add a function which is privileged - i.e. can create and pattern match on values of that type. + +An alternative would be to say that, in terms of type identity, opaque types work exactly like unique types. But that you can annotate terms as being a 'friend' of that type, and so allowed to create / pattern match. So maybe here's what a term looks like that's a friend of types Foo and Bar: + +``` haskell +friend[Foo, Bar] eg : Foo Bar +eg = Foo.Foo 1 "hi" (Bar.Bar 3.1) +-- syntax reminiscent of unique[#af361] +``` + +This annotation would be metadata attached to the term. You can get unison to list all the friends of a given type, in order to work out what the footprint of 'privileged' code is. + +### Private functions + +It's not quite true to say that controlling creation and pattern matching is enough for the three aspects of modularity mentioned above. What about internal library helper functions which could be called in a way that creates data that doesn't respect the invariants? Or that you might want to change or remove later? Or that are not at the same semantic level as your API? So maybe we'd want a `private[Foo]` annotation on terms, which both implies `friend[Foo]`, and can only be referenced from other `friend[Foo]` terms. + +## Combinations? + +*Structural + Unique:* No. + +*Structural + Opaque:* No. + +*Unique + Opaque:* Sure why not. + +(So note that Opaque implies Unique.) + +Example where you want Opaque without Unique: `SortedSet` -- the exposed methods define the semantics. Example where you want Unique + Opaque: `Socket`, `Handle` -- the exposed methods may necessarily dictate that the two types are not the same. + +## Misc scenarios / questions: + +I was just editing some Haskell code. + +``` haskell +-- InputPatterns accept some fixed number of Required arguments of various +-- types, followed by a variable number of a single type of argument. +data IsOptional + = Optional -- 0 or 1, at the end + | Required -- 1, at the start + | ZeroPlus -- 0 or more, at the end + | OnePlus -- 1 or more, at the end + deriving Show +``` + +I decided to move `Required` to the top for clarity since, as the comments state, InputPattern arg lists start with some number of `Required` arguments. + +``` haskell +data IsOptional + = Optional -- 0 or 1, at the end + | Required -- 1, at the start + | ZeroPlus -- 0 or more, at the end + | OnePlus -- 1 or more, at the end + deriving Show +``` + +I still want this to be the same type. None of the semantics have changed, I just reordered the constructors for readability. I don't think this would be possible with any of our current proposed type implementations. Yes, I could create a new unique type, and refactor everything to use that, but that strikes me as unappealing, especially from a code-sharing perspective. + +Thoughts? + + - @pchiusano - I'd say that "constructor display order" should be a bit of metadata that can be attached to a data declaration, and you should be able to edit this metadata somehow (perhaps by default, the `add` / `update` command can suggest "metadata edits" in reponse to this sort of thing). + +## Old stuff: Algebraic Types? + +Algebraic types are defined by their structure and a set of laws relating their fields. Note that the laws may involve more than one type. + +``` +algebraic Monoid a = Monoid { mempty : a, mappend : a -> a -> a } +where m a -> (mappend m) (mempty m) a == a + m a -> (mappend m) a (mempty m) == a + m a b c -> (mappend m) a ((mappend m) b c) == + (mappend m) ((mappend m) a b) c +``` diff --git a/unison-src/transcripts/propagate.md b/unison-src/transcripts/propagate.md deleted file mode 100644 index cc80ef885c..0000000000 --- a/unison-src/transcripts/propagate.md +++ /dev/null @@ -1,125 +0,0 @@ -# Propagating type edits - -```ucm:hide -.subpath.lib> builtins.merge -``` - -We introduce a type `Foo` with a function dependent `fooToInt`. - -```unison -unique type Foo = Foo - -fooToInt : Foo -> Int -fooToInt _ = +42 -``` - -And then we add it. - -```ucm -.subpath> add -.subpath> find.verbose -.subpath> view fooToInt -``` - -Then if we change the type `Foo`... - -```unison -unique type Foo = Foo | Bar -``` - -and update the codebase to use the new type `Foo`... - -```ucm -.subpath> update.old -``` - -... it should automatically propagate the type to `fooToInt`. - -```ucm -.subpath> view fooToInt -``` - -### Preserving user type variables - -We make a term that has a dependency on another term and also a non-redundant -user-provided type signature. - -```unison -preserve.someTerm : Optional foo -> Optional foo -preserve.someTerm x = x - -preserve.otherTerm : Optional baz -> Optional baz -preserve.otherTerm y = someTerm y -``` - -Add that to the codebase: - -```ucm -.subpath> add -``` - -Let's now edit the dependency: - -```unison -preserve.someTerm : Optional x -> Optional x -preserve.someTerm _ = None -``` - -Update... - -```ucm -.subpath> update.old -``` - -Now the type of `someTerm` should be `Optional x -> Optional x` and the -type of `otherTerm` should remain the same. - -```ucm -.subpath> view preserve.someTerm -.subpath> view preserve.otherTerm -``` - -### Propagation only applies to the local branch - -Cleaning up a bit... - -```ucm -.> delete.namespace subpath -.subpath.lib> builtins.merge -``` - -Now, we make two terms, where one depends on the other. - -```unison -one.someTerm : Optional foo -> Optional foo -one.someTerm x = x - -one.otherTerm : Optional baz -> Optional baz -one.otherTerm y = someTerm y -``` - -We'll make two copies of this namespace. - -```ucm -.subpath> add -.subpath> fork one two -``` - -Now let's edit one of the terms... - -```unison -someTerm : Optional x -> Optional x -someTerm _ = None -``` - -... in one of the namespaces... - -```ucm -.subpath.one> update.old -``` - -The other namespace should be left alone. - -```ucm -.subpath> view two.someTerm -``` diff --git a/unison-src/transcripts/propagate.output.md b/unison-src/transcripts/propagate.output.md deleted file mode 100644 index 5f0b72bb35..0000000000 --- a/unison-src/transcripts/propagate.output.md +++ /dev/null @@ -1,271 +0,0 @@ -# Propagating type edits - -We introduce a type `Foo` with a function dependent `fooToInt`. - -```unison -unique type Foo = Foo - -fooToInt : Foo -> Int -fooToInt _ = +42 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - fooToInt : Foo -> Int - -``` -And then we add it. - -```ucm -.subpath> add - - ⍟ I've added these definitions: - - type Foo - fooToInt : Foo -> Int - -.subpath> find.verbose - - 1. -- #uj8oalgadr2f52qloufah6t8vsvbc76oqijkotek87vooih7aqu44k20hrs34kartusapghp4jmfv6g1409peklv3r6a527qpk52soo - type Foo - - 2. -- #uj8oalgadr2f52qloufah6t8vsvbc76oqijkotek87vooih7aqu44k20hrs34kartusapghp4jmfv6g1409peklv3r6a527qpk52soo#0 - Foo.Foo : Foo - - 3. -- #j6hbm1gc2ak4f46b6705q90ld4bmhoi8etq2q45j081i9jgn95fvk3p6tjg67e7sm0021035i8qikmk4p6k845l5d00u26cos5731to - fooToInt : Foo -> Int - - - -.subpath> view fooToInt - - fooToInt : Foo -> Int - fooToInt _ = +42 - -``` -Then if we change the type `Foo`... - -```unison -unique type Foo = Foo | Bar -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -and update the codebase to use the new type `Foo`... - -```ucm -.subpath> update.old - - ⍟ I've updated these names to your new definition: - - type Foo - -``` -... it should automatically propagate the type to `fooToInt`. - -```ucm -.subpath> view fooToInt - - fooToInt : Foo -> Int - fooToInt _ = +42 - -``` -### Preserving user type variables - -We make a term that has a dependency on another term and also a non-redundant -user-provided type signature. - -```unison -preserve.someTerm : Optional foo -> Optional foo -preserve.someTerm x = x - -preserve.otherTerm : Optional baz -> Optional baz -preserve.otherTerm y = someTerm y -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - preserve.otherTerm : Optional baz -> Optional baz - preserve.someTerm : Optional foo -> Optional foo - -``` -Add that to the codebase: - -```ucm -.subpath> add - - ⍟ I've added these definitions: - - preserve.otherTerm : Optional baz -> Optional baz - preserve.someTerm : Optional foo -> Optional foo - -``` -Let's now edit the dependency: - -```unison -preserve.someTerm : Optional x -> Optional x -preserve.someTerm _ = None -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - preserve.someTerm : Optional x -> Optional x - -``` -Update... - -```ucm -.subpath> update.old - - ⍟ I've updated these names to your new definition: - - preserve.someTerm : Optional x -> Optional x - -``` -Now the type of `someTerm` should be `Optional x -> Optional x` and the -type of `otherTerm` should remain the same. - -```ucm -.subpath> view preserve.someTerm - - preserve.someTerm : Optional x -> Optional x - preserve.someTerm _ = None - -.subpath> view preserve.otherTerm - - preserve.otherTerm : Optional baz -> Optional baz - preserve.otherTerm y = someTerm y - -``` -### Propagation only applies to the local branch - -Cleaning up a bit... - -```ucm -.> delete.namespace subpath - - Done. - - ☝️ The namespace .subpath.lib is empty. - -.subpath.lib> builtins.merge - - Done. - -``` -Now, we make two terms, where one depends on the other. - -```unison -one.someTerm : Optional foo -> Optional foo -one.someTerm x = x - -one.otherTerm : Optional baz -> Optional baz -one.otherTerm y = someTerm y -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - one.otherTerm : Optional baz -> Optional baz - one.someTerm : Optional foo -> Optional foo - -``` -We'll make two copies of this namespace. - -```ucm -.subpath> add - - ⍟ I've added these definitions: - - one.otherTerm : Optional baz -> Optional baz - one.someTerm : Optional foo -> Optional foo - -.subpath> fork one two - - Done. - -``` -Now let's edit one of the terms... - -```unison -someTerm : Optional x -> Optional x -someTerm _ = None -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - someTerm : Optional x -> Optional x - -``` -... in one of the namespaces... - -```ucm -.subpath.one> update.old - - ⍟ I've updated these names to your new definition: - - someTerm : #nirp5os0q6 x -> #nirp5os0q6 x - -``` -The other namespace should be left alone. - -```ucm -.subpath> view two.someTerm - - two.someTerm : Optional foo -> Optional foo - two.someTerm x = x - -``` diff --git a/unison-src/transcripts/pull-errors.md b/unison-src/transcripts/pull-errors.md deleted file mode 100644 index 784221bb8e..0000000000 --- a/unison-src/transcripts/pull-errors.md +++ /dev/null @@ -1,6 +0,0 @@ -```ucm:error -test/main> pull @aryairani/test-almost-empty/main lib.base_latest -test/main> pull @aryairani/test-almost-empty/main a.b -test/main> pull @aryairani/test-almost-empty/main a -test/main> pull @aryairani/test-almost-empty/main .a -``` diff --git a/unison-src/transcripts/pull-errors.output.md b/unison-src/transcripts/pull-errors.output.md deleted file mode 100644 index a2894f6468..0000000000 --- a/unison-src/transcripts/pull-errors.output.md +++ /dev/null @@ -1,38 +0,0 @@ -```ucm -test/main> pull @aryairani/test-almost-empty/main lib.base_latest - - The use of `pull` to install libraries is now deprecated. - Going forward, you can use - `lib.install @aryairani/test-almost-empty/main`. - - Downloaded 2 entities. - - I installed @aryairani/test-almost-empty/main as - aryairani_test_almost_empty_main. - -test/main> pull @aryairani/test-almost-empty/main a.b - - I think you're wanting to merge - @aryairani/test-almost-empty/main into the a.b namespace, but - the `pull` command only supports merging into the top level of - a local project branch. - - Use `help pull` to see some examples. - -test/main> pull @aryairani/test-almost-empty/main a - - I think you're wanting to merge - @aryairani/test-almost-empty/main into the a branch, but it - doesn't exist. If you want, you can create it with - `branch.empty a`, and then `pull` again. - -test/main> pull @aryairani/test-almost-empty/main .a - - I think you're wanting to merge - @aryairani/test-almost-empty/main into the .a namespace, but - the `pull` command only supports merging into the top level of - a local project branch. - - Use `help pull` to see some examples. - -``` diff --git a/unison-src/transcripts/records.md b/unison-src/transcripts/records.md deleted file mode 100644 index 4a3d5d23d2..0000000000 --- a/unison-src/transcripts/records.md +++ /dev/null @@ -1,138 +0,0 @@ -Ensure that Records keep their syntax after being added to the codebase - -```ucm:hide -.> builtins.merge -.> load unison-src/transcripts-using-base/base.u -``` - -## Record with 1 field - -```unison:hide -unique type Record1 = { a : Text } -``` - -```ucm:hide -.> add -``` - -```ucm -.> view Record1 -``` - -## Record with 2 fields - -```unison:hide -unique type Record2 = { a : Text, b : Int } -``` - -```ucm:hide -.> add -``` - -```ucm -.> view Record2 -``` - -## Record with 3 fields - -```unison:hide -unique type Record3 = { a : Text, b : Int, c : Nat } -``` - -```ucm:hide -.> add -``` - -```ucm -.> view Record3 -``` - -## Record with many fields - -```unison:hide -unique type Record4 = - { a : Text - , b : Int - , c : Nat - , d : Bytes - , e : Text - , f : Nat - , g : [Nat] - } -``` - -```ucm:hide -.> add -``` - -```ucm -.> view Record4 -``` - -## Record with many many fields - -```unison:hide -unique type Record5 = { - zero : Nat, - one : [Nat], - two : [[Nat]], - three: [[[Nat]]], - four: [[[[Nat]]]], - five: [[[[[Nat]]]]], - six: [[[[[[Nat]]]]]], - seven: [[[[[[[Nat]]]]]]], - eight: [[[[[[[[Nat]]]]]]]], - nine: [[[[[[[[[Nat]]]]]]]]], - ten: [[[[[[[[[[Nat]]]]]]]]]], - eleven: [[[[[[[[[[[Nat]]]]]]]]]]], - twelve: [[[[[[[[[[[[Nat]]]]]]]]]]]], - thirteen: [[[[[[[[[[[[[Nat]]]]]]]]]]]]], - fourteen: [[[[[[[[[[[[[[Nat]]]]]]]]]]]]]], - fifteen: [[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]], - sixteen: [[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]], - seventeen: [[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]], - eighteen: [[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]], - nineteen: [[[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]]], - twenty: [[[[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]]]] -} -``` - -```ucm:hide -.> add -``` - -```ucm -.> view Record5 -``` - -## Record with user-defined type fields - -This record type has two fields whose types are user-defined (`Record4` and `UserType`). - -```unison:hide -unique type UserType = UserType Nat - -unique type RecordWithUserType = { a : Text, b : Record4, c : UserType } -``` - -```ucm:hide -.> add -``` - -If you `view` or `edit` it, it _should_ be treated as a record type, but it does not (which is a bug) - -```ucm -.> view RecordWithUserType -``` - - -## Syntax - -Trailing commas are allowed. - -```unison -unique type Record5 = - { a : Text, - b : Int, - } -``` diff --git a/unison-src/transcripts/records.output.md b/unison-src/transcripts/records.output.md deleted file mode 100644 index 064e18c690..0000000000 --- a/unison-src/transcripts/records.output.md +++ /dev/null @@ -1,177 +0,0 @@ -Ensure that Records keep their syntax after being added to the codebase - -## Record with 1 field - -```unison -unique type Record1 = { a : Text } -``` - -```ucm -.> view Record1 - - type Record1 = { a : Text } - -``` -## Record with 2 fields - -```unison -unique type Record2 = { a : Text, b : Int } -``` - -```ucm -.> view Record2 - - type Record2 = { a : Text, b : Int } - -``` -## Record with 3 fields - -```unison -unique type Record3 = { a : Text, b : Int, c : Nat } -``` - -```ucm -.> view Record3 - - type Record3 = { a : Text, b : Int, c : Nat } - -``` -## Record with many fields - -```unison -unique type Record4 = - { a : Text - , b : Int - , c : Nat - , d : Bytes - , e : Text - , f : Nat - , g : [Nat] - } -``` - -```ucm -.> view Record4 - - type Record4 - = { a : Text, - b : Int, - c : Nat, - d : Bytes, - e : Text, - f : Nat, - g : [Nat] } - -``` -## Record with many many fields - -```unison -unique type Record5 = { - zero : Nat, - one : [Nat], - two : [[Nat]], - three: [[[Nat]]], - four: [[[[Nat]]]], - five: [[[[[Nat]]]]], - six: [[[[[[Nat]]]]]], - seven: [[[[[[[Nat]]]]]]], - eight: [[[[[[[[Nat]]]]]]]], - nine: [[[[[[[[[Nat]]]]]]]]], - ten: [[[[[[[[[[Nat]]]]]]]]]], - eleven: [[[[[[[[[[[Nat]]]]]]]]]]], - twelve: [[[[[[[[[[[[Nat]]]]]]]]]]]], - thirteen: [[[[[[[[[[[[[Nat]]]]]]]]]]]]], - fourteen: [[[[[[[[[[[[[[Nat]]]]]]]]]]]]]], - fifteen: [[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]], - sixteen: [[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]], - seventeen: [[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]], - eighteen: [[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]], - nineteen: [[[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]]], - twenty: [[[[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]]]] -} -``` - -```ucm -.> view Record5 - - type Record5 - = { zero : Nat, - one : [Nat], - two : [[Nat]], - three : [[[Nat]]], - four : [[[[Nat]]]], - five : [[[[[Nat]]]]], - six : [[[[[[Nat]]]]]], - seven : [[[[[[[Nat]]]]]]], - eight : [[[[[[[[Nat]]]]]]]], - nine : [[[[[[[[[Nat]]]]]]]]], - ten : [[[[[[[[[[Nat]]]]]]]]]], - eleven : [[[[[[[[[[[Nat]]]]]]]]]]], - twelve : [[[[[[[[[[[[Nat]]]]]]]]]]]], - thirteen : [[[[[[[[[[[[[Nat]]]]]]]]]]]]], - fourteen : [[[[[[[[[[[[[[Nat]]]]]]]]]]]]]], - fifteen : [[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]], - sixteen : [[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]], - seventeen : [[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]], - eighteen : [[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]], - nineteen : [[[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]]], - twenty : [[[[[[[[[[[[[[[[[[[[Nat]]]]]]]]]]]]]]]]]]]] } - -``` -## Record with user-defined type fields - -This record type has two fields whose types are user-defined (`Record4` and `UserType`). - -```unison -unique type UserType = UserType Nat - -unique type RecordWithUserType = { a : Text, b : Record4, c : UserType } -``` - -If you `view` or `edit` it, it _should_ be treated as a record type, but it does not (which is a bug) - -```ucm -.> view RecordWithUserType - - type RecordWithUserType - = { a : Text, b : Record4, c : UserType } - -``` -## Syntax - -Trailing commas are allowed. - -```unison -unique type Record5 = - { a : Text, - b : Int, - } -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - Record5.a : Record5 -> Text - Record5.a.modify : (Text ->{g} Text) - -> Record5 - ->{g} Record5 - Record5.a.set : Text -> Record5 -> Record5 - Record5.b : Record5 -> Int - Record5.b.modify : (Int ->{g} Int) - -> Record5 - ->{g} Record5 - Record5.b.set : Int -> Record5 -> Record5 - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Record5 - -``` diff --git a/unison-src/transcripts/redundant.output.md b/unison-src/transcripts/redundant.output.md deleted file mode 100644 index b778734cd7..0000000000 --- a/unison-src/transcripts/redundant.output.md +++ /dev/null @@ -1,45 +0,0 @@ -The same kind of thing happens with `map`. Are we saying this is incorrect behaviour? - -```unison -map : (a -> b) -> [a] -> [b] -map f = cases - x +: xs -> f x +: map f xs - [] -> [] -``` - -```ucm - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - map : (a ->{𝕖} b) ->{𝕖} [a] ->{𝕖} [b] - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - map : (a ->{𝕖} b) ->{𝕖} [a] ->{𝕖} [b] - -.> view map - - map : (a -> b) -> [a] -> [b] - map f = cases - x +: xs -> - use builtin.List +: - f x +: map f xs - [] -> [] - -.> find map - - 1. map : (a ->{𝕖} b) ->{𝕖} [a] ->{𝕖} [b] - - -``` diff --git a/unison-src/transcripts/reflog.md b/unison-src/transcripts/reflog.md deleted file mode 100644 index 202dc50820..0000000000 --- a/unison-src/transcripts/reflog.md +++ /dev/null @@ -1,31 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -First we make two changes to the codebase, so that there's more than one line -for the `reflog` command to display: - -```unison -x = 1 -``` -```ucm -.> add -``` -```unison -y = 2 -``` -```ucm -.> add -.> view y -``` -```ucm -.> reflog -``` - -If we `reset-root` to its previous value, `y` disappears. -```ucm -.> reset-root 2 -``` -```ucm:error -.> view y -``` diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md deleted file mode 100644 index 96e68114ff..0000000000 --- a/unison-src/transcripts/reflog.output.md +++ /dev/null @@ -1,98 +0,0 @@ -First we make two changes to the codebase, so that there's more than one line -for the `reflog` command to display: - -```unison -x = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - x : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - x : Nat - -``` -```unison -y = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - y : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - y : Nat - -.> view y - - y : Nat - y = 2 - -``` -```ucm -.> reflog - - Here is a log of the root namespace hashes, starting with the - most recent, along with the command that got us there. Try: - - `fork 2 .old` - `fork #p611n6o5ve .old` to make an old namespace - accessible again, - - `reset-root #p611n6o5ve` to reset the root namespace and - its history to that of the - specified namespace. - - When Root Hash Action - 1. now #rmu2vgm86a add - 2. now #p611n6o5ve add - 3. now #4bigcpnl7t builtins.merge - 4. #sg60bvjo91 history starts here - - Tip: Use `diff.namespace 1 7` to compare namespaces between - two points in history. - -``` -If we `reset-root` to its previous value, `y` disappears. -```ucm -.> reset-root 2 - - Done. - -``` -```ucm -.> view y - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - y - -``` diff --git a/unison-src/transcripts/release-draft-command.md b/unison-src/transcripts/release-draft-command.md deleted file mode 100644 index bac0e991b0..0000000000 --- a/unison-src/transcripts/release-draft-command.md +++ /dev/null @@ -1,29 +0,0 @@ -The `release.draft` command drafts a release from the current branch. - -```ucm:hide -foo/main> builtins.merge -``` - -Some setup: - -```unison -someterm = 18 -``` - -```ucm -foo/main> add -``` - -Now, the `release.draft` demo: - -`release.draft` accepts a single semver argument. - -```ucm -foo/main> release.draft 1.2.3 -``` - -It's an error to try to create a `releases/drafts/x.y.z` branch that already exists. - -```ucm:error -foo/main> release.draft 1.2.3 -``` diff --git a/unison-src/transcripts/release-draft-command.output.md b/unison-src/transcripts/release-draft-command.output.md deleted file mode 100644 index 0eb667e870..0000000000 --- a/unison-src/transcripts/release-draft-command.output.md +++ /dev/null @@ -1,60 +0,0 @@ -The `release.draft` command drafts a release from the current branch. - -Some setup: - -```unison -someterm = 18 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - someterm : Nat - -``` -```ucm -foo/main> add - - ⍟ I've added these definitions: - - someterm : Nat - -``` -Now, the `release.draft` demo: - -`release.draft` accepts a single semver argument. - -```ucm -foo/main> release.draft 1.2.3 - - 😎 Great! I've created a draft release for you at - /releases/drafts/1.2.3. - - You can create a `ReleaseNotes : Doc` in this branch to give - an overview of the release. It'll automatically show up on - Unison Share when you publish. - - When ready to release 1.2.3 to the world, `push` the release - to Unison Share, navigate to the release, and click "Publish". - - Tip: if you get pulled away from drafting your release, you - can always get back to it with - `switch /releases/drafts/1.2.3`. - -``` -It's an error to try to create a `releases/drafts/x.y.z` branch that already exists. - -```ucm -foo/main> release.draft 1.2.3 - - foo/releases/drafts/1.2.3 already exists. You can switch to it - with `switch foo/releases/drafts/1.2.3`. - -``` diff --git a/unison-src/transcripts/reset.md b/unison-src/transcripts/reset.md deleted file mode 100644 index a01351233d..0000000000 --- a/unison-src/transcripts/reset.md +++ /dev/null @@ -1,78 +0,0 @@ -```ucm:hide -.> builtins.merge -``` - -# reset loose code -```unison -a = 5 -``` - -```ucm -.> add -.> history -.> reset 2 -.> history -``` - -```unison -foo.a = 5 -``` - -```ucm -.> add -.> ls foo -.> history -.> reset 1 foo -.> ls foo.foo -``` - -# reset branch - -```ucm -foo/main> history -``` - -```unison -a = 5 -``` - -```ucm -foo/main> add -foo/main> branch topic -foo/main> history -``` - -```unison -a = 3 -``` - -```ucm -foo/main> update -foo/main> reset /topic -foo/main> history -``` - -# ambiguous reset - -## ambiguous target -```unison -main.a = 3 -``` - -```ucm:error -foo/main> add -foo/main> history -foo/main> reset 2 main -``` - -## ambiguous hash - -```unison -main.a = 3 -``` - -```ucm:error -foo/main> switch /topic -foo/topic> add -foo/topic> reset main -``` diff --git a/unison-src/transcripts/reset.output.md b/unison-src/transcripts/reset.output.md deleted file mode 100644 index 344b2c16f9..0000000000 --- a/unison-src/transcripts/reset.output.md +++ /dev/null @@ -1,279 +0,0 @@ -# reset loose code -```unison -a = 5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - a : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - a : Nat - -.> history - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #d079vet1oj - - + Adds / updates: - - a - - □ 2. #4bigcpnl7t (start of history) - -.> reset 2 - - Done. - -.> history - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #4bigcpnl7t (start of history) - -``` -```unison -foo.a = 5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo.a : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - foo.a : Nat - -.> ls foo - - 1. a (Nat) - -.> history - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #tfg7r9359n - - + Adds / updates: - - foo.a - - □ 2. #4bigcpnl7t (start of history) - -.> reset 1 foo - - Done. - -.> ls foo.foo - - 1. a (Nat) - -``` -# reset branch - -```ucm -foo/main> history - - ☝️ The namespace is empty. - -``` -```unison -a = 5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - a : ##Nat - -``` -```ucm -foo/main> add - - ⍟ I've added these definitions: - - a : ##Nat - -foo/main> branch topic - - Done. I've created the topic branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic`. - -foo/main> history - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #5l94rduvel (start of history) - -``` -```unison -a = 3 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - a : ##Nat - -``` -```ucm -foo/main> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -foo/main> reset /topic - - Done. - -foo/main> history - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #5l94rduvel (start of history) - -``` -# ambiguous reset - -## ambiguous target -```unison -main.a = 3 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - main.a : ##Nat - -``` -```ucm -foo/main> add - - ⍟ I've added these definitions: - - main.a : ##Nat - -foo/main> history - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #0i64kpfccl - - + Adds / updates: - - main.a - - □ 2. #5l94rduvel (start of history) - -foo/main> reset 2 main - - I'm not sure if you wanted to reset the branch foo/main or the - namespace main in the current branch. Could you be more - specific? - - 1. /main (the branch main in the current project) - 2. main (the relative path main in the current branch) - - Tip: use `reset 1` or `reset 2` to - pick one of these. - -``` -## ambiguous hash - -```unison -main.a = 3 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked the definitions in scratch.u. This - file has been previously added to the codebase. - -``` -```ucm -foo/main> switch /topic - -foo/topic> add - - ⍟ I've added these definitions: - - main.a : ##Nat - -foo/topic> reset main - - I'm not sure if you wanted to reset to the branch foo/main or - to the namespace main in the current branch. Could you be more - specific? - - 1. /main (the branch main in the current project) - 2. main (the relative path main in the current branch) - - Tip: use `reset 1` or `reset 2` to pick one of these. - -``` diff --git a/unison-src/transcripts/resolution-failures.md b/unison-src/transcripts/resolution-failures.md deleted file mode 100644 index f6f0b0a4ad..0000000000 --- a/unison-src/transcripts/resolution-failures.md +++ /dev/null @@ -1,50 +0,0 @@ -# Resolution Errors - -This transcript tests the errors printed to the user when a name cannot be resolved. - -## Codebase Setup - -First we define differing types with the same name in different namespaces: - -```unison -unique type one.AmbiguousType = one.AmbiguousType -unique type two.AmbiguousType = two.AmbiguousType - -one.ambiguousTerm = "term one" -two.ambiguousTerm = "term two" -``` - -```ucm -.example.resolution_failures> add -``` - -## Tests - -Now we introduce code which isn't sufficiently qualified. -It is ambiguous which type from which namespace we mean. - -We expect the output to: - -1. Print all ambiguous usage sites separately -2. Print possible disambiguation suggestions for each unique ambiguity - -```unison:error --- We intentionally avoid using a constructor to ensure the constructor doesn't --- affect type resolution. -useAmbiguousType : AmbiguousType -> () -useAmbiguousType _ = () - -useUnknownType : UnknownType -> () -useUnknownType _ = () - --- Despite being a duplicate disambiguation, this should still be included in the annotations printout -separateAmbiguousTypeUsage : AmbiguousType -> () -separateAmbiguousTypeUsage _ = () -``` - -Currently, ambiguous terms are caught and handled by type directed name resolution, -but expect it to eventually be handled by the above machinery. - -```unison:error -useAmbiguousTerm = ambiguousTerm -``` diff --git a/unison-src/transcripts/resolution-failures.output.md b/unison-src/transcripts/resolution-failures.output.md deleted file mode 100644 index 352e2f1c20..0000000000 --- a/unison-src/transcripts/resolution-failures.output.md +++ /dev/null @@ -1,122 +0,0 @@ -# Resolution Errors - -This transcript tests the errors printed to the user when a name cannot be resolved. - -## Codebase Setup - -First we define differing types with the same name in different namespaces: - -```unison -unique type one.AmbiguousType = one.AmbiguousType -unique type two.AmbiguousType = two.AmbiguousType - -one.ambiguousTerm = "term one" -two.ambiguousTerm = "term two" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type one.AmbiguousType - type two.AmbiguousType - one.ambiguousTerm : ##Text - two.ambiguousTerm : ##Text - -``` -```ucm - ☝️ The namespace .example.resolution_failures is empty. - -.example.resolution_failures> add - - ⍟ I've added these definitions: - - type one.AmbiguousType - type two.AmbiguousType - one.ambiguousTerm : ##Text - two.ambiguousTerm : ##Text - -``` -## Tests - -Now we introduce code which isn't sufficiently qualified. -It is ambiguous which type from which namespace we mean. - -We expect the output to: - -1. Print all ambiguous usage sites separately -2. Print possible disambiguation suggestions for each unique ambiguity - -```unison --- We intentionally avoid using a constructor to ensure the constructor doesn't --- affect type resolution. -useAmbiguousType : AmbiguousType -> () -useAmbiguousType _ = () - -useUnknownType : UnknownType -> () -useUnknownType _ = () - --- Despite being a duplicate disambiguation, this should still be included in the annotations printout -separateAmbiguousTypeUsage : AmbiguousType -> () -separateAmbiguousTypeUsage _ = () -``` - -```ucm - - Loading changes detected in scratch.u. - - - ❓ - - I couldn't resolve any of these symbols: - - 3 | useAmbiguousType : AmbiguousType -> () - 4 | useAmbiguousType _ = () - 5 | - 6 | useUnknownType : UnknownType -> () - 7 | useUnknownType _ = () - 8 | - 9 | -- Despite being a duplicate disambiguation, this should still be included in the annotations printout - 10 | separateAmbiguousTypeUsage : AmbiguousType -> () - - - Symbol Suggestions - - AmbiguousType one.AmbiguousType - two.AmbiguousType - - UnknownType No matches - - -``` -Currently, ambiguous terms are caught and handled by type directed name resolution, -but expect it to eventually be handled by the above machinery. - -```unison -useAmbiguousTerm = ambiguousTerm -``` - -```ucm - - Loading changes detected in scratch.u. - - I couldn't figure out what ambiguousTerm refers to here: - - 1 | useAmbiguousTerm = ambiguousTerm - - The name ambiguousTerm is ambiguous. I couldn't narrow it down - by type, as any type would work here. - - I found some terms in scope that have matching names and - types. Maybe you meant one of these: - - one.ambiguousTerm : ##Text - two.ambiguousTerm : ##Text - -``` diff --git a/unison-src/transcripts/rsa.md b/unison-src/transcripts/rsa.md deleted file mode 100644 index 6b9ed33b53..0000000000 --- a/unison-src/transcripts/rsa.md +++ /dev/null @@ -1,37 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -```unison - -up = 0xs0123456789abcdef -down = 0xsfedcba9876543210 - --- | Generated with: --- openssl genrsa -out private_key.pem 1024 --- openssl rsa -in private_key.pem -outform DER | xxd -p -secret = 0xs30820276020100300d06092a864886f70d0101010500048202603082025c02010002818100a7104b2f20725896076e629ccedbcd6907b16694c6e3d8768b5e0e685670b49616e796c588e5aafb92ef986c1a42c021fed0bdc99212c969cdab98087a0ee4c2f4acd4b6049a87a96afc45668329a3cf21a86fb13b488bbe9fefa1cd5a459014f0d0101378e9661e11b73acf54c8a91141ac90309e7fb6ed69b4e63230ab291502030100010281807cdc23a4fc3619d93f8293b728af848d0c0fdd603269d5bd7b99f760a9c22065d08693dbdcddf1f5863306133d694819e04d789aef4e95343b601507b8d9eac4492e6d7031b035c5d84eceaa9686b292712632d33b3303af84314d7920bc3d45f90d7818fc2587b129196d378ee4ed3e6b8d9010d504bb6470ff53e7c5fb17a1024100d67cbcf113d24325fcef12a778dc47c7060055290b68287649ef092558daccb61c4e7bc290740b75a29d4356dcbd66d18b0860dbff394cc8ff3d94d57617adbd024100c765d8261dd3d8e0d3caf11ab7b212eed181354215687ca6387283e4f0be16e79c8f298be0a70c7734dea78ea65128517d693cabfa4c0ff5328f2abb85d2023902403ca41dc347285e65c22251b2d9bfe5e7463217e1b7e0e5f7b3a58a7f6da4c6d60220ca6ad2ee8c42e10bf77afa83ee2af6551315800e52404db1ba7fb398b43d02410084877d85c0177933ddb12a554eb8edfa8b872c85d2c2d2ee8be019280696e19469ab81bab5c371f69d4e4be1f54b45d7fbda017870f1333e0eafb78051ee8689024061f694c12e934c44b7734f62d1b2a3d3624a4980e1b8e066d78dbabd2436654fbb9d9701425900daaafa1e031310e8a580520bb9e1c1288c669fce252bad1e65 - --- | Generated with: --- openssl rsa -in private_key.pem -outform DER -pubout | xxd -p -publicKey = 0xs30819f300d06092a864886f70d010101050003818d0030818902818100a7104b2f20725896076e629ccedbcd6907b16694c6e3d8768b5e0e685670b49616e796c588e5aafb92ef986c1a42c021fed0bdc99212c969cdab98087a0ee4c2f4acd4b6049a87a96afc45668329a3cf21a86fb13b488bbe9fefa1cd5a459014f0d0101378e9661e11b73acf54c8a91141ac90309e7fb6ed69b4e63230ab29150203010001 - -incorrectPublicKey = 0xs30819f300d06092a864886f70d010101050003818d0030818902818100a7104b2f20725896076e629ccedbcd6907b16694c6e3d8768b5e0e685670b49616e796c588e5aafb92ef986c1a42c021fed0bdc99212c969cdab98087a0ee4c2f4acd4b6049a87a96afc45668329a3cf21a86fb13b488bbe9fefa1cd5a459014f0d0101378e9661e11b73acf54c8a91141ac90309e7fb6ed69b4e63230ab29150203010002 - -message = up ++ down ++ up ++ down ++ down ++ up ++ down ++ up - -signature = crypto.Rsa.sign.impl secret message - -sigOkay = match signature with - Left err -> Left err - Right sg -> crypto.Rsa.verify.impl publicKey message sg - -sigKo = match signature with - Left err -> Left err - Right sg -> crypto.Rsa.verify.impl incorrectPublicKey message sg - -> signature -> sigOkay -> sigKo -``` diff --git a/unison-src/transcripts/rsa.output.md b/unison-src/transcripts/rsa.output.md deleted file mode 100644 index b81a16becc..0000000000 --- a/unison-src/transcripts/rsa.output.md +++ /dev/null @@ -1,70 +0,0 @@ - -```unison -up = 0xs0123456789abcdef -down = 0xsfedcba9876543210 - --- | Generated with: --- openssl genrsa -out private_key.pem 1024 --- openssl rsa -in private_key.pem -outform DER | xxd -p -secret = 0xs30820276020100300d06092a864886f70d0101010500048202603082025c02010002818100a7104b2f20725896076e629ccedbcd6907b16694c6e3d8768b5e0e685670b49616e796c588e5aafb92ef986c1a42c021fed0bdc99212c969cdab98087a0ee4c2f4acd4b6049a87a96afc45668329a3cf21a86fb13b488bbe9fefa1cd5a459014f0d0101378e9661e11b73acf54c8a91141ac90309e7fb6ed69b4e63230ab291502030100010281807cdc23a4fc3619d93f8293b728af848d0c0fdd603269d5bd7b99f760a9c22065d08693dbdcddf1f5863306133d694819e04d789aef4e95343b601507b8d9eac4492e6d7031b035c5d84eceaa9686b292712632d33b3303af84314d7920bc3d45f90d7818fc2587b129196d378ee4ed3e6b8d9010d504bb6470ff53e7c5fb17a1024100d67cbcf113d24325fcef12a778dc47c7060055290b68287649ef092558daccb61c4e7bc290740b75a29d4356dcbd66d18b0860dbff394cc8ff3d94d57617adbd024100c765d8261dd3d8e0d3caf11ab7b212eed181354215687ca6387283e4f0be16e79c8f298be0a70c7734dea78ea65128517d693cabfa4c0ff5328f2abb85d2023902403ca41dc347285e65c22251b2d9bfe5e7463217e1b7e0e5f7b3a58a7f6da4c6d60220ca6ad2ee8c42e10bf77afa83ee2af6551315800e52404db1ba7fb398b43d02410084877d85c0177933ddb12a554eb8edfa8b872c85d2c2d2ee8be019280696e19469ab81bab5c371f69d4e4be1f54b45d7fbda017870f1333e0eafb78051ee8689024061f694c12e934c44b7734f62d1b2a3d3624a4980e1b8e066d78dbabd2436654fbb9d9701425900daaafa1e031310e8a580520bb9e1c1288c669fce252bad1e65 - --- | Generated with: --- openssl rsa -in private_key.pem -outform DER -pubout | xxd -p -publicKey = 0xs30819f300d06092a864886f70d010101050003818d0030818902818100a7104b2f20725896076e629ccedbcd6907b16694c6e3d8768b5e0e685670b49616e796c588e5aafb92ef986c1a42c021fed0bdc99212c969cdab98087a0ee4c2f4acd4b6049a87a96afc45668329a3cf21a86fb13b488bbe9fefa1cd5a459014f0d0101378e9661e11b73acf54c8a91141ac90309e7fb6ed69b4e63230ab29150203010001 - -incorrectPublicKey = 0xs30819f300d06092a864886f70d010101050003818d0030818902818100a7104b2f20725896076e629ccedbcd6907b16694c6e3d8768b5e0e685670b49616e796c588e5aafb92ef986c1a42c021fed0bdc99212c969cdab98087a0ee4c2f4acd4b6049a87a96afc45668329a3cf21a86fb13b488bbe9fefa1cd5a459014f0d0101378e9661e11b73acf54c8a91141ac90309e7fb6ed69b4e63230ab29150203010002 - -message = up ++ down ++ up ++ down ++ down ++ up ++ down ++ up - -signature = crypto.Rsa.sign.impl secret message - -sigOkay = match signature with - Left err -> Left err - Right sg -> crypto.Rsa.verify.impl publicKey message sg - -sigKo = match signature with - Left err -> Left err - Right sg -> crypto.Rsa.verify.impl incorrectPublicKey message sg - -> signature -> sigOkay -> sigKo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - down : Bytes - incorrectPublicKey : Bytes - message : Bytes - publicKey : Bytes - secret : Bytes - sigKo : Either Failure Boolean - sigOkay : Either Failure Boolean - signature : Either Failure Bytes - up : Bytes - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 27 | > signature - ⧩ - Right - 0xs84b02b6bb0e1196b65378cb12b727f7b4b38e5979f0632e8a51cfab088827f6d3da4221788029f75a0a5f4d740372cfa590462888a1189bbd9de9b084f26116640e611af5a1a17229beec7fb2570887181bbdced8f0ebfec6cad6bdd318a616ba4f01c90e1436efe44b18417d18ce712a0763be834f8c76e0c39b2119b061373 - - 28 | > sigOkay - ⧩ - Right true - - 29 | > sigKo - ⧩ - Right false - -``` diff --git a/unison-src/transcripts/scope-ref.md b/unison-src/transcripts/scope-ref.md deleted file mode 100644 index 67fcbc336b..0000000000 --- a/unison-src/transcripts/scope-ref.md +++ /dev/null @@ -1,19 +0,0 @@ - -A short script to test mutable references with local scope. - -```ucm:hide -.> builtins.merge -``` - -```unison -test = Scope.run 'let - r = Scope.ref 0 - Ref.write r 1 - i = Ref.read r - Ref.write r 2 - j = Ref.read r - Ref.write r 5 - (i, j, Ref.read r) - -> test -``` diff --git a/unison-src/transcripts/scope-ref.output.md b/unison-src/transcripts/scope-ref.output.md deleted file mode 100644 index ea44a79469..0000000000 --- a/unison-src/transcripts/scope-ref.output.md +++ /dev/null @@ -1,36 +0,0 @@ - -A short script to test mutable references with local scope. - -```unison -test = Scope.run 'let - r = Scope.ref 0 - Ref.write r 1 - i = Ref.read r - Ref.write r 2 - j = Ref.read r - Ref.write r 5 - (i, j, Ref.read r) - -> test -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - test : (Nat, Nat, Nat) - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 10 | > test - ⧩ - (1, 2, 5) - -``` diff --git a/unison-src/transcripts/squash.md b/unison-src/transcripts/squash.md deleted file mode 100644 index f3b010944a..0000000000 --- a/unison-src/transcripts/squash.md +++ /dev/null @@ -1,157 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -# Squash merges - -`squash src dest` merges can be used to merge from `src` to `dest`, discarding the history of `src`. It's useful when the source namespace history is irrelevant or has a bunch of churn you wish to discard. Often when merging small pull requests, you'll use a squash merge. - -Let's look at some examples. We'll start with a namespace with just the builtins. Let's take a look at the hash of this namespace: - -```ucm -.> history builtin -.> fork builtin builtin2 -``` - -(We make a copy of `builtin` for use later in this transcript.) - -Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, then rename it back. Notice this produces multiple entries in the history: - -```ucm -.> fork builtin mybuiltin -.mybuiltin> rename.term Nat.+ Nat.frobnicate -.mybuiltin> rename.term Nat.frobnicate Nat.+ -.mybuiltin> history -``` - -If we merge that back into `builtin`, we get that same chain of history: - -```ucm -.> merge.old mybuiltin builtin -.> history builtin -``` - -Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: - -```ucm -.> merge.old.squash mybuiltin builtin2 -.> history builtin2 -``` - -The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. - -## Another example - -Let's look at a more interesting example, where the two namespaces have diverged a bit. Here's our starting namespace: - -```unison:hide -x = 1 -``` - -```ucm -.trunk> add -.> fork trunk alice -.> fork trunk bob -``` - -Alice now does some hacking: - -```unison:hide -radNumber = 348 -bodaciousNumero = 2394 -neatoFun x = x -``` - -```ucm -.alice> add -.alice> rename.term radNumber superRadNumber -.alice> rename.term neatoFun productionReadyId -``` - -Meanwhile, Bob does his own hacking: - -```unison:hide -whatIsLove = "?" -babyDon'tHurtMe = ".. Don't hurt me..." -no more = no more -``` - -```ucm -.bob> add -``` - -At this point, Alice and Bob both have some history beyond what's in trunk: - -```ucm -.> history trunk -.> history alice -.> history bob -``` - -Alice then squash merges into `trunk`, as does Bob. It's as if Alice and Bob both made their changes in one single commit. - -```ucm -.> merge.old.squash alice trunk -.> history trunk -.> merge.old.squash bob trunk -.> history trunk -``` - -Since squash merges don't produce any merge nodes, we can `undo` a couple times to get back to our starting state: - -```ucm -.> undo -.> undo -.> history trunk -``` - -This time, we'll first squash Alice and Bob's changes together before squashing their combined changes into `trunk`. The resulting `trunk` will have just a single entry in it, combining both Alice and Bob's changes: - -```ucm -.> merge.old.squash alice bob -.> merge.old.squash bob trunk -.> history trunk -``` - -So, there you have it. With squashing, you can control the granularity of your history. - -## Throwing out all history - -Another thing we can do is `squash` into an empty namespace. This effectively makes a copy of the namespace, but without any of its history: - -```ucm -.> merge.old.squash alice nohistoryalice -.> history nohistoryalice -``` - -There's nothing really special here, `squash src dest` discards `src` history that comes after the LCA of `src` and `dest`, it's just that in the case of an empty namespace, that LCA is the beginning of time (the empty namespace), so all the history of `src` is discarded. - -## Checking for handling of deletes - -This checks to see that squashing correctly preserves deletions: - -```ucm -.delete> builtins.merge -.delete> fork builtin builtin2 -.delete> delete.term.verbose builtin2.Nat.+ -.delete> delete.term.verbose builtin2.Nat.* -.delete> merge.old.squash builtin2 builtin -.delete> history builtin -``` - -Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. - -Just confirming that those two definitions are in fact removed: - -```ucm:error -.delete> view .delete.builtin.Nat.+ -``` - -```ucm:error -.delete> view .delete.builtin.Nat.* -``` - -## Caveats - -If you `squash mystuff trunk`, you're discarding any history of `mystuff` and just cons'ing onto the history of `trunk`. Thus, don't expect to be able to `merge trunk mystuff` later and get great results. Squashing should only be used when you don't care about the history (and you know others haven't pulled and built on your line of history being discarded, so they don't care about the history either). diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md deleted file mode 100644 index 3698fdfe6a..0000000000 --- a/unison-src/transcripts/squash.output.md +++ /dev/null @@ -1,529 +0,0 @@ - -# Squash merges - -`squash src dest` merges can be used to merge from `src` to `dest`, discarding the history of `src`. It's useful when the source namespace history is irrelevant or has a bunch of churn you wish to discard. Often when merging small pull requests, you'll use a squash merge. - -Let's look at some examples. We'll start with a namespace with just the builtins. Let's take a look at the hash of this namespace: - -```ucm -.> history builtin - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #i3vp9o9btm (start of history) - -.> fork builtin builtin2 - - Done. - -``` -(We make a copy of `builtin` for use later in this transcript.) - -Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, then rename it back. Notice this produces multiple entries in the history: - -```ucm -.> fork builtin mybuiltin - - Done. - -.mybuiltin> rename.term Nat.+ Nat.frobnicate - - Done. - -.mybuiltin> rename.term Nat.frobnicate Nat.+ - - Done. - -.mybuiltin> history - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #tpkjb488ei - - > Moves: - - Original name New name - Nat.frobnicate Nat.+ - - ⊙ 2. #334ak3epqt - - > Moves: - - Original name New name - Nat.+ Nat.frobnicate - - □ 3. #i3vp9o9btm (start of history) - -``` -If we merge that back into `builtin`, we get that same chain of history: - -```ucm -.> merge.old mybuiltin builtin - - Nothing changed as a result of the merge. - - Applying changes from patch... - -.> history builtin - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #tpkjb488ei - - > Moves: - - Original name New name - Nat.frobnicate Nat.+ - - ⊙ 2. #334ak3epqt - - > Moves: - - Original name New name - Nat.+ Nat.frobnicate - - □ 3. #i3vp9o9btm (start of history) - -``` -Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: - -```ucm -.> merge.old.squash mybuiltin builtin2 - - Nothing changed as a result of the merge. - - 😶 - - builtin2 was already up-to-date with mybuiltin. - -.> history builtin2 - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #i3vp9o9btm (start of history) - -``` -The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. - -## Another example - -Let's look at a more interesting example, where the two namespaces have diverged a bit. Here's our starting namespace: - -```unison -x = 1 -``` - -```ucm - ☝️ The namespace .trunk is empty. - -.trunk> add - - ⍟ I've added these definitions: - - x : ##Nat - -.> fork trunk alice - - Done. - -.> fork trunk bob - - Done. - -``` -Alice now does some hacking: - -```unison -radNumber = 348 -bodaciousNumero = 2394 -neatoFun x = x -``` - -```ucm -.alice> add - - ⍟ I've added these definitions: - - bodaciousNumero : ##Nat - neatoFun : x -> x - radNumber : ##Nat - -.alice> rename.term radNumber superRadNumber - - Done. - -.alice> rename.term neatoFun productionReadyId - - Done. - -``` -Meanwhile, Bob does his own hacking: - -```unison -whatIsLove = "?" -babyDon'tHurtMe = ".. Don't hurt me..." -no more = no more -``` - -```ucm -.bob> add - - ⍟ I've added these definitions: - - babyDon'tHurtMe : ##Text - no : more -> r - whatIsLove : ##Text - -``` -At this point, Alice and Bob both have some history beyond what's in trunk: - -```ucm -.> history trunk - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #i52j9fd57b (start of history) - -.> history alice - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #e9jd55555o - - > Moves: - - Original name New name - neatoFun productionReadyId - - ⊙ 2. #l5ocoo2eac - - > Moves: - - Original name New name - radNumber superRadNumber - - ⊙ 3. #i1vq05628n - - + Adds / updates: - - bodaciousNumero neatoFun radNumber - - □ 4. #i52j9fd57b (start of history) - -.> history bob - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #brr4400742 - - + Adds / updates: - - babyDon'tHurtMe no whatIsLove - - □ 2. #i52j9fd57b (start of history) - -``` -Alice then squash merges into `trunk`, as does Bob. It's as if Alice and Bob both made their changes in one single commit. - -```ucm -.> merge.old.squash alice trunk - - Here's what's changed in trunk after the merge: - - Added definitions: - - 1. bodaciousNumero : Nat - 2. productionReadyId : x -> x - 3. superRadNumber : Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.> history trunk - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #f9lvm9gd2k - - + Adds / updates: - - bodaciousNumero productionReadyId superRadNumber - - □ 2. #i52j9fd57b (start of history) - -.> merge.old.squash bob trunk - - Here's what's changed in trunk after the merge: - - Added definitions: - - 1. babyDon'tHurtMe : Text - 2. no : more -> r - 3. whatIsLove : Text - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.> history trunk - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #dbp78ts6q3 - - + Adds / updates: - - babyDon'tHurtMe no whatIsLove - - ⊙ 2. #f9lvm9gd2k - - + Adds / updates: - - bodaciousNumero productionReadyId superRadNumber - - □ 3. #i52j9fd57b (start of history) - -``` -Since squash merges don't produce any merge nodes, we can `undo` a couple times to get back to our starting state: - -```ucm -.> undo - - Here are the changes I undid - - Name changes: - - Original Changes - 1. bob.babyDon'tHurtMe 2. trunk.babyDon'tHurtMe (added) - - 3. bob.no 4. trunk.no (added) - - 5. bob.whatIsLove 6. trunk.whatIsLove (added) - -.> undo - - Here are the changes I undid - - Name changes: - - Original Changes - 1. alice.bodaciousNumero 2. trunk.bodaciousNumero (added) - - 3. alice.productionReadyId 4. trunk.productionReadyId (added) - - 5. alice.superRadNumber 6. trunk.superRadNumber (added) - -.> history trunk - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #i52j9fd57b (start of history) - -``` -This time, we'll first squash Alice and Bob's changes together before squashing their combined changes into `trunk`. The resulting `trunk` will have just a single entry in it, combining both Alice and Bob's changes: - -```ucm -.> merge.old.squash alice bob - - Here's what's changed in bob after the merge: - - Added definitions: - - 1. bodaciousNumero : Nat - 2. productionReadyId : x -> x - 3. superRadNumber : Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.> merge.old.squash bob trunk - - Here's what's changed in trunk after the merge: - - Added definitions: - - 1. babyDon'tHurtMe : Text - 2. bodaciousNumero : Nat - 3. no : more -> r - 4. productionReadyId : x -> x - 5. superRadNumber : Nat - 6. whatIsLove : Text - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.> history trunk - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #qtotqgds4i - - + Adds / updates: - - babyDon'tHurtMe bodaciousNumero no productionReadyId - superRadNumber whatIsLove - - □ 2. #i52j9fd57b (start of history) - -``` -So, there you have it. With squashing, you can control the granularity of your history. - -## Throwing out all history - -Another thing we can do is `squash` into an empty namespace. This effectively makes a copy of the namespace, but without any of its history: - -```ucm -.> merge.old.squash alice nohistoryalice - - Here's what's changed in nohistoryalice after the merge: - - Added definitions: - - 1. bodaciousNumero : Nat - 2. productionReadyId : x -> x - 3. superRadNumber : Nat - 4. x : Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.> history nohistoryalice - - Note: The most recent namespace hash is immediately below this - message. - - - - □ 1. #1d9haupn3d (start of history) - -``` -There's nothing really special here, `squash src dest` discards `src` history that comes after the LCA of `src` and `dest`, it's just that in the case of an empty namespace, that LCA is the beginning of time (the empty namespace), so all the history of `src` is discarded. - -## Checking for handling of deletes - -This checks to see that squashing correctly preserves deletions: - -```ucm - ☝️ The namespace .delete is empty. - -.delete> builtins.merge - - Done. - -.delete> fork builtin builtin2 - - Done. - -.delete> delete.term.verbose builtin2.Nat.+ - - Name changes: - - Original Changes - 1. builtin.Nat.+ ┐ 2. builtin2.Nat.+ (removed) - 3. builtin2.Nat.+ ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -.delete> delete.term.verbose builtin2.Nat.* - - Name changes: - - Original Changes - 1. builtin.Nat.* ┐ 2. builtin2.Nat.* (removed) - 3. builtin2.Nat.* ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -.delete> merge.old.squash builtin2 builtin - - Here's what's changed in builtin after the merge: - - Removed definitions: - - 1. Nat.* : Nat -> Nat -> Nat - 2. Nat.+ : Nat -> Nat -> Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.delete> history builtin - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #dv00hf6vmg - - - Deletes: - - Nat.* Nat.+ - - □ 2. #i3vp9o9btm (start of history) - -``` -Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. - -Just confirming that those two definitions are in fact removed: - -```ucm -.delete> view .delete.builtin.Nat.+ - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - .delete.builtin.Nat.+ - -``` -```ucm -.delete> view .delete.builtin.Nat.* - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - .delete.builtin.Nat.* - -``` -## Caveats - -If you `squash mystuff trunk`, you're discarding any history of `mystuff` and just cons'ing onto the history of `trunk`. Thus, don't expect to be able to `merge trunk mystuff later and get great results. Squashing should only be used when you don't care about the history (and you know others haven't pulled and built on your line of history being discarded, so they don't care about the history either). diff --git a/unison-src/transcripts/suffixes.md b/unison-src/transcripts/suffixes.md deleted file mode 100644 index 3a4c47933f..0000000000 --- a/unison-src/transcripts/suffixes.md +++ /dev/null @@ -1,107 +0,0 @@ -# Suffix-based resolution of names - -```ucm:hide -.> builtins.merge -``` - -Any unique name suffix can be used to refer to a definition. For instance: - -```unison:hide --- No imports needed even though FQN is `builtin.{Int,Nat}` -foo.bar.a : Int -foo.bar.a = +99 - --- No imports needed even though FQN is `builtin.Optional.{None,Some}` -optional.isNone = cases - None -> true - Some _ -> false -``` - -This also affects commands like find. Notice lack of qualified names in output: - -```ucm -.> add -.> find take -``` - -The `view` and `display` commands also benefit from this: - -```ucm -.> view List.drop -.> display bar.a -``` - -In the signature, we don't see `base.Nat`, just `Nat`. The full declaration name is still shown for each search result though. - -Type-based search also benefits from this, we can just say `Nat` rather than `.base.Nat`: - -```ucm -.> find : Nat -> [a] -> [a] -``` - -## Preferring names not in `lib.*.lib.*` - -Suffix-based resolution prefers names that are not in an indirect dependency. - -```unison -cool.abra.cadabra = "my project" -lib.distributed.abra.cadabra = "direct dependency 1" -lib.distributed.baz.qux = "direct dependency 2" -lib.distributed.lib.baz.qux = "indirect dependency" -``` - -```ucm -.> add -``` - -```unison:error -> abra.cadabra -``` - -```unison -> baz.qux -``` - -```ucm -.> view abra.cadabra -.> view baz.qux -``` - -Note that we can always still view indirect dependencies by using more name segments: - -```ucm -.> view distributed.abra.cadabra -.> names distributed.lib.baz.qux -``` - -## Corner cases - -If a definition is given in a scratch file, its suffixes shadow existing definitions that exist in the codebase with the same suffixes. For example: - -```unison:hide -unique type A = Thing1 Nat | thing2 Nat - -foo.a = 23 -bar = 100 -``` - -```ucm -.> add -``` - -```unison -unique type B = Thing1 Text | thing2 Text | Thing3 Text - -zoink.a = "hi" - --- verifying that the `a` here references `zoink.a` -foo.baz.qux.bar : Text -foo.baz.qux.bar = a - --- verifying that the `bar` is resolving to `foo.baz.qux.bar` --- and that `Thing1` references `B.Thing1` from the current file -fn = cases - Thing1 msg -> msg Text.++ bar - thing2 msg -> msg Text.++ bar - _ -> todo "hmm" -``` diff --git a/unison-src/transcripts/suffixes.output.md b/unison-src/transcripts/suffixes.output.md deleted file mode 100644 index 21aeafa44e..0000000000 --- a/unison-src/transcripts/suffixes.output.md +++ /dev/null @@ -1,225 +0,0 @@ -# Suffix-based resolution of names - -Any unique name suffix can be used to refer to a definition. For instance: - -```unison --- No imports needed even though FQN is `builtin.{Int,Nat}` -foo.bar.a : Int -foo.bar.a = +99 - --- No imports needed even though FQN is `builtin.Optional.{None,Some}` -optional.isNone = cases - None -> true - Some _ -> false -``` - -This also affects commands like find. Notice lack of qualified names in output: - -```ucm -.> add - - ⍟ I've added these definitions: - - foo.bar.a : Int - optional.isNone : Optional a -> Boolean - -.> find take - - 1. builtin.Bytes.take : Nat -> Bytes -> Bytes - 2. builtin.List.take : Nat -> [a] -> [a] - 3. builtin.Text.take : Nat -> Text -> Text - 4. builtin.io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 5. builtin.io2.MVar.tryTake : MVar a ->{IO} Optional a - - -``` -The `view` and `display` commands also benefit from this: - -```ucm -.> view List.drop - - builtin builtin.List.drop : builtin.Nat -> [a] -> [a] - -.> display bar.a - - +99 - -``` -In the signature, we don't see `base.Nat`, just `Nat`. The full declaration name is still shown for each search result though. - -Type-based search also benefits from this, we can just say `Nat` rather than `.base.Nat`: - -```ucm -.> find : Nat -> [a] -> [a] - - 1. builtin.List.drop : Nat -> [a] -> [a] - 2. builtin.List.take : Nat -> [a] -> [a] - - -``` -## Preferring names not in `lib.*.lib.*` - -Suffix-based resolution prefers names that are not in an indirect dependency. - -```unison -cool.abra.cadabra = "my project" -lib.distributed.abra.cadabra = "direct dependency 1" -lib.distributed.baz.qux = "direct dependency 2" -lib.distributed.lib.baz.qux = "indirect dependency" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - cool.abra.cadabra : Text - lib.distributed.abra.cadabra : Text - lib.distributed.baz.qux : Text - lib.distributed.lib.baz.qux : Text - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - cool.abra.cadabra : Text - lib.distributed.abra.cadabra : Text - lib.distributed.baz.qux : Text - lib.distributed.lib.baz.qux : Text - -``` -```unison -> abra.cadabra -``` - -```ucm - - Loading changes detected in scratch.u. - - I couldn't figure out what abra.cadabra refers to here: - - 1 | > abra.cadabra - - The name abra.cadabra is ambiguous. I couldn't narrow it down - by type, as any type would work here. - - I found some terms in scope that have matching names and - types. Maybe you meant one of these: - - cool.abra.cadabra : Text - distributed.abra.cadabra : Text - -``` -```unison -> baz.qux -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > baz.qux - ⧩ - "direct dependency 2" - -``` -```ucm -.> view abra.cadabra - - cool.abra.cadabra : Text - cool.abra.cadabra = "my project" - - lib.distributed.abra.cadabra : Text - lib.distributed.abra.cadabra = "direct dependency 1" - -.> view baz.qux - - lib.distributed.baz.qux : Text - lib.distributed.baz.qux = "direct dependency 2" - -``` -Note that we can always still view indirect dependencies by using more name segments: - -```ucm -.> view distributed.abra.cadabra - - lib.distributed.abra.cadabra : Text - lib.distributed.abra.cadabra = "direct dependency 1" - -.> names distributed.lib.baz.qux - - Term - Hash: #nhup096n2s - Names: lib.distributed.lib.baz.qux - - Tip: Use `names.global` to see more results. - -``` -## Corner cases - -If a definition is given in a scratch file, its suffixes shadow existing definitions that exist in the codebase with the same suffixes. For example: - -```unison -unique type A = Thing1 Nat | thing2 Nat - -foo.a = 23 -bar = 100 -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - type A - bar : Nat - foo.a : Nat - -``` -```unison -unique type B = Thing1 Text | thing2 Text | Thing3 Text - -zoink.a = "hi" - --- verifying that the `a` here references `zoink.a` -foo.baz.qux.bar : Text -foo.baz.qux.bar = a - --- verifying that the `bar` is resolving to `foo.baz.qux.bar` --- and that `Thing1` references `B.Thing1` from the current file -fn = cases - Thing1 msg -> msg Text.++ bar - thing2 msg -> msg Text.++ bar - _ -> todo "hmm" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type B - fn : B -> Text - foo.baz.qux.bar : Text - zoink.a : Text - -``` diff --git a/unison-src/transcripts/sum-type-update-conflicts.md b/unison-src/transcripts/sum-type-update-conflicts.md deleted file mode 100644 index ce29931852..0000000000 --- a/unison-src/transcripts/sum-type-update-conflicts.md +++ /dev/null @@ -1,36 +0,0 @@ -# Regression test for updates which conflict with an existing data constructor - -https://github.com/unisonweb/unison/issues/2786 - -```ucm:hide -.ns> builtins.merge -``` - -First we add a sum-type to the codebase. - -```unison -structural type X = x -``` - -```ucm -.ns> add -``` - -Now we update the type, changing the name of the constructors, _but_, we simultaneously -add a new top-level term with the same name as the old constructor. - -```unison -structural type X = y | z - -X.x : Text -X.x = "some text that's not in the codebase" - -dependsOnX = Text.size X.x -``` - -This update should succeed since the conflicted constructor -is removed in the same update that the new term is being added. - -```ucm -.ns> update.old -``` diff --git a/unison-src/transcripts/sum-type-update-conflicts.output.md b/unison-src/transcripts/sum-type-update-conflicts.output.md deleted file mode 100644 index fc45a547bf..0000000000 --- a/unison-src/transcripts/sum-type-update-conflicts.output.md +++ /dev/null @@ -1,82 +0,0 @@ -# Regression test for updates which conflict with an existing data constructor - -https://github.com/unisonweb/unison/issues/2786 - -First we add a sum-type to the codebase. - -```unison -structural type X = x -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type X - (also named builtin.Unit) - -``` -```ucm -.ns> add - - ⍟ I've added these definitions: - - structural type X - (also named builtin.Unit) - -``` -Now we update the type, changing the name of the constructors, _but_, we simultaneously -add a new top-level term with the same name as the old constructor. - -```unison -structural type X = y | z - -X.x : Text -X.x = "some text that's not in the codebase" - -dependsOnX = Text.size X.x -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - X.x : Text - dependsOnX : Nat - - ⍟ These names already exist. You can `update` them to your - new definition: - - structural type X - (The old definition is also named builtin.Unit.) - -``` -This update should succeed since the conflicted constructor -is removed in the same update that the new term is being added. - -```ucm -.ns> update.old - - ⍟ I've added these definitions: - - X.x : Text - dependsOnX : Nat - - ⍟ I've updated these names to your new definition: - - structural type X - (The old definition was also named builtin.Unit.) - -``` diff --git a/unison-src/transcripts/switch-command.md b/unison-src/transcripts/switch-command.md deleted file mode 100644 index c1a2bca962..0000000000 --- a/unison-src/transcripts/switch-command.md +++ /dev/null @@ -1,50 +0,0 @@ -The `switch` command switches to an existing project or branch. - -```ucm:hide -foo/main> builtins.merge -bar/main> builtins.merge -``` - -Setup stuff. - -```unison -someterm = 18 -``` - -```ucm -foo/main> add -foo/main> branch bar -foo/main> branch topic -``` - -Now, the demo. When unambiguous, `switch` switches to either a project or a branch in the current project. A branch in -the current project can be preceded by a forward slash (which makes it unambiguous). A project can be followed by a -forward slash (which makes it unambiguous). - -```ucm -.> switch foo -.> switch foo/topic -foo/main> switch topic -foo/main> switch /topic -foo/main> switch bar/ -``` - -It's an error to try to switch to something ambiguous. - -```ucm:error -foo/main> switch bar -``` - -It's an error to try to switch to something that doesn't exist, of course. - -```ucm:error -.> switch foo/no-such-branch -``` - -```ucm:error -.> switch no-such-project -``` - -```ucm:error -foo/main> switch no-such-project-or-branch -``` diff --git a/unison-src/transcripts/switch-command.output.md b/unison-src/transcripts/switch-command.output.md deleted file mode 100644 index 2542da7b32..0000000000 --- a/unison-src/transcripts/switch-command.output.md +++ /dev/null @@ -1,94 +0,0 @@ -The `switch` command switches to an existing project or branch. - -Setup stuff. - -```unison -someterm = 18 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - someterm : Nat - -``` -```ucm -foo/main> add - - ⍟ I've added these definitions: - - someterm : Nat - -foo/main> branch bar - - Done. I've created the bar branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /bar`. - -foo/main> branch topic - - Done. I've created the topic branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic`. - -``` -Now, the demo. When unambiguous, `switch` switches to either a project or a branch in the current project. A branch in -the current project can be preceded by a forward slash (which makes it unambiguous). A project can be followed by a -forward slash (which makes it unambiguous). - -```ucm -.> switch foo - -.> switch foo/topic - -foo/main> switch topic - -foo/main> switch /topic - -foo/main> switch bar/ - -``` -It's an error to try to switch to something ambiguous. - -```ucm -foo/main> switch bar - - I'm not sure if you wanted to switch to the branch foo/bar or - the project bar. Could you be more specific? - - 1. /bar (the branch bar in the current project) - 2. bar/ (the project bar, with the branch left unspecified) - - Tip: use `switch 1` or `switch 2` to pick one of these. - -``` -It's an error to try to switch to something that doesn't exist, of course. - -```ucm -.> switch foo/no-such-branch - - foo/no-such-branch does not exist. - -``` -```ucm -.> switch no-such-project - - no-such-project does not exist. - -``` -```ucm -foo/main> switch no-such-project-or-branch - - Neither project no-such-project-or-branch nor branch - /no-such-project-or-branch exists. - -``` diff --git a/unison-src/transcripts/tab-completion.md b/unison-src/transcripts/tab-completion.md deleted file mode 100644 index c35c4ba347..0000000000 --- a/unison-src/transcripts/tab-completion.md +++ /dev/null @@ -1,87 +0,0 @@ -# Tab Completion - -Test that tab completion works as expected. - -## Tab Complete Command Names - -```ucm -.> debug.tab-complete vi -.> debug.tab-complete delete. -``` - -## Tab complete terms & types - -```unison -subnamespace.someName = 1 -subnamespace.someOtherName = 2 -subnamespace2.thing = 3 -othernamespace.someName = 4 - -unique type subnamespace.AType = A | B -``` - -```ucm:hide -.> add -``` - -```ucm --- Should tab complete namespaces since they may contain terms/types -.> debug.tab-complete view sub --- Should not complete things from child namespaces of the current query if there are other completions at this level -.> debug.tab-complete view subnamespace --- Should complete things from child namespaces of the current query if it's dot-suffixed -.> debug.tab-complete view subnamespace. --- Should complete things from child namespaces of the current query if there are no more completions at this level. -.> debug.tab-complete view subnamespace2 --- Should prefix-filter by query suffix -.> debug.tab-complete view subnamespace.some -.> debug.tab-complete view subnamespace.someOther --- Should tab complete absolute names -.othernamespace> debug.tab-complete view .subnamespace.some -``` - -## Tab complete namespaces - -```ucm --- Should tab complete namespaces -.> debug.tab-complete find-in sub -.> debug.tab-complete find-in subnamespace -.> debug.tab-complete find-in subnamespace. -.> debug.tab-complete io.test sub -.> debug.tab-complete io.test subnamespace -.> debug.tab-complete io.test subnamespace. -``` - -Tab Complete Delete Subcommands - -```unison -unique type Foo = A | B -add : a -> a -add b = b -``` - -```ucm -.> update.old -.> debug.tab-complete delete.type Foo -.> debug.tab-complete delete.term add -``` - -## Tab complete projects and branches - -```ucm -myproject/main> branch mybranch -myproject/main> debug.tab-complete branch.delete /mybr -myproject/main> debug.tab-complete project.rename my -``` - -Commands which complete namespaces OR branches should list both - -```unison -mybranchsubnamespace.term = 1 -``` - - -```ucm -myproject/main> add -myproject/main> debug.tab-complete merge mybr -``` diff --git a/unison-src/transcripts/tab-completion.output.md b/unison-src/transcripts/tab-completion.output.md deleted file mode 100644 index 82961cfd5c..0000000000 --- a/unison-src/transcripts/tab-completion.output.md +++ /dev/null @@ -1,222 +0,0 @@ -# Tab Completion - -Test that tab completion works as expected. - -## Tab Complete Command Names - -```ucm -.> debug.tab-complete vi - - view - view.global - -.> debug.tab-complete delete. - - delete.branch - delete.namespace - delete.namespace.force - delete.project - delete.term - delete.term.verbose - delete.type - delete.type.verbose - delete.verbose - -``` -## Tab complete terms & types - -```unison -subnamespace.someName = 1 -subnamespace.someOtherName = 2 -subnamespace2.thing = 3 -othernamespace.someName = 4 - -unique type subnamespace.AType = A | B -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type subnamespace.AType - othernamespace.someName : ##Nat - subnamespace.someName : ##Nat - subnamespace.someOtherName : ##Nat - subnamespace2.thing : ##Nat - -``` -```ucm --- Should tab complete namespaces since they may contain terms/types -.> debug.tab-complete view sub - - subnamespace. - subnamespace2. - --- Should not complete things from child namespaces of the current query if there are other completions at this level -.> debug.tab-complete view subnamespace - - subnamespace. - subnamespace2. - --- Should complete things from child namespaces of the current query if it's dot-suffixed -.> debug.tab-complete view subnamespace. - - * subnamespace.AType - subnamespace.AType. - * subnamespace.someName - * subnamespace.someOtherName - --- Should complete things from child namespaces of the current query if there are no more completions at this level. -.> debug.tab-complete view subnamespace2 - - subnamespace2. - * subnamespace2.thing - --- Should prefix-filter by query suffix -.> debug.tab-complete view subnamespace.some - - * subnamespace.someName - * subnamespace.someOtherName - -.> debug.tab-complete view subnamespace.someOther - - * subnamespace.someOtherName - --- Should tab complete absolute names -.othernamespace> debug.tab-complete view .subnamespace.some - - * .subnamespace.someName - * .subnamespace.someOtherName - -``` -## Tab complete namespaces - -```ucm --- Should tab complete namespaces -.> debug.tab-complete find-in sub - - subnamespace - subnamespace2 - -.> debug.tab-complete find-in subnamespace - - subnamespace - subnamespace2 - -.> debug.tab-complete find-in subnamespace. - - subnamespace.AType - -.> debug.tab-complete io.test sub - - subnamespace. - subnamespace2. - -.> debug.tab-complete io.test subnamespace - - subnamespace. - subnamespace2. - -.> debug.tab-complete io.test subnamespace. - - subnamespace.AType. - * subnamespace.someName - * subnamespace.someOtherName - -``` -Tab Complete Delete Subcommands - -```unison -unique type Foo = A | B -add : a -> a -add b = b -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - add : a -> a - -``` -```ucm -.> update.old - - ⍟ I've added these definitions: - - type Foo - add : a -> a - -.> debug.tab-complete delete.type Foo - - * Foo - Foo. - -.> debug.tab-complete delete.term add - - * add - -``` -## Tab complete projects and branches - -```ucm -myproject/main> branch mybranch - - Done. I've created the mybranch branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /mybranch`. - -myproject/main> debug.tab-complete branch.delete /mybr - - /mybranch - -myproject/main> debug.tab-complete project.rename my - - myproject - -``` -Commands which complete namespaces OR branches should list both - -```unison -mybranchsubnamespace.term = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - mybranchsubnamespace.term : ##Nat - -``` -```ucm -myproject/main> add - - ⍟ I've added these definitions: - - mybranchsubnamespace.term : ##Nat - -myproject/main> debug.tab-complete merge mybr - - /mybranch - -``` diff --git a/unison-src/transcripts/test-command.md b/unison-src/transcripts/test-command.md deleted file mode 100644 index 2f95c846b7..0000000000 --- a/unison-src/transcripts/test-command.md +++ /dev/null @@ -1,57 +0,0 @@ -Merge builtins so we get enough names for the testing stuff. - -```ucm:hide -.> builtins.merge -``` - -The `test` command should run all of the tests in the current directory. - -```unison -test1 : [Result] -test1 = [Ok "test1"] - -foo.test2 : [Result] -foo.test2 = [Ok "test2"] -``` - -```ucm:hide -.> add -``` - -```ucm -.> test -``` - -Tests should be cached if unchanged. - -```ucm -.> test -``` - -`test` won't descend into the `lib` namespace, but `test.all` will. - -```unison -testInLib : [Result] -testInLib = [Ok "testInLib"] -``` - -```ucm:hide -.lib> add -``` - -```ucm -.> test -.> test.all -``` - -`test` WILL run tests within `lib` if ucm is cd'd inside. - -```ucm -.lib> test -``` - -`test` can be given a relative path, in which case it will only run tests found somewhere in that namespace. - -```ucm -.> test foo -``` diff --git a/unison-src/transcripts/test-command.output.md b/unison-src/transcripts/test-command.output.md deleted file mode 100644 index a59faee54c..0000000000 --- a/unison-src/transcripts/test-command.output.md +++ /dev/null @@ -1,149 +0,0 @@ -Merge builtins so we get enough names for the testing stuff. - -The `test` command should run all of the tests in the current directory. - -```unison -test1 : [Result] -test1 = [Ok "test1"] - -foo.test2 : [Result] -foo.test2 = [Ok "test2"] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo.test2 : [Result] - test1 : [Result] - -``` -```ucm -.> test - - ✅ - - - - - - - - - - New test results: - - ◉ foo.test2 test2 - ◉ test1 test1 - - ✅ 2 test(s) passing - - Tip: Use view foo.test2 to view the source of a test. - -``` -Tests should be cached if unchanged. - -```ucm -.> test - - Cached test results (`help testcache` to learn more) - - ◉ foo.test2 test2 - ◉ test1 test1 - - ✅ 2 test(s) passing - - Tip: Use view foo.test2 to view the source of a test. - -``` -`test` won't descend into the `lib` namespace, but `test.all` will. - -```unison -testInLib : [Result] -testInLib = [Ok "testInLib"] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - testInLib : [Result] - -``` -```ucm -.> test - - Cached test results (`help testcache` to learn more) - - ◉ foo.test2 test2 - ◉ test1 test1 - - ✅ 2 test(s) passing - - Tip: Use view foo.test2 to view the source of a test. - -.> test.all - - - Cached test results (`help testcache` to learn more) - - ◉ foo.test2 test2 - ◉ test1 test1 - - ✅ 2 test(s) passing - - ✅ - - - - - - New test results: - - ◉ lib.testInLib testInLib - - ✅ 1 test(s) passing - - Tip: Use view lib.testInLib to view the source of a test. - -``` -`test` WILL run tests within `lib` if ucm is cd'd inside. - -```ucm -.lib> test - - Cached test results (`help testcache` to learn more) - - ◉ testInLib testInLib - - ✅ 1 test(s) passing - - Tip: Use view testInLib to view the source of a test. - -``` -`test` can be given a relative path, in which case it will only run tests found somewhere in that namespace. - -```ucm -.> test foo - - Cached test results (`help testcache` to learn more) - - ◉ foo.test2 test2 - - ✅ 1 test(s) passing - - Tip: Use view foo.test2 to view the source of a test. - -``` diff --git a/unison-src/transcripts/text-literals.md b/unison-src/transcripts/text-literals.md deleted file mode 100644 index 06898d1452..0000000000 --- a/unison-src/transcripts/text-literals.md +++ /dev/null @@ -1,42 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -This transcript shows some syntax for raw text literals. - -```unison -lit1 = """ -This is a raw text literal. -It can start with 3 or more ", -and is terminated by the same number of quotes. -Nothing is escaped. \n - -The initial newline, if it exists, is ignored. -The last line, if it's just whitespace up to the closing quotes, -is ignored. - -Use an extra blank line if you'd like a trailing newline. Like so: - -""" - -> lit1 -> Some lit1 - -lit2 = """" - This is a raw text literal, indented. - It can start with 3 or more ", - and is terminated by the same number of quotes. - Nothing is escaped. \n - - This doesn't terminate the literal - """ - """" - -> lit2 -> Some lit2 -``` - -```ucm -.> add -.> view lit1 lit2 -``` \ No newline at end of file diff --git a/unison-src/transcripts/text-literals.output.md b/unison-src/transcripts/text-literals.output.md deleted file mode 100644 index efb094d98c..0000000000 --- a/unison-src/transcripts/text-literals.output.md +++ /dev/null @@ -1,126 +0,0 @@ - -This transcript shows some syntax for raw text literals. - -```unison -lit1 = """ -This is a raw text literal. -It can start with 3 or more ", -and is terminated by the same number of quotes. -Nothing is escaped. \n - -The initial newline, if it exists, is ignored. -The last line, if it's just whitespace up to the closing quotes, -is ignored. - -Use an extra blank line if you'd like a trailing newline. Like so: - -""" - -> lit1 -> Some lit1 - -lit2 = """" - This is a raw text literal, indented. - It can start with 3 or more ", - and is terminated by the same number of quotes. - Nothing is escaped. \n - - This doesn't terminate the literal - """ - """" - -> lit2 -> Some lit2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - lit1 : Text - lit2 : Text - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 15 | > lit1 - ⧩ - """ - This is a raw text literal. - It can start with 3 or more ", - and is terminated by the same number of quotes. - Nothing is escaped. \n - - The initial newline, if it exists, is ignored. - The last line, if it's just whitespace up to the closing quotes, - is ignored. - - Use an extra blank line if you'd like a trailing newline. Like so: - - """ - - 16 | > Some lit1 - ⧩ - Some - "This is a raw text literal.\nIt can start with 3 or more \",\nand is terminated by the same number of quotes.\nNothing is escaped. \\n\n\nThe initial newline, if it exists, is ignored.\nThe last line, if it's just whitespace up to the closing quotes,\nis ignored.\n\nUse an extra blank line if you'd like a trailing newline. Like so:\n" - - 27 | > lit2 - ⧩ - """" - This is a raw text literal, indented. - It can start with 3 or more ", - and is terminated by the same number of quotes. - Nothing is escaped. \n - - This doesn't terminate the literal - """ - """" - - 28 | > Some lit2 - ⧩ - Some - "This is a raw text literal, indented.\nIt can start with 3 or more \",\nand is terminated by the same number of quotes.\nNothing is escaped. \\n\n\nThis doesn't terminate the literal - \"\"\"" - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - lit1 : Text - lit2 : Text - -.> view lit1 lit2 - - lit1 : Text - lit1 = - """ - This is a raw text literal. - It can start with 3 or more ", - and is terminated by the same number of quotes. - Nothing is escaped. \n - - The initial newline, if it exists, is ignored. - The last line, if it's just whitespace up to the closing quotes, - is ignored. - - Use an extra blank line if you'd like a trailing newline. Like so: - - """ - - lit2 : Text - lit2 = - """" - This is a raw text literal, indented. - It can start with 3 or more ", - and is terminated by the same number of quotes. - Nothing is escaped. \n - - This doesn't terminate the literal - """ - """" - -``` diff --git a/unison-src/transcripts/todo-bug-builtins.md b/unison-src/transcripts/todo-bug-builtins.md deleted file mode 100644 index c7d88fb784..0000000000 --- a/unison-src/transcripts/todo-bug-builtins.md +++ /dev/null @@ -1,27 +0,0 @@ -# The `todo` and `bug` builtin - -```ucm:hide -.> builtins.merge -``` - -`todo` and `bug` have type `a -> b`. They take a message or a value of type `a` and crash during runtime displaying `a` in ucm. -```unison:error -> todo "implement me later" -``` -```unison:error -> bug "there's a bug in my code" -``` - -## Todo -`todo` is useful if you want to come back to a piece of code later but you want your project to compile. -```unison -complicatedMathStuff x = todo "Come back and to something with x here" -``` - -## Bug -`bug` is used to indicate that a particular branch is not expected to execute. -```unison -test = match true with - true -> "Yay" - false -> bug "Wow, that's unexpected" -``` diff --git a/unison-src/transcripts/todo-bug-builtins.output.md b/unison-src/transcripts/todo-bug-builtins.output.md deleted file mode 100644 index 0e3bb72ada..0000000000 --- a/unison-src/transcripts/todo-bug-builtins.output.md +++ /dev/null @@ -1,97 +0,0 @@ -# The `todo` and `bug` builtin - -`todo` and `bug` have type `a -> b`. They take a message or a value of type `a` and crash during runtime displaying `a` in ucm. -```unison -> todo "implement me later" -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 💔💥 - - I've encountered a call to builtin.todo with the following - value: - - "implement me later" - - Stack trace: - todo - #qe5e1lcfn8 - -``` -```unison -> bug "there's a bug in my code" -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 💔💥 - - I've encountered a call to builtin.bug with the following - value: - - "there's a bug in my code" - - Stack trace: - bug - #m67hcdcoda - -``` -## Todo -`todo` is useful if you want to come back to a piece of code later but you want your project to compile. -```unison -complicatedMathStuff x = todo "Come back and to something with x here" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - complicatedMathStuff : x -> r - -``` -## Bug -`bug` is used to indicate that a particular branch is not expected to execute. -```unison -test = match true with - true -> "Yay" - false -> bug "Wow, that's unexpected" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - test : Text - -``` diff --git a/unison-src/transcripts/todo.md b/unison-src/transcripts/todo.md deleted file mode 100644 index 39fece2f61..0000000000 --- a/unison-src/transcripts/todo.md +++ /dev/null @@ -1,139 +0,0 @@ -# Test the `todo` command - -## Simple type-changing update. - -```ucm:hide -.simple> builtins.merge -``` - -```unison:hide -x = 1 -useX = x + 10 - -type MyType = MyType Nat -useMyType = match MyType 1 with - MyType a -> a + 10 -``` - -```ucm:hide -.simple> add -``` - -Perform a type-changing update so dependents are added to our update frontier. - -```unison:hide -x = -1 - -type MyType = MyType Text -``` - -```ucm:error -.simple> update.old -.simple> todo -``` - -## A merge with conflicting updates. - -```ucm:hide -.mergeA> builtins.merge -``` - -```unison:hide -x = 1 -type MyType = MyType -``` - -Set up two branches with the same starting point. - -```ucm:hide -.mergeA> add -.> fork .mergeA .mergeB -``` - -Update `x` to a different term in each branch. - -```unison:hide -x = 2 -type MyType = MyType Nat -``` - -```ucm:hide -.mergeA> update.old -``` - -```unison:hide -x = 3 -type MyType = MyType Int -``` - -```ucm:hide -.mergeB> update.old -``` - -```ucm:error -.mergeA> merge.old .mergeB -.mergeA> todo -``` - -## A named value that appears on the LHS of a patch isn't shown - -```ucm:hide -.lhs> builtins.merge -``` - -```unison -foo = 801 -``` - -```ucm -.lhs> add -``` - -```unison -foo = 802 -``` - -```ucm -.lhs> update.old -``` - -```unison -oldfoo = 801 -``` - -```ucm -.lhs> add -.lhs> todo -``` - -## A type-changing update to one element of a cycle, which doesn't propagate to the other - -```ucm:hide -.cycle2> builtins.merge -``` - -```unison -even = cases - 0 -> true - n -> odd (drop 1 n) - -odd = cases - 0 -> false - n -> even (drop 1 n) -``` - -```ucm -.cycle2> add -``` - -```unison -even = 17 -``` - -```ucm -.cycle2> update.old -``` - -```ucm:error -.cycle2> todo -``` diff --git a/unison-src/transcripts/todo.output.md b/unison-src/transcripts/todo.output.md deleted file mode 100644 index b0a9d69c6d..0000000000 --- a/unison-src/transcripts/todo.output.md +++ /dev/null @@ -1,292 +0,0 @@ -# Test the `todo` command - -## Simple type-changing update. - -```unison -x = 1 -useX = x + 10 - -type MyType = MyType Nat -useMyType = match MyType 1 with - MyType a -> a + 10 -``` - -Perform a type-changing update so dependents are added to our update frontier. - -```unison -x = -1 - -type MyType = MyType Text -``` - -```ucm -.simple> update.old - - ⍟ I've updated these names to your new definition: - - type MyType - x : Int - -.simple> todo - - 🚧 - - The namespace has 2 transitive dependent(s) left to upgrade. - Your edit frontier is the dependents of these definitions: - - type #vijug0om28 - #gjmq673r1v : Nat - - I recommend working on them in the following order: - - 1. useMyType : Nat - 2. useX : Nat - - - -``` -## A merge with conflicting updates. - -```unison -x = 1 -type MyType = MyType -``` - -Set up two branches with the same starting point. - -Update `x` to a different term in each branch. - -```unison -x = 2 -type MyType = MyType Nat -``` - -```unison -x = 3 -type MyType = MyType Int -``` - -```ucm -.mergeA> merge.old .mergeB - - Here's what's changed in the current namespace after the - merge: - - New name conflicts: - - 1. type MyType#ig1g2ka7lv - ↓ - 2. ┌ type MyType#8c6f40i3tj - 3. └ type MyType#ig1g2ka7lv - - 4. MyType.MyType#ig1g2ka7lv#0 : Nat -> MyType#ig1g2ka7lv - ↓ - 5. ┌ MyType.MyType#8c6f40i3tj#0 : Int -> MyType#8c6f40i3tj - 6. └ MyType.MyType#ig1g2ka7lv#0 : Nat -> MyType#ig1g2ka7lv - - 7. x#dcgdua2lj6 : Nat - ↓ - 8. ┌ x#dcgdua2lj6 : Nat - 9. └ x#f3lgjvjqoo : Nat - - Updates: - - 10. patch patch (added 2 updates) - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - - I tried to auto-apply the patch, but couldn't because it - contained contradictory entries. - -.mergeA> todo - - ❓ - - These definitions were edited differently in namespaces that - have been merged into this one. You'll have to tell me what to - use as the new definition: - - The type 1. #8h7qq3ougl was replaced with - 2. MyType#8c6f40i3tj - 3. MyType#ig1g2ka7lv - The term 4. #gjmq673r1v was replaced with - 5. x#dcgdua2lj6 - 6. x#f3lgjvjqoo - ❓ - - The term MyType.MyType has conflicting definitions: - 7. MyType.MyType#8c6f40i3tj#0 - 8. MyType.MyType#ig1g2ka7lv#0 - - Tip: This occurs when merging branches that both independently - introduce the same name. Use `move.term` or `delete.term` - to resolve the conflicts. - -``` -## A named value that appears on the LHS of a patch isn't shown - -```unison -foo = 801 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo : Nat - -``` -```ucm -.lhs> add - - ⍟ I've added these definitions: - - foo : Nat - -``` -```unison -foo = 802 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : Nat - -``` -```ucm -.lhs> update.old - - ⍟ I've updated these names to your new definition: - - foo : Nat - -``` -```unison -oldfoo = 801 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - oldfoo : Nat - -``` -```ucm -.lhs> add - - ⍟ I've added these definitions: - - oldfoo : Nat - -.lhs> todo - - ✅ - - No conflicts or edits in progress. - -``` -## A type-changing update to one element of a cycle, which doesn't propagate to the other - -```unison -even = cases - 0 -> true - n -> odd (drop 1 n) - -odd = cases - 0 -> false - n -> even (drop 1 n) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - even : Nat -> Boolean - odd : Nat -> Boolean - -``` -```ucm -.cycle2> add - - ⍟ I've added these definitions: - - even : Nat -> Boolean - odd : Nat -> Boolean - -``` -```unison -even = 17 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - even : Nat - -``` -```ucm -.cycle2> update.old - - ⍟ I've updated these names to your new definition: - - even : Nat - -``` -```ucm -.cycle2> todo - - 🚧 - - The namespace has 1 transitive dependent(s) left to upgrade. - Your edit frontier is the dependents of these definitions: - - #kkohl7ba1e : Nat -> Boolean - - I recommend working on them in the following order: - - 1. odd : Nat -> Boolean - - - -``` diff --git a/unison-src/transcripts/top-level-exceptions.md b/unison-src/transcripts/top-level-exceptions.md deleted file mode 100644 index 8749984744..0000000000 --- a/unison-src/transcripts/top-level-exceptions.md +++ /dev/null @@ -1,46 +0,0 @@ - -A simple transcript to test the use of exceptions that bubble to the top level. - -```ucm:hide -.> builtins.merge -``` - -FYI, here are the `Exception` and `Failure` types: - -```ucm -.> view Exception Failure -``` - -Here's a sample program just to verify that the typechecker allows `run` to throw exceptions: - -```unison -use builtin IO Exception Test.Result - -main : '{IO, Exception} () -main _ = () - -mytest : '{IO, Exception} [Test.Result] -mytest _ = [Ok "Great"] -``` - -```ucm -.> run main -.> add -.> io.test mytest -``` - -Now a test to show the handling of uncaught exceptions: - -```unison -main2 = '(error "oh noes!" ()) - -error : Text -> a ->{Exception} x -error msg a = - builtin.Exception.raise (Failure (typeLink RuntimeError) msg (Any a)) - -unique type RuntimeError = -``` - -```ucm:error -.> run main2 -``` diff --git a/unison-src/transcripts/top-level-exceptions.output.md b/unison-src/transcripts/top-level-exceptions.output.md deleted file mode 100644 index 745e94c657..0000000000 --- a/unison-src/transcripts/top-level-exceptions.output.md +++ /dev/null @@ -1,104 +0,0 @@ - -A simple transcript to test the use of exceptions that bubble to the top level. - -FYI, here are the `Exception` and `Failure` types: - -```ucm -.> view Exception Failure - - structural ability builtin.Exception where - raise : Failure ->{builtin.Exception} x - - type builtin.io2.Failure - = Failure Type Text Any - -``` -Here's a sample program just to verify that the typechecker allows `run` to throw exceptions: - -```unison -use builtin IO Exception Test.Result - -main : '{IO, Exception} () -main _ = () - -mytest : '{IO, Exception} [Test.Result] -mytest _ = [Ok "Great"] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - main : '{IO, Exception} () - mytest : '{IO, Exception} [Result] - -``` -```ucm -.> run main - - () - -.> add - - ⍟ I've added these definitions: - - main : '{IO, Exception} () - mytest : '{IO, Exception} [Result] - -.> io.test mytest - - New test results: - - ◉ mytest Great - - ✅ 1 test(s) passing - - Tip: Use view mytest to view the source of a test. - -``` -Now a test to show the handling of uncaught exceptions: - -```unison -main2 = '(error "oh noes!" ()) - -error : Text -> a ->{Exception} x -error msg a = - builtin.Exception.raise (Failure (typeLink RuntimeError) msg (Any a)) - -unique type RuntimeError = -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type RuntimeError - error : Text -> a ->{Exception} x - main2 : '{Exception} r - -``` -```ucm -.> run main2 - - 💔💥 - - The program halted with an unhandled exception: - - Failure (typeLink RuntimeError) "oh noes!" (Any ()) - - Stack trace: - ##raise - -``` diff --git a/unison-src/transcripts/transcript-parser-commands.md b/unison-src/transcripts/transcript-parser-commands.md deleted file mode 100644 index e39fd10885..0000000000 --- a/unison-src/transcripts/transcript-parser-commands.md +++ /dev/null @@ -1,41 +0,0 @@ -### Transcript parser operations - -```ucm:hide -.> builtins.merge -``` - -The transcript parser is meant to parse `ucm` and `unison` blocks. - -```unison -x = 1 -``` - -```ucm -.> add -``` - -```unison:hide:error:scratch.u -z -``` - -```ucm:error -.> delete foo -``` - -```ucm :error -.> delete lineToken.call -``` - -However handling of blocks of other languages should be supported. - -```python -some python code -``` - -```c_cpp -some C++ code -``` - -```c9search -some cloud9 code -``` diff --git a/unison-src/transcripts/transcript-parser-commands.output.md b/unison-src/transcripts/transcript-parser-commands.output.md deleted file mode 100644 index 15b72bc3b1..0000000000 --- a/unison-src/transcripts/transcript-parser-commands.output.md +++ /dev/null @@ -1,76 +0,0 @@ -### Transcript parser operations - -The transcript parser is meant to parse `ucm` and `unison` blocks. - -```unison -x = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - x : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - x : Nat - -``` -```unison ---- -title: :scratch.u ---- -z - -``` - - -```ucm -.> delete foo - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - foo - -``` -```ucm -.> delete lineToken.call - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - lineToken.call - -``` -However handling of blocks of other languages should be supported. - -```python - -some python code - -``` - -```c_cpp - -some C++ code - -``` - -```c9search - -some cloud9 code - -``` - diff --git a/unison-src/transcripts/type-deps.md b/unison-src/transcripts/type-deps.md deleted file mode 100644 index 142265c786..0000000000 --- a/unison-src/transcripts/type-deps.md +++ /dev/null @@ -1,32 +0,0 @@ -# Ensure type dependencies are properly considered in slurping - -https://github.com/unisonweb/unison/pull/2821 - -```ucm:hide -.> builtins.merge -``` - - -Define a type. - -```unison:hide -structural type Y = Y -``` - -```ucm:hide -.> add -``` - -Now, we update `Y`, and add a new type `Z` which depends on it. - -```unison -structural type Z = Z Y -structural type Y = Y Nat -``` - -Adding should fail for BOTH definitions, `Y` needs an update and `Z` is blocked by `Y`. -```ucm:error -.> add --- This shouldn't exist, because it should've been blocked. -.> view Z -``` diff --git a/unison-src/transcripts/type-deps.output.md b/unison-src/transcripts/type-deps.output.md deleted file mode 100644 index b3a18e310d..0000000000 --- a/unison-src/transcripts/type-deps.output.md +++ /dev/null @@ -1,57 +0,0 @@ -# Ensure type dependencies are properly considered in slurping - -https://github.com/unisonweb/unison/pull/2821 - -Define a type. - -```unison -structural type Y = Y -``` - -Now, we update `Y`, and add a new type `Z` which depends on it. - -```unison -structural type Z = Z Y -structural type Y = Y Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type Z - - ⍟ These names already exist. You can `update` them to your - new definition: - - structural type Y - (The old definition is also named builtin.Unit.) - -``` -Adding should fail for BOTH definitions, `Y` needs an update and `Z` is blocked by `Y`. -```ucm -.> add - - x These definitions failed: - - Reason - needs update structural type Y - blocked structural type Z - - Tip: Use `help filestatus` to learn more. - --- This shouldn't exist, because it should've been blocked. -.> view Z - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - Z - -``` diff --git a/unison-src/transcripts/type-modifier-are-optional.md b/unison-src/transcripts/type-modifier-are-optional.md deleted file mode 100644 index abce0ad0b8..0000000000 --- a/unison-src/transcripts/type-modifier-are-optional.md +++ /dev/null @@ -1,17 +0,0 @@ -# Type modifiers are optional, `unique` is the default. - -```ucm:hide -.> builtins.merge -``` - -Types and abilities may be prefixed with either `unique` or `structural`. When left unspecified, `unique` is assumed. - -```unison -type Abc = Abc -unique type Def = Def -structural type Ghi = Ghi - -ability MyAbility where const : a -unique ability MyAbilityU where const : a -structural ability MyAbilityS where const : a -``` diff --git a/unison-src/transcripts/type-modifier-are-optional.output.md b/unison-src/transcripts/type-modifier-are-optional.output.md deleted file mode 100644 index 88b7844127..0000000000 --- a/unison-src/transcripts/type-modifier-are-optional.output.md +++ /dev/null @@ -1,33 +0,0 @@ -# Type modifiers are optional, `unique` is the default. - -Types and abilities may be prefixed with either `unique` or `structural`. When left unspecified, `unique` is assumed. - -```unison -type Abc = Abc -unique type Def = Def -structural type Ghi = Ghi - -ability MyAbility where const : a -unique ability MyAbilityU where const : a -structural ability MyAbilityS where const : a -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Abc - type Def - structural type Ghi - (also named builtin.Unit) - ability MyAbility - structural ability MyAbilityS - ability MyAbilityU - -``` diff --git a/unison-src/transcripts/unique-type-churn.md b/unison-src/transcripts/unique-type-churn.md deleted file mode 100644 index 904e1c480c..0000000000 --- a/unison-src/transcripts/unique-type-churn.md +++ /dev/null @@ -1,46 +0,0 @@ -This transcript demonstrates that unique types no longer always get a fresh GUID: they share GUIDs with already-saved -unique types of the same name. - -```unison -unique type A = A - -unique type B = B C -unique type C = C B -``` - -```ucm -.> add -``` - -```unison -unique type A = A - -unique type B = B C -unique type C = C B -``` - -If the name stays the same, the churn is even prevented if the type is updated and then reverted to the original form. - -```ucm -.> names A -``` - -```unison -unique type A = A () -``` - -```ucm -.> update -.> names A -``` - -```unison -unique type A = A -``` - -Note that `A` is back to its original hash. - -```ucm -.> update -.> names A -``` diff --git a/unison-src/transcripts/unique-type-churn.output.md b/unison-src/transcripts/unique-type-churn.output.md deleted file mode 100644 index bcee03f59e..0000000000 --- a/unison-src/transcripts/unique-type-churn.output.md +++ /dev/null @@ -1,146 +0,0 @@ -This transcript demonstrates that unique types no longer always get a fresh GUID: they share GUIDs with already-saved -unique types of the same name. - -```unison -unique type A = A - -unique type B = B C -unique type C = C B -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type A - type B - type C - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type A - type B - type C - -``` -```unison -unique type A = A - -unique type B = B C -unique type C = C B -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked the definitions in scratch.u. This - file has been previously added to the codebase. - -``` -If the name stays the same, the churn is even prevented if the type is updated and then reverted to the original form. - -```ucm -.> names A - - Type - Hash: #uj8oalgadr - Names: A - - Term - Hash: #uj8oalgadr#0 - Names: A.A - - Tip: Use `names.global` to see more results. - -``` -```unison -unique type A = A () -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type A - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> names A - - Type - Hash: #ufo5tuc7ho - Names: A - - Term - Hash: #ufo5tuc7ho#0 - Names: A.A - - Tip: Use `names.global` to see more results. - -``` -```unison -unique type A = A -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type A - -``` -Note that `A` is back to its original hash. - -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> names A - - Type - Hash: #uj8oalgadr - Names: A - - Term - Hash: #uj8oalgadr#0 - Names: A.A - - Tip: Use `names.global` to see more results. - -``` diff --git a/unison-src/transcripts/unitnamespace.md b/unison-src/transcripts/unitnamespace.md deleted file mode 100644 index 0f6838dae5..0000000000 --- a/unison-src/transcripts/unitnamespace.md +++ /dev/null @@ -1,10 +0,0 @@ -```unison -foo = "bar" -``` - -```ucm -.`()`> add -.> find -.> find-in `()` -.> delete.namespace `()` -``` diff --git a/unison-src/transcripts/unitnamespace.output.md b/unison-src/transcripts/unitnamespace.output.md deleted file mode 100644 index 9e18ea08ef..0000000000 --- a/unison-src/transcripts/unitnamespace.output.md +++ /dev/null @@ -1,41 +0,0 @@ -```unison -foo = "bar" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo : ##Text - -``` -```ucm - ☝️ The namespace .`()` is empty. - -.`()`> add - - ⍟ I've added these definitions: - - foo : ##Text - -.> find - - 1. `()`.foo : ##Text - - -.> find-in `()` - - 1. foo : ##Text - - -.> delete.namespace `()` - - Done. - -``` diff --git a/unison-src/transcripts/universal-cmp.md b/unison-src/transcripts/universal-cmp.md deleted file mode 100644 index 2364cb39c2..0000000000 --- a/unison-src/transcripts/universal-cmp.md +++ /dev/null @@ -1,28 +0,0 @@ - -File for test cases making sure that universal equality/comparison -cases exist for built-in types. Just making sure they don't crash. - -```ucm:hide -.> builtins.merge -``` - -```unison -unique type A = A - -threadEyeDeez _ = - t1 = forkComp '() - t2 = forkComp '() - (t1 == t2, t1 < t2) -``` - -```ucm -.> add -.> run threadEyeDeez -``` - -```unison -> typeLink A == typeLink A -> typeLink Text == typeLink Text -> typeLink Text == typeLink A -> termLink threadEyeDeez == termLink threadEyeDeez -``` diff --git a/unison-src/transcripts/universal-cmp.output.md b/unison-src/transcripts/universal-cmp.output.md deleted file mode 100644 index ec03128e87..0000000000 --- a/unison-src/transcripts/universal-cmp.output.md +++ /dev/null @@ -1,75 +0,0 @@ - -File for test cases making sure that universal equality/comparison -cases exist for built-in types. Just making sure they don't crash. - -```unison -unique type A = A - -threadEyeDeez _ = - t1 = forkComp '() - t2 = forkComp '() - (t1 == t2, t1 < t2) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type A - threadEyeDeez : ∀ _. _ ->{IO} (Boolean, Boolean) - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type A - threadEyeDeez : ∀ _. _ ->{IO} (Boolean, Boolean) - -.> run threadEyeDeez - - (false, true) - -``` -```unison -> typeLink A == typeLink A -> typeLink Text == typeLink Text -> typeLink Text == typeLink A -> termLink threadEyeDeez == termLink threadEyeDeez -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > typeLink A == typeLink A - ⧩ - true - - 2 | > typeLink Text == typeLink Text - ⧩ - true - - 3 | > typeLink Text == typeLink A - ⧩ - false - - 4 | > termLink threadEyeDeez == termLink threadEyeDeez - ⧩ - true - -``` diff --git a/unison-src/transcripts/unsafe-coerce.md b/unison-src/transcripts/unsafe-coerce.md deleted file mode 100644 index ab3c38481e..0000000000 --- a/unison-src/transcripts/unsafe-coerce.md +++ /dev/null @@ -1,23 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -```unison -f : '{} Nat -f _ = 5 - -fc : '{IO, Exception} Nat -fc = unsafe.coerceAbilities f - -main : '{IO, Exception} [Result] -main _ = - n = !fc - if n == 5 then [Ok ""] else [Fail ""] -``` - -```ucm -.> find unsafe.coerceAbilities -.> add -.> io.test main -``` diff --git a/unison-src/transcripts/unsafe-coerce.output.md b/unison-src/transcripts/unsafe-coerce.output.md deleted file mode 100644 index 8736e6e9cd..0000000000 --- a/unison-src/transcripts/unsafe-coerce.output.md +++ /dev/null @@ -1,54 +0,0 @@ - -```unison -f : '{} Nat -f _ = 5 - -fc : '{IO, Exception} Nat -fc = unsafe.coerceAbilities f - -main : '{IO, Exception} [Result] -main _ = - n = !fc - if n == 5 then [Ok ""] else [Fail ""] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - f : 'Nat - fc : '{IO, Exception} Nat - main : '{IO, Exception} [Result] - -``` -```ucm -.> find unsafe.coerceAbilities - - 1. builtin.unsafe.coerceAbilities : (a ->{e1} b) -> a -> b - - -.> add - - ⍟ I've added these definitions: - - f : 'Nat - fc : '{IO, Exception} Nat - main : '{IO, Exception} [Result] - -.> io.test main - - New test results: - - ◉ main - - ✅ 1 test(s) passing - - Tip: Use view main to view the source of a test. - -``` diff --git a/unison-src/transcripts/update-ignores-lib-namespace.md b/unison-src/transcripts/update-ignores-lib-namespace.md deleted file mode 100644 index 04498e48ab..0000000000 --- a/unison-src/transcripts/update-ignores-lib-namespace.md +++ /dev/null @@ -1,25 +0,0 @@ -`update` / `patch` (anything that a patch) ignores the namespace named "lib" at the location it's applied. This follows -the project organization convention that dependencies are put in "lib"; it's much easier to apply a patch to all of -one's own code if the "lib" namespace is simply ignored. - -```ucm:hide -.> builtins.merge -``` - -```unison -foo = 100 -lib.foo = 100 -``` - -```ucm -.> add -``` - -```unison -foo = 200 -``` - -```ucm -.> update -.> names foo -``` diff --git a/unison-src/transcripts/update-ignores-lib-namespace.output.md b/unison-src/transcripts/update-ignores-lib-namespace.output.md deleted file mode 100644 index 5711f81a81..0000000000 --- a/unison-src/transcripts/update-ignores-lib-namespace.output.md +++ /dev/null @@ -1,68 +0,0 @@ -`update` / `patch` (anything that a patch) ignores the namespace named "lib" at the location it's applied. This follows -the project organization convention that dependencies are put in "lib"; it's much easier to apply a patch to all of -one's own code if the "lib" namespace is simply ignored. - -```unison -foo = 100 -lib.foo = 100 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo : Nat - lib.foo : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - foo : Nat - lib.foo : Nat - -``` -```unison -foo = 200 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : Nat - (The old definition is also named lib.foo.) - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> names foo - - Term - Hash: #9ntnotdp87 - Names: foo - - Tip: Use `names.global` to see more results. - -``` diff --git a/unison-src/transcripts/update-on-conflict.md b/unison-src/transcripts/update-on-conflict.md deleted file mode 100644 index 21b9a656cb..0000000000 --- a/unison-src/transcripts/update-on-conflict.md +++ /dev/null @@ -1,28 +0,0 @@ -# Update on conflict - -```ucm:hide -.> builtins.merge -.merged> builtins.merge -``` - -```unison -a.x = 1 -b.x = 2 -``` - -Cause a conflict: -```ucm -.> add -.merged> merge.old .a -.merged> merge.old .b -``` - -Updating conflicted definitions works fine. - -```unison -x = 3 -``` - -```ucm -.merged> update -``` diff --git a/unison-src/transcripts/update-on-conflict.output.md b/unison-src/transcripts/update-on-conflict.output.md deleted file mode 100644 index 6a9afd2e93..0000000000 --- a/unison-src/transcripts/update-on-conflict.output.md +++ /dev/null @@ -1,95 +0,0 @@ -# Update on conflict - -```unison -a.x = 1 -b.x = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - a.x : Nat - b.x : Nat - -``` -Cause a conflict: -```ucm -.> add - - ⍟ I've added these definitions: - - a.x : Nat - b.x : Nat - -.merged> merge.old .a - - Here's what's changed in the current namespace after the - merge: - - Added definitions: - - 1. x : Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -.merged> merge.old .b - - Here's what's changed in the current namespace after the - merge: - - New name conflicts: - - 1. x#gjmq673r1v : Nat - ↓ - 2. ┌ x#dcgdua2lj6 : Nat - 3. └ x#gjmq673r1v : Nat - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` -Updating conflicted definitions works fine. - -```unison -x = 3 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - x : Nat - -``` -```ucm -.merged> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -``` diff --git a/unison-src/transcripts/update-suffixifies-properly.md b/unison-src/transcripts/update-suffixifies-properly.md deleted file mode 100644 index d983959770..0000000000 --- a/unison-src/transcripts/update-suffixifies-properly.md +++ /dev/null @@ -1,24 +0,0 @@ -```ucm:hide -myproject/main> builtins.merge lib.builtin -``` - -```unison -a.x.x.x.x = 100 -b.x.x.x.x = 100 -foo = 25 -c.y.y.y.y = foo + 10 -d.y.y.y.y = foo + 10 -bar = a.x.x.x.x + c.y.y.y.y -``` - -```ucm -myproject/main> add -``` - -```unison -foo = +30 -``` - -```ucm:error -myproject/main> update -``` diff --git a/unison-src/transcripts/update-suffixifies-properly.output.md b/unison-src/transcripts/update-suffixifies-properly.output.md deleted file mode 100644 index 812eac20e2..0000000000 --- a/unison-src/transcripts/update-suffixifies-properly.output.md +++ /dev/null @@ -1,90 +0,0 @@ -```unison -a.x.x.x.x = 100 -b.x.x.x.x = 100 -foo = 25 -c.y.y.y.y = foo + 10 -d.y.y.y.y = foo + 10 -bar = a.x.x.x.x + c.y.y.y.y -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - a.x.x.x.x : Nat - b.x.x.x.x : Nat - bar : Nat - c.y.y.y.y : Nat - d.y.y.y.y : Nat - foo : Nat - -``` -```ucm -myproject/main> add - - ⍟ I've added these definitions: - - a.x.x.x.x : Nat - b.x.x.x.x : Nat - bar : Nat - c.y.y.y.y : Nat - d.y.y.y.y : Nat - foo : Nat - -``` -```unison -foo = +30 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : Int - -``` -```ucm -myproject/main> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Typechecking failed. I've updated your scratch file with the - definitions that need fixing. Once the file is compiling, try - `update` again. - -``` -```unison:added-by-ucm scratch.u -bar : Nat -bar = - use Nat + - x + c.y.y.y.y - -c.y.y.y.y : Nat -c.y.y.y.y = - use Nat + - foo + 10 - -d.y.y.y.y : Nat -d.y.y.y.y = - use Nat + - foo + 10 - -foo = +30 -``` - diff --git a/unison-src/transcripts/update-term-aliases-in-different-ways.md b/unison-src/transcripts/update-term-aliases-in-different-ways.md deleted file mode 100644 index fd8a8816c0..0000000000 --- a/unison-src/transcripts/update-term-aliases-in-different-ways.md +++ /dev/null @@ -1,28 +0,0 @@ -```ucm -.> builtins.merge -``` - -```unison -foo : Nat -foo = 5 - -bar : Nat -bar = 5 -``` - -```ucm -.> add -``` - -```unison -foo : Nat -foo = 6 - -bar : Nat -bar = 7 -``` - -```ucm -.> update -.> view foo bar -``` diff --git a/unison-src/transcripts/update-term-aliases-in-different-ways.output.md b/unison-src/transcripts/update-term-aliases-in-different-ways.output.md deleted file mode 100644 index 2d7960976a..0000000000 --- a/unison-src/transcripts/update-term-aliases-in-different-ways.output.md +++ /dev/null @@ -1,79 +0,0 @@ -```ucm -.> builtins.merge - - Done. - -``` -```unison -foo : Nat -foo = 5 - -bar : Nat -bar = 5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bar : Nat - foo : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - bar : Nat - foo : Nat - -``` -```unison -foo : Nat -foo = 6 - -bar : Nat -bar = 7 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - bar : Nat - (The old definition is also named foo.) - foo : Nat - (The old definition is also named bar.) - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> view foo bar - - bar : Nat - bar = 7 - - foo : Nat - foo = 6 - -``` diff --git a/unison-src/transcripts/update-term-to-different-type.md b/unison-src/transcripts/update-term-to-different-type.md deleted file mode 100644 index 3fa5a735f9..0000000000 --- a/unison-src/transcripts/update-term-to-different-type.md +++ /dev/null @@ -1,22 +0,0 @@ -```ucm -.> builtins.merge -``` - -```unison -foo : Nat -foo = 5 -``` - -```ucm -.> add -``` - -```unison -foo : Int -foo = +5 -``` - -```ucm -.> update -.> view foo -``` diff --git a/unison-src/transcripts/update-term-to-different-type.output.md b/unison-src/transcripts/update-term-to-different-type.output.md deleted file mode 100644 index 7f6bf57ccf..0000000000 --- a/unison-src/transcripts/update-term-to-different-type.output.md +++ /dev/null @@ -1,65 +0,0 @@ -```ucm -.> builtins.merge - - Done. - -``` -```unison -foo : Nat -foo = 5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - foo : Nat - -``` -```unison -foo : Int -foo = +5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : Int - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> view foo - - foo : Int - foo = +5 - -``` diff --git a/unison-src/transcripts/update-term-with-alias.md b/unison-src/transcripts/update-term-with-alias.md deleted file mode 100644 index b3c5e9e791..0000000000 --- a/unison-src/transcripts/update-term-with-alias.md +++ /dev/null @@ -1,25 +0,0 @@ -```ucm -.> builtins.merge -``` - -```unison -foo : Nat -foo = 5 - -bar : Nat -bar = 5 -``` - -```ucm -.> add -``` - -```unison -foo : Nat -foo = 6 -``` - -```ucm -.> update -.> view foo bar -``` diff --git a/unison-src/transcripts/update-term-with-alias.output.md b/unison-src/transcripts/update-term-with-alias.output.md deleted file mode 100644 index abf21943aa..0000000000 --- a/unison-src/transcripts/update-term-with-alias.output.md +++ /dev/null @@ -1,74 +0,0 @@ -```ucm -.> builtins.merge - - Done. - -``` -```unison -foo : Nat -foo = 5 - -bar : Nat -bar = 5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bar : Nat - foo : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - bar : Nat - foo : Nat - -``` -```unison -foo : Nat -foo = 6 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : Nat - (The old definition is also named bar.) - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> view foo bar - - bar : Nat - bar = 5 - - foo : Nat - foo = 6 - -``` diff --git a/unison-src/transcripts/update-term-with-dependent-to-different-type.md b/unison-src/transcripts/update-term-with-dependent-to-different-type.md deleted file mode 100644 index c9d6388dc3..0000000000 --- a/unison-src/transcripts/update-term-with-dependent-to-different-type.md +++ /dev/null @@ -1,24 +0,0 @@ -```ucm -.> builtins.merge -``` - -```unison -foo : Nat -foo = 5 - -bar : Nat -bar = foo + 10 -``` - -```ucm -.> add -``` - -```unison -foo : Int -foo = +5 -``` - -```ucm:error -.> update -``` diff --git a/unison-src/transcripts/update-term-with-dependent-to-different-type.output.md b/unison-src/transcripts/update-term-with-dependent-to-different-type.output.md deleted file mode 100644 index 1a62cebf4a..0000000000 --- a/unison-src/transcripts/update-term-with-dependent-to-different-type.output.md +++ /dev/null @@ -1,79 +0,0 @@ -```ucm -.> builtins.merge - - Done. - -``` -```unison -foo : Nat -foo = 5 - -bar : Nat -bar = foo + 10 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bar : Nat - foo : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - bar : Nat - foo : Nat - -``` -```unison -foo : Int -foo = +5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : Int - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Typechecking failed. I've updated your scratch file with the - definitions that need fixing. Once the file is compiling, try - `update` again. - -``` -```unison:added-by-ucm scratch.u -bar : Nat -bar = - use Nat + - foo + 10 - -foo : Int -foo = +5 -``` - diff --git a/unison-src/transcripts/update-term-with-dependent.md b/unison-src/transcripts/update-term-with-dependent.md deleted file mode 100644 index d7aa6b3db6..0000000000 --- a/unison-src/transcripts/update-term-with-dependent.md +++ /dev/null @@ -1,25 +0,0 @@ -```ucm -.> builtins.merge -``` - -```unison -foo : Nat -foo = 5 - -bar : Nat -bar = foo + 10 -``` - -```ucm -.> add -``` - -```unison -foo : Nat -foo = 6 -``` - -```ucm -.> update -.> view bar -``` diff --git a/unison-src/transcripts/update-term-with-dependent.output.md b/unison-src/transcripts/update-term-with-dependent.output.md deleted file mode 100644 index dc2d66f72a..0000000000 --- a/unison-src/transcripts/update-term-with-dependent.output.md +++ /dev/null @@ -1,76 +0,0 @@ -```ucm -.> builtins.merge - - Done. - -``` -```unison -foo : Nat -foo = 5 - -bar : Nat -bar = foo + 10 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bar : Nat - foo : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - bar : Nat - foo : Nat - -``` -```unison -foo : Nat -foo = 6 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : Nat - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Everything typechecks, so I'm saving the results... - - Done. - -.> view bar - - bar : Nat - bar = - use Nat + - foo + 10 - -``` diff --git a/unison-src/transcripts/update-term.md b/unison-src/transcripts/update-term.md deleted file mode 100644 index 0fbb55357b..0000000000 --- a/unison-src/transcripts/update-term.md +++ /dev/null @@ -1,22 +0,0 @@ -```ucm -.> builtins.merge -``` - -```unison -foo : Nat -foo = 5 -``` - -```ucm -.> add -``` - -```unison -foo : Nat -foo = 6 -``` - -```ucm -.> update -.> view foo -``` diff --git a/unison-src/transcripts/update-term.output.md b/unison-src/transcripts/update-term.output.md deleted file mode 100644 index 1a641671e5..0000000000 --- a/unison-src/transcripts/update-term.output.md +++ /dev/null @@ -1,65 +0,0 @@ -```ucm -.> builtins.merge - - Done. - -``` -```unison -foo : Nat -foo = 5 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - foo : Nat - -``` -```unison -foo : Nat -foo = 6 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : Nat - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> view foo - - foo : Nat - foo = 6 - -``` diff --git a/unison-src/transcripts/update-test-to-non-test.md b/unison-src/transcripts/update-test-to-non-test.md deleted file mode 100644 index a25ad0d3e2..0000000000 --- a/unison-src/transcripts/update-test-to-non-test.md +++ /dev/null @@ -1,25 +0,0 @@ -```ucm -.> builtins.merge -``` - -```unison -test> foo = [] -``` - -After adding the test `foo`, we expect `view` to render it like a test. (Bug: It doesn't.) - -```ucm -.> add -.> view foo -``` - -```unison -foo = 1 -``` - -After updating `foo` to not be a test, we expect `view` to not render it like a test. - -```ucm -.> update -.> view foo -``` diff --git a/unison-src/transcripts/update-test-to-non-test.output.md b/unison-src/transcripts/update-test-to-non-test.output.md deleted file mode 100644 index a3a016e736..0000000000 --- a/unison-src/transcripts/update-test-to-non-test.output.md +++ /dev/null @@ -1,78 +0,0 @@ -```ucm -.> builtins.merge - - Done. - -``` -```unison -test> foo = [] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - foo : [Result] - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | test> foo = [] - - -``` -After adding the test `foo`, we expect `view` to render it like a test. (Bug: It doesn't.) - -```ucm -.> add - - ⍟ I've added these definitions: - - foo : [Result] - -.> view foo - - foo : [Result] - foo = [] - -``` -```unison -foo = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : Nat - -``` -After updating `foo` to not be a test, we expect `view` to not render it like a test. - -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> view foo - - foo : Nat - foo = 1 - -``` diff --git a/unison-src/transcripts/update-test-watch-roundtrip.md b/unison-src/transcripts/update-test-watch-roundtrip.md deleted file mode 100644 index a3ea386efe..0000000000 --- a/unison-src/transcripts/update-test-watch-roundtrip.md +++ /dev/null @@ -1,28 +0,0 @@ - -```ucm:hide -.> builtins.merge -``` - -Given a test that depends on another definition, - -```unison:hide -foo n = n + 1 - -test> mynamespace.foo.test = - n = 2 - if (foo n) == 2 then [ Ok "passed" ] else [ Fail "wat" ] -``` - -```ucm -.> add -``` - -if we change the type of the dependency, the test should show in the scratch file as a test watch. - -```unison -foo n = "hello, world!" -``` - -```ucm:error -.> update -``` diff --git a/unison-src/transcripts/update-test-watch-roundtrip.output.md b/unison-src/transcripts/update-test-watch-roundtrip.output.md deleted file mode 100644 index b3db6133dd..0000000000 --- a/unison-src/transcripts/update-test-watch-roundtrip.output.md +++ /dev/null @@ -1,61 +0,0 @@ - -Given a test that depends on another definition, - -```unison -foo n = n + 1 - -test> mynamespace.foo.test = - n = 2 - if (foo n) == 2 then [ Ok "passed" ] else [ Fail "wat" ] -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - foo : Nat -> Nat - mynamespace.foo.test : [Result] - -``` -if we change the type of the dependency, the test should show in the scratch file as a test watch. - -```unison -foo n = "hello, world!" -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : n -> Text - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Typechecking failed. I've updated your scratch file with the - definitions that need fixing. Once the file is compiling, try - `update` again. - -``` -```unison:added-by-ucm scratch.u -test> mynamespace.foo.test = - n = 2 - if foo n == 2 then [Ok "passed"] else [Fail "wat"] - -foo n = "hello, world!" -``` - diff --git a/unison-src/transcripts/update-type-add-constructor.md b/unison-src/transcripts/update-type-add-constructor.md deleted file mode 100644 index b801106c24..0000000000 --- a/unison-src/transcripts/update-type-add-constructor.md +++ /dev/null @@ -1,24 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo - = Bar Nat -``` - -```ucm -.> add -``` - -```unison -unique type Foo - = Bar Nat - | Baz Nat Nat -``` - -```ucm -.> update -.> view Foo -.> find.verbose -``` diff --git a/unison-src/transcripts/update-type-add-constructor.output.md b/unison-src/transcripts/update-type-add-constructor.output.md deleted file mode 100644 index d0fb21a382..0000000000 --- a/unison-src/transcripts/update-type-add-constructor.output.md +++ /dev/null @@ -1,72 +0,0 @@ -```unison -unique type Foo - = Bar Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - -``` -```unison -unique type Foo - = Bar Nat - | Baz Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> view Foo - - type Foo = Bar Nat | Baz Nat Nat - -.> find.verbose - - 1. -- #2sffq4apsq1cts53njcunj63fa8ohov4eqn77q14s77ajicajh4g28sq5s5ai33f2k6oh6o67aarnlpu7u7s4la07ag2er33epalsog - type Foo - - 2. -- #2sffq4apsq1cts53njcunj63fa8ohov4eqn77q14s77ajicajh4g28sq5s5ai33f2k6oh6o67aarnlpu7u7s4la07ag2er33epalsog#0 - Foo.Bar : Nat -> Foo - - 3. -- #2sffq4apsq1cts53njcunj63fa8ohov4eqn77q14s77ajicajh4g28sq5s5ai33f2k6oh6o67aarnlpu7u7s4la07ag2er33epalsog#1 - Foo.Baz : Nat -> Nat -> Foo - - - -``` diff --git a/unison-src/transcripts/update-type-add-field.md b/unison-src/transcripts/update-type-add-field.md deleted file mode 100644 index 13a388e1bd..0000000000 --- a/unison-src/transcripts/update-type-add-field.md +++ /dev/null @@ -1,21 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = Bar Nat -``` - -```ucm -.> add -``` - -```unison -unique type Foo = Bar Nat Nat -``` - -```ucm -.> update -.> view Foo -.> find.verbose -``` diff --git a/unison-src/transcripts/update-type-add-field.output.md b/unison-src/transcripts/update-type-add-field.output.md deleted file mode 100644 index 7ee979d64e..0000000000 --- a/unison-src/transcripts/update-type-add-field.output.md +++ /dev/null @@ -1,66 +0,0 @@ -```unison -unique type Foo = Bar Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - -``` -```unison -unique type Foo = Bar Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> view Foo - - type Foo = Bar Nat Nat - -.> find.verbose - - 1. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g - type Foo - - 2. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g#0 - Foo.Bar : Nat -> Nat -> Foo - - - -``` diff --git a/unison-src/transcripts/update-type-add-new-record.md b/unison-src/transcripts/update-type-add-new-record.md deleted file mode 100644 index 0d311ec1e2..0000000000 --- a/unison-src/transcripts/update-type-add-new-record.md +++ /dev/null @@ -1,12 +0,0 @@ -```ucm:hide -.lib> builtins.merge -``` - -```unison -unique type Foo = { bar : Nat } -``` - -```ucm -.> update -.> view Foo -``` diff --git a/unison-src/transcripts/update-type-add-new-record.output.md b/unison-src/transcripts/update-type-add-new-record.output.md deleted file mode 100644 index 8c00d6c1de..0000000000 --- a/unison-src/transcripts/update-type-add-new-record.output.md +++ /dev/null @@ -1,33 +0,0 @@ -```unison -unique type Foo = { bar : Nat } -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - Foo.bar : Foo -> Nat - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.bar.set : Nat -> Foo -> Foo - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> view Foo - - type Foo = { bar : Nat } - -``` diff --git a/unison-src/transcripts/update-type-add-record-field.md b/unison-src/transcripts/update-type-add-record-field.md deleted file mode 100644 index ef5aba3614..0000000000 --- a/unison-src/transcripts/update-type-add-record-field.md +++ /dev/null @@ -1,21 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = { bar : Nat } -``` - -```ucm -.> add -``` - -```unison -unique type Foo = { bar : Nat, baz : Int } -``` - -```ucm -.> update -.> view Foo -.> find.verbose -``` diff --git a/unison-src/transcripts/update-type-add-record-field.output.md b/unison-src/transcripts/update-type-add-record-field.output.md deleted file mode 100644 index 3f52ad6a82..0000000000 --- a/unison-src/transcripts/update-type-add-record-field.output.md +++ /dev/null @@ -1,99 +0,0 @@ -```unison -unique type Foo = { bar : Nat } -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - Foo.bar : Foo -> Nat - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.bar.set : Nat -> Foo -> Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - Foo.bar : Foo -> Nat - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.bar.set : Nat -> Foo -> Foo - -``` -```unison -unique type Foo = { bar : Nat, baz : Int } -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - Foo.baz : Foo -> Int - Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo - Foo.baz.set : Int -> Foo -> Foo - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - Foo.bar : Foo -> Nat - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.bar.set : Nat -> Foo -> Foo - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> view Foo - - type Foo = { bar : Nat, baz : Int } - -.> find.verbose - - 1. -- #05gh1dur4778dauh9slaofprc5356n47qpove0c1jl0birt2fcu301js8auu5vfr5bjfga9j8ikuk07ll9fu1gj3ehrp3basguhsd58 - type Foo - - 2. -- #77mi33dv8ac2s90852khi35km5gsamhnpada8mai0k36obbttgg17qld719ospcs1ht9ctolg3pjsqs6qjnl3hfmu493rgsher73sc0 - Foo.bar : Foo -> Nat - - 3. -- #7m1n2178r5u12jdnb6crcmanu2gm961kdvbjul5m6hta1s57avibsvk6p5g9efut8sennpgstbb8kf97eujbbuiplsoloa4cael7t90 - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - - 4. -- #ghuqoel4pao6v8e7un238i3e86vv7a7pnvgaq8m9s32edm1upgv35gri2iu32ipn9r4poli56r5kr3vtjfrltem696grfl75al4jkgg - Foo.bar.set : Nat -> Foo -> Foo - - 5. -- #p8emkm2s09n3nsd8ne5f6fro0vsldk8pn7n6rcf417anuvvun43qrk1ioofs6pdq4537eosao17c7ibvktktr3lfqglmj26gmbulmj0 - Foo.baz : Foo -> Int - - 6. -- #0il9pl29jpe3fh6vp3qeqai73915k3qffhf4bgttrgsj000b9fgs3bqoj8ugjop6kdr04acc34m1bj7lf417tslfeva7dmmoqdu5hug - Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo - - 7. -- #87rjeqltvvd4adffsheqae62eefoge8p78pvnjdkc9q1stq20lhubvtpos0io4v3vhnol8nn2uollup97l4orq1fh2h12b0imeuuc58 - Foo.baz.set : Int -> Foo -> Foo - - 8. -- #05gh1dur4778dauh9slaofprc5356n47qpove0c1jl0birt2fcu301js8auu5vfr5bjfga9j8ikuk07ll9fu1gj3ehrp3basguhsd58#0 - Foo.Foo : Nat -> Int -> Foo - - - -``` diff --git a/unison-src/transcripts/update-type-constructor-alias.md b/unison-src/transcripts/update-type-constructor-alias.md deleted file mode 100644 index 2d5f97ef25..0000000000 --- a/unison-src/transcripts/update-type-constructor-alias.md +++ /dev/null @@ -1,23 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = Bar Nat -``` - -```ucm -.> add -.> alias.term Foo.Bar Foo.BarAlias -``` - -```unison -unique type Foo = Bar Nat Nat -``` - -Bug: we leave `Foo.BarAlias` in the namespace with a nameless decl. - -```ucm -.> update -.> find.verbose -``` diff --git a/unison-src/transcripts/update-type-constructor-alias.output.md b/unison-src/transcripts/update-type-constructor-alias.output.md deleted file mode 100644 index 44d683227c..0000000000 --- a/unison-src/transcripts/update-type-constructor-alias.output.md +++ /dev/null @@ -1,71 +0,0 @@ -```unison -unique type Foo = Bar Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - -.> alias.term Foo.Bar Foo.BarAlias - - Done. - -``` -```unison -unique type Foo = Bar Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -Bug: we leave `Foo.BarAlias` in the namespace with a nameless decl. - -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> find.verbose - - 1. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g - type Foo - - 2. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g#0 - Foo.Bar : Nat -> Nat -> Foo - - 3. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60#0 - Foo.BarAlias : Nat -> #b509v3eg4k - - - -``` diff --git a/unison-src/transcripts/update-type-delete-constructor-with-dependent.md b/unison-src/transcripts/update-type-delete-constructor-with-dependent.md deleted file mode 100644 index b44cf8a7a7..0000000000 --- a/unison-src/transcripts/update-type-delete-constructor-with-dependent.md +++ /dev/null @@ -1,27 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo - = Bar Nat - | Baz Nat Nat - -foo : Foo -> Nat -foo = cases - Bar n -> n - Baz n m -> n + m -``` - -```ucm -.> add -``` - -```unison -unique type Foo - = Bar Nat -``` - -```ucm:error -.> update -``` diff --git a/unison-src/transcripts/update-type-delete-constructor-with-dependent.output.md b/unison-src/transcripts/update-type-delete-constructor-with-dependent.output.md deleted file mode 100644 index 9966a32418..0000000000 --- a/unison-src/transcripts/update-type-delete-constructor-with-dependent.output.md +++ /dev/null @@ -1,75 +0,0 @@ -```unison -unique type Foo - = Bar Nat - | Baz Nat Nat - -foo : Foo -> Nat -foo = cases - Bar n -> n - Baz n m -> n + m -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - foo : Foo -> Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - foo : Foo -> Nat - -``` -```unison -unique type Foo - = Bar Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Typechecking failed. I've updated your scratch file with the - definitions that need fixing. Once the file is compiling, try - `update` again. - -``` -```unison:added-by-ucm scratch.u -foo : Foo -> Nat -foo = cases - Bar n -> n - Baz n m -> n Nat.+ m - -type Foo = Bar Nat -``` - diff --git a/unison-src/transcripts/update-type-delete-constructor.md b/unison-src/transcripts/update-type-delete-constructor.md deleted file mode 100644 index cf348f690e..0000000000 --- a/unison-src/transcripts/update-type-delete-constructor.md +++ /dev/null @@ -1,24 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo - = Bar Nat - | Baz Nat Nat -``` - -```ucm -.> add -``` - -```unison -unique type Foo - = Bar Nat -``` - -```ucm -.> update -.> view Foo -.> find.verbose -``` diff --git a/unison-src/transcripts/update-type-delete-constructor.output.md b/unison-src/transcripts/update-type-delete-constructor.output.md deleted file mode 100644 index c417d5f15c..0000000000 --- a/unison-src/transcripts/update-type-delete-constructor.output.md +++ /dev/null @@ -1,69 +0,0 @@ -```unison -unique type Foo - = Bar Nat - | Baz Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - -``` -```unison -unique type Foo - = Bar Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> view Foo - - type Foo = Bar Nat - -.> find.verbose - - 1. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60 - type Foo - - 2. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60#0 - Foo.Bar : Nat -> Foo - - - -``` diff --git a/unison-src/transcripts/update-type-delete-record-field.md b/unison-src/transcripts/update-type-delete-record-field.md deleted file mode 100644 index de6396e0c3..0000000000 --- a/unison-src/transcripts/update-type-delete-record-field.md +++ /dev/null @@ -1,23 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = { bar : Nat, baz : Int } -``` - -```ucm -.> add -``` - -```unison -unique type Foo = { bar : Nat } -``` - -We want the field accessors to go away; but for now they are here, causing the update to fail. - -```ucm:error -.> update -.> view Foo -.> find.verbose -``` diff --git a/unison-src/transcripts/update-type-delete-record-field.output.md b/unison-src/transcripts/update-type-delete-record-field.output.md deleted file mode 100644 index a5b570d6d4..0000000000 --- a/unison-src/transcripts/update-type-delete-record-field.output.md +++ /dev/null @@ -1,118 +0,0 @@ -```unison -unique type Foo = { bar : Nat, baz : Int } -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - Foo.bar : Foo -> Nat - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.bar.set : Nat -> Foo -> Foo - Foo.baz : Foo -> Int - Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo - Foo.baz.set : Int -> Foo -> Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - Foo.bar : Foo -> Nat - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.bar.set : Nat -> Foo -> Foo - Foo.baz : Foo -> Int - Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo - Foo.baz.set : Int -> Foo -> Foo - -``` -```unison -unique type Foo = { bar : Nat } -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - Foo.bar : Foo -> Nat - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.bar.set : Nat -> Foo -> Foo - -``` -We want the field accessors to go away; but for now they are here, causing the update to fail. - -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Typechecking failed. I've updated your scratch file with the - definitions that need fixing. Once the file is compiling, try - `update` again. - -.> view Foo - - type Foo = { bar : Nat, baz : Int } - -.> find.verbose - - 1. -- #05gh1dur4778dauh9slaofprc5356n47qpove0c1jl0birt2fcu301js8auu5vfr5bjfga9j8ikuk07ll9fu1gj3ehrp3basguhsd58 - type Foo - - 2. -- #77mi33dv8ac2s90852khi35km5gsamhnpada8mai0k36obbttgg17qld719ospcs1ht9ctolg3pjsqs6qjnl3hfmu493rgsher73sc0 - Foo.bar : Foo -> Nat - - 3. -- #7m1n2178r5u12jdnb6crcmanu2gm961kdvbjul5m6hta1s57avibsvk6p5g9efut8sennpgstbb8kf97eujbbuiplsoloa4cael7t90 - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - - 4. -- #ghuqoel4pao6v8e7un238i3e86vv7a7pnvgaq8m9s32edm1upgv35gri2iu32ipn9r4poli56r5kr3vtjfrltem696grfl75al4jkgg - Foo.bar.set : Nat -> Foo -> Foo - - 5. -- #p8emkm2s09n3nsd8ne5f6fro0vsldk8pn7n6rcf417anuvvun43qrk1ioofs6pdq4537eosao17c7ibvktktr3lfqglmj26gmbulmj0 - Foo.baz : Foo -> Int - - 6. -- #0il9pl29jpe3fh6vp3qeqai73915k3qffhf4bgttrgsj000b9fgs3bqoj8ugjop6kdr04acc34m1bj7lf417tslfeva7dmmoqdu5hug - Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo - - 7. -- #87rjeqltvvd4adffsheqae62eefoge8p78pvnjdkc9q1stq20lhubvtpos0io4v3vhnol8nn2uollup97l4orq1fh2h12b0imeuuc58 - Foo.baz.set : Int -> Foo -> Foo - - 8. -- #05gh1dur4778dauh9slaofprc5356n47qpove0c1jl0birt2fcu301js8auu5vfr5bjfga9j8ikuk07ll9fu1gj3ehrp3basguhsd58#0 - Foo.Foo : Nat -> Int -> Foo - - - -``` -```unison:added-by-ucm scratch.u -Foo.baz : Foo -> Int -Foo.baz = cases Foo _ baz -> baz - -Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo -Foo.baz.modify f = cases Foo bar baz -> Foo bar (f baz) - -Foo.baz.set : Int -> Foo -> Foo -Foo.baz.set baz1 = cases Foo bar _ -> Foo bar baz1 - -type Foo = { bar : Nat } -``` - diff --git a/unison-src/transcripts/update-type-missing-constructor.md b/unison-src/transcripts/update-type-missing-constructor.md deleted file mode 100644 index bfaafa8343..0000000000 --- a/unison-src/transcripts/update-type-missing-constructor.md +++ /dev/null @@ -1,23 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = Bar Nat -``` - -```ucm -.> add -.> delete.term Foo.Bar -``` - -Now we've set up a situation where the original constructor missing. - -```unison -unique type Foo = Bar Nat Nat -``` - -```ucm:error -.> view Foo -.> update -``` diff --git a/unison-src/transcripts/update-type-missing-constructor.output.md b/unison-src/transcripts/update-type-missing-constructor.output.md deleted file mode 100644 index 52ead472eb..0000000000 --- a/unison-src/transcripts/update-type-missing-constructor.output.md +++ /dev/null @@ -1,68 +0,0 @@ -```unison -unique type Foo = Bar Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - -.> delete.term Foo.Bar - - Done. - -``` -Now we've set up a situation where the original constructor missing. - -```unison -unique type Foo = Bar Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -```ucm -.> view Foo - - type Foo = #b509v3eg4k#0 Nat - -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - I couldn't complete the update because the type Foo has - unnamed constructors. (I currently need each constructor to - have a name somewhere under the type name.) - - You can use `view Foo` and - `alias.term Foo.` to give names to - each constructor, and then try the update again. - -``` diff --git a/unison-src/transcripts/update-type-nested-decl-aliases.md b/unison-src/transcripts/update-type-nested-decl-aliases.md deleted file mode 100644 index a51c9a2c16..0000000000 --- a/unison-src/transcripts/update-type-nested-decl-aliases.md +++ /dev/null @@ -1,26 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = Bar Nat - -structural type A.B = OneAlias Foo -structural type A = B.TheOtherAlias Foo -``` - -```ucm -.> add -``` - -```unison -unique type Foo = Bar Nat Nat -``` - -Bug: we want this update to be rejected earlier, because it violates the "decl coherency" precondition that there's -only one name for each constructor. We instead get too far in the update process, and are delivered a bogus scratch.u -file to stare at. - -```ucm:error -.> update -``` diff --git a/unison-src/transcripts/update-type-nested-decl-aliases.output.md b/unison-src/transcripts/update-type-nested-decl-aliases.output.md deleted file mode 100644 index 0b373c88cd..0000000000 --- a/unison-src/transcripts/update-type-nested-decl-aliases.output.md +++ /dev/null @@ -1,75 +0,0 @@ -```unison -unique type Foo = Bar Nat - -structural type A.B = OneAlias Foo -structural type A = B.TheOtherAlias Foo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type A - structural type A.B - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - structural type A - structural type A.B - type Foo - -``` -```unison -unique type Foo = Bar Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -Bug: we want this update to be rejected earlier, because it violates the "decl coherency" precondition that there's -only one name for each constructor. We instead get too far in the update process, and are delivered a bogus scratch.u -file to stare at. - -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Typechecking failed. I've updated your scratch file with the - definitions that need fixing. Once the file is compiling, try - `update` again. - -``` -```unison:added-by-ucm scratch.u -structural type A = B.OneAlias Foo - -structural type A.B = OneAlias Foo - -type Foo = Bar Nat Nat -``` - diff --git a/unison-src/transcripts/update-type-no-op-record.md b/unison-src/transcripts/update-type-no-op-record.md deleted file mode 100644 index 50a559819a..0000000000 --- a/unison-src/transcripts/update-type-no-op-record.md +++ /dev/null @@ -1,17 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = { bar : Nat } -``` - -```ucm -.> add -``` - -Bug: this no-op update should (of course) succeed. - -```ucm -.> update -``` diff --git a/unison-src/transcripts/update-type-no-op-record.output.md b/unison-src/transcripts/update-type-no-op-record.output.md deleted file mode 100644 index 1a7e55eb74..0000000000 --- a/unison-src/transcripts/update-type-no-op-record.output.md +++ /dev/null @@ -1,42 +0,0 @@ -```unison -unique type Foo = { bar : Nat } -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - Foo.bar : Foo -> Nat - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.bar.set : Nat -> Foo -> Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - Foo.bar : Foo -> Nat - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.bar.set : Nat -> Foo -> Foo - -``` -Bug: this no-op update should (of course) succeed. - -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -``` diff --git a/unison-src/transcripts/update-type-stray-constructor-alias.md b/unison-src/transcripts/update-type-stray-constructor-alias.md deleted file mode 100644 index 847a37e32d..0000000000 --- a/unison-src/transcripts/update-type-stray-constructor-alias.md +++ /dev/null @@ -1,23 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = Bar Nat -``` - -```ucm -.> add -.> alias.term Foo.Bar Stray.BarAlias -``` - -```unison -unique type Foo = Bar Nat Nat -``` - -Bug: we leave `Stray.BarAlias` in the namespace with a nameless decl. - -```ucm -.> update -.> find.verbose -``` diff --git a/unison-src/transcripts/update-type-stray-constructor-alias.output.md b/unison-src/transcripts/update-type-stray-constructor-alias.output.md deleted file mode 100644 index e9fe5f9662..0000000000 --- a/unison-src/transcripts/update-type-stray-constructor-alias.output.md +++ /dev/null @@ -1,71 +0,0 @@ -```unison -unique type Foo = Bar Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - -.> alias.term Foo.Bar Stray.BarAlias - - Done. - -``` -```unison -unique type Foo = Bar Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -Bug: we leave `Stray.BarAlias` in the namespace with a nameless decl. - -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> find.verbose - - 1. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g - type Foo - - 2. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g#0 - Foo.Bar : Nat -> Nat -> Foo - - 3. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60#0 - Stray.BarAlias : Nat -> #b509v3eg4k - - - -``` diff --git a/unison-src/transcripts/update-type-stray-constructor.md b/unison-src/transcripts/update-type-stray-constructor.md deleted file mode 100644 index 183818e564..0000000000 --- a/unison-src/transcripts/update-type-stray-constructor.md +++ /dev/null @@ -1,25 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = Bar Nat -``` - -```ucm -.> add -.> move.term Foo.Bar Stray.Bar -``` - -Now we've set up a situation where the constructor is not where it's supposed to be; it's somewhere else. - -```unison -unique type Foo = Bar Nat Nat -``` - -Note that the constructor name shown here (implied to be called `Foo.Stray.Bar`) doesn't really exist, it's just showing up due to a pretty-printer bug. - -```ucm:error -.> view Foo -.> update -``` diff --git a/unison-src/transcripts/update-type-stray-constructor.output.md b/unison-src/transcripts/update-type-stray-constructor.output.md deleted file mode 100644 index 8f72beefd3..0000000000 --- a/unison-src/transcripts/update-type-stray-constructor.output.md +++ /dev/null @@ -1,70 +0,0 @@ -```unison -unique type Foo = Bar Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - -.> move.term Foo.Bar Stray.Bar - - Done. - -``` -Now we've set up a situation where the constructor is not where it's supposed to be; it's somewhere else. - -```unison -unique type Foo = Bar Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -Note that the constructor name shown here (implied to be called `Foo.Stray.Bar`) doesn't really exist, it's just showing up due to a pretty-printer bug. - -```ucm -.> view Foo - - type Foo = Stray.Bar Nat - -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - I couldn't complete the update because the type Foo has - unnamed constructors. (I currently need each constructor to - have a name somewhere under the type name.) - - You can use `view Foo` and - `alias.term Foo.` to give names to - each constructor, and then try the update again. - -``` diff --git a/unison-src/transcripts/update-type-turn-constructor-into-smart-constructor.md b/unison-src/transcripts/update-type-turn-constructor-into-smart-constructor.md deleted file mode 100644 index 1debc0aaf3..0000000000 --- a/unison-src/transcripts/update-type-turn-constructor-into-smart-constructor.md +++ /dev/null @@ -1,27 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = Bar Nat - -makeFoo : Nat -> Foo -makeFoo n = Bar (n+10) -``` - -```ucm -.> add -``` - -```unison -unique type Foo = internal.Bar Nat - -Foo.Bar : Nat -> Foo -Foo.Bar n = internal.Bar n -``` - -```ucm -.> update -.> view Foo -.> find.verbose -``` diff --git a/unison-src/transcripts/update-type-turn-constructor-into-smart-constructor.output.md b/unison-src/transcripts/update-type-turn-constructor-into-smart-constructor.output.md deleted file mode 100644 index a28e27e747..0000000000 --- a/unison-src/transcripts/update-type-turn-constructor-into-smart-constructor.output.md +++ /dev/null @@ -1,85 +0,0 @@ -```unison -unique type Foo = Bar Nat - -makeFoo : Nat -> Foo -makeFoo n = Bar (n+10) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - makeFoo : Nat -> Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - makeFoo : Nat -> Foo - -``` -```unison -unique type Foo = internal.Bar Nat - -Foo.Bar : Nat -> Foo -Foo.Bar n = internal.Bar n -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⊡ Previously added definitions will be ignored: Foo - - ⍟ These new definitions are ok to `add`: - - Foo.Bar : Nat -> Foo - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Everything typechecks, so I'm saving the results... - - Done. - -.> view Foo - - type Foo = internal.Bar Nat - -.> find.verbose - - 1. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60 - type Foo - - 2. -- #36rn6jqt1k5jccb3c7vagp3jam74dngr92kgcntqhs6dbkua54verfert2i6hsku6uitt9s2jvt1msric0tgemal52d5apav6akn25o - Foo.Bar : Nat -> Foo - - 3. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60#0 - Foo.internal.Bar : Nat -> Foo - - 4. -- #204frdcl0iid1ujkkfbkc6b3v7cgqp56h1q3duc46i5md6qb4m6am1fqbceb335u87l05gkdnaa7fjn4alj1diukgme63e41lh072l8 - makeFoo : Nat -> Foo - - - -``` diff --git a/unison-src/transcripts/update-type-turn-non-record-into-record.md b/unison-src/transcripts/update-type-turn-non-record-into-record.md deleted file mode 100644 index b570aa5f7e..0000000000 --- a/unison-src/transcripts/update-type-turn-non-record-into-record.md +++ /dev/null @@ -1,21 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = Nat -``` - -```ucm -.> add -``` - -```unison -unique type Foo = { bar : Nat } -``` - -```ucm -.> update -.> view Foo -.> find.verbose -``` diff --git a/unison-src/transcripts/update-type-turn-non-record-into-record.output.md b/unison-src/transcripts/update-type-turn-non-record-into-record.output.md deleted file mode 100644 index f23ab09cd5..0000000000 --- a/unison-src/transcripts/update-type-turn-non-record-into-record.output.md +++ /dev/null @@ -1,81 +0,0 @@ -```unison -unique type Foo = Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - -``` -```unison -unique type Foo = { bar : Nat } -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - Foo.bar : Foo -> Nat - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - Foo.bar.set : Nat -> Foo -> Foo - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -.> view Foo - - type Foo = { bar : Nat } - -.> find.verbose - - 1. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60 - type Foo - - 2. -- #ovhevqfin94qhq5fu0mujfi20mbpvg5mh4vsfklrohp84cch4lhvrn5p29cnbsqfm92l7bt8c1vpjooh72a0psbddvvten4gq2sipag - Foo.bar : Foo -> Nat - - 3. -- #as72md2u70e0u9s2ig2ug7jvlbrk1mubo8qlfokpuvgusg35svh05r7nsj27sqo5edeghjnk8g8259fi4ismse736v4n5ojrb3o2le8 - Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - - 4. -- #5cbctoor75nbtn4ppp10qm1i25gqt2lgth3itqa0lloib32je4ijfj2n3qcdfhmdcnbgum2jg46opntlohv7ladun3dmefl1ucgobeg - Foo.bar.set : Nat -> Foo -> Foo - - 5. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60#0 - Foo.Foo : Nat -> Foo - - - -``` diff --git a/unison-src/transcripts/update-type-with-dependent-term.md b/unison-src/transcripts/update-type-with-dependent-term.md deleted file mode 100644 index 99bfcceac4..0000000000 --- a/unison-src/transcripts/update-type-with-dependent-term.md +++ /dev/null @@ -1,22 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = Bar Nat - -incrFoo : Foo -> Foo -incrFoo = cases Bar n -> Bar (n+1) -``` - -```ucm -.> add -``` - -```unison -unique type Foo = Bar Nat Nat -``` - -```ucm:error -.> update -``` diff --git a/unison-src/transcripts/update-type-with-dependent-term.output.md b/unison-src/transcripts/update-type-with-dependent-term.output.md deleted file mode 100644 index e8837eb523..0000000000 --- a/unison-src/transcripts/update-type-with-dependent-term.output.md +++ /dev/null @@ -1,68 +0,0 @@ -```unison -unique type Foo = Bar Nat - -incrFoo : Foo -> Foo -incrFoo = cases Bar n -> Bar (n+1) -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - incrFoo : Foo -> Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - incrFoo : Foo -> Foo - -``` -```unison -unique type Foo = Bar Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Typechecking failed. I've updated your scratch file with the - definitions that need fixing. Once the file is compiling, try - `update` again. - -``` -```unison:added-by-ucm scratch.u -incrFoo : Foo -> Foo -incrFoo = cases Bar n -> Bar (n Nat.+ 1) - -type Foo = Bar Nat Nat -``` - diff --git a/unison-src/transcripts/update-type-with-dependent-type-to-different-kind.md b/unison-src/transcripts/update-type-with-dependent-type-to-different-kind.md deleted file mode 100644 index 7c5a5018b2..0000000000 --- a/unison-src/transcripts/update-type-with-dependent-type-to-different-kind.md +++ /dev/null @@ -1,20 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = Bar Nat -unique type Baz = Qux Foo -``` - -```ucm -.> add -``` - -```unison -unique type Foo a = Bar Nat a -``` - -```ucm:error -.> update -``` diff --git a/unison-src/transcripts/update-type-with-dependent-type-to-different-kind.output.md b/unison-src/transcripts/update-type-with-dependent-type-to-different-kind.output.md deleted file mode 100644 index e105b39ea2..0000000000 --- a/unison-src/transcripts/update-type-with-dependent-type-to-different-kind.output.md +++ /dev/null @@ -1,65 +0,0 @@ -```unison -unique type Foo = Bar Nat -unique type Baz = Qux Foo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Baz - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Baz - type Foo - -``` -```unison -unique type Foo a = Bar Nat a -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo a - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Typechecking failed. I've updated your scratch file with the - definitions that need fixing. Once the file is compiling, try - `update` again. - -``` -```unison:added-by-ucm scratch.u -type Baz = Qux Foo - -type Foo a = Bar Nat a -``` - diff --git a/unison-src/transcripts/update-type-with-dependent-type.md b/unison-src/transcripts/update-type-with-dependent-type.md deleted file mode 100644 index 7dea367322..0000000000 --- a/unison-src/transcripts/update-type-with-dependent-type.md +++ /dev/null @@ -1,23 +0,0 @@ -```ucm:hide -.> builtins.merge lib.builtin -``` - -```unison -unique type Foo = Bar Nat -unique type Baz = Qux Foo -``` - -```ucm -.> add -``` - -```unison -unique type Foo = Bar Nat Nat -``` - -```ucm -.> update -.> view Foo -.> view Baz -.> find.verbose -``` diff --git a/unison-src/transcripts/update-type-with-dependent-type.output.md b/unison-src/transcripts/update-type-with-dependent-type.output.md deleted file mode 100644 index 47988e1ffd..0000000000 --- a/unison-src/transcripts/update-type-with-dependent-type.output.md +++ /dev/null @@ -1,83 +0,0 @@ -```unison -unique type Foo = Bar Nat -unique type Baz = Qux Foo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Baz - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Baz - type Foo - -``` -```unison -unique type Foo = Bar Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - That's done. Now I'm making sure everything typechecks... - - Everything typechecks, so I'm saving the results... - - Done. - -.> view Foo - - type Foo = Bar Nat Nat - -.> view Baz - - type Baz = Qux Foo - -.> find.verbose - - 1. -- #34msh9satlfog576493eo9pkjn6aj7d8fj6jfheglvgr5s39iptb81649bpkad1lqraheqb8em9ms551k01oternhknc4m7jicgtk08 - type Baz - - 2. -- #34msh9satlfog576493eo9pkjn6aj7d8fj6jfheglvgr5s39iptb81649bpkad1lqraheqb8em9ms551k01oternhknc4m7jicgtk08#0 - Baz.Qux : Foo -> Baz - - 3. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g - type Foo - - 4. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g#0 - Foo.Bar : Nat -> Nat -> Foo - - - -``` diff --git a/unison-src/transcripts/update-watch.md b/unison-src/transcripts/update-watch.md deleted file mode 100644 index 6637515ff6..0000000000 --- a/unison-src/transcripts/update-watch.md +++ /dev/null @@ -1,7 +0,0 @@ -```unison -> 1 -``` - -```ucm -.> update -``` diff --git a/unison-src/transcripts/update-watch.output.md b/unison-src/transcripts/update-watch.output.md deleted file mode 100644 index e97d32f9ef..0000000000 --- a/unison-src/transcripts/update-watch.output.md +++ /dev/null @@ -1,29 +0,0 @@ -```unison -> 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > 1 - ⧩ - 1 - -``` -```ucm -.> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -``` diff --git a/unison-src/transcripts/upgrade-happy-path.md b/unison-src/transcripts/upgrade-happy-path.md deleted file mode 100644 index 068c8ccf1c..0000000000 --- a/unison-src/transcripts/upgrade-happy-path.md +++ /dev/null @@ -1,28 +0,0 @@ -```ucm:hide -proj/main> builtins.merge lib.builtin -``` - -```unison -lib.old.foo = 17 -lib.new.foo = 18 -thingy = lib.old.foo + 10 -``` - - -```ucm -proj/main> add -``` - -Test tab completion and fzf options of upgrade command. - -```ucm -proj/main> debug.tab-complete upgrade ol -proj/main> debug.fuzzy-options upgrade _ -proj/main> debug.fuzzy-options upgrade old _ -``` - -```ucm -proj/main> upgrade old new -proj/main> ls lib -proj/main> view thingy -``` diff --git a/unison-src/transcripts/upgrade-happy-path.output.md b/unison-src/transcripts/upgrade-happy-path.output.md deleted file mode 100644 index b2d8bb80a6..0000000000 --- a/unison-src/transcripts/upgrade-happy-path.output.md +++ /dev/null @@ -1,71 +0,0 @@ -```unison -lib.old.foo = 17 -lib.new.foo = 18 -thingy = lib.old.foo + 10 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - lib.new.foo : Nat - lib.old.foo : Nat - thingy : Nat - -``` -```ucm -proj/main> add - - ⍟ I've added these definitions: - - lib.new.foo : Nat - lib.old.foo : Nat - thingy : Nat - -``` -Test tab completion and fzf options of upgrade command. - -```ucm -proj/main> debug.tab-complete upgrade ol - - old - -proj/main> debug.fuzzy-options upgrade _ - - Select a dependency to upgrade: - * builtin - * new - * old - -proj/main> debug.fuzzy-options upgrade old _ - - Select a dependency to upgrade to: - * builtin - * new - * old - -``` -```ucm -proj/main> upgrade old new - - I upgraded old to new, and removed old. - -proj/main> ls lib - - 1. builtin/ (469 terms, 74 types) - 2. new/ (1 term) - -proj/main> view thingy - - thingy : Nat - thingy = - use Nat + - foo + 10 - -``` diff --git a/unison-src/transcripts/upgrade-sad-path.md b/unison-src/transcripts/upgrade-sad-path.md deleted file mode 100644 index c2c1fe459a..0000000000 --- a/unison-src/transcripts/upgrade-sad-path.md +++ /dev/null @@ -1,31 +0,0 @@ -```ucm:hide -proj/main> builtins.merge lib.builtin -``` - -```unison -lib.old.foo = 17 -lib.new.foo = +18 -thingy = lib.old.foo + 10 -``` - -```ucm -proj/main> add -``` - -```ucm:error -proj/main> upgrade old new -``` - -Resolve the error and commit the upgrade. - -```unison -thingy = foo + +10 -``` - -```ucm -proj/upgrade-old-to-new> update -proj/upgrade-old-to-new> upgrade.commit -proj/main> view thingy -proj/main> ls lib -proj/main> branches -``` diff --git a/unison-src/transcripts/upgrade-sad-path.output.md b/unison-src/transcripts/upgrade-sad-path.output.md deleted file mode 100644 index f0811cd8ee..0000000000 --- a/unison-src/transcripts/upgrade-sad-path.output.md +++ /dev/null @@ -1,108 +0,0 @@ -```unison -lib.old.foo = 17 -lib.new.foo = +18 -thingy = lib.old.foo + 10 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - lib.new.foo : Int - lib.old.foo : Nat - thingy : Nat - -``` -```ucm -proj/main> add - - ⍟ I've added these definitions: - - lib.new.foo : Int - lib.old.foo : Nat - thingy : Nat - -``` -```ucm -proj/main> upgrade old new - - I couldn't automatically upgrade old to new. However, I've - added the definitions that need attention to the top of - scratch.u. - - When you're done, you can run - - upgrade.commit - - to merge your changes back into main and delete the temporary - branch. Or, if you decide to cancel the upgrade instead, you - can run - - delete.branch /upgrade-old-to-new - - to delete the temporary branch and switch back to main. - -``` -```unison:added-by-ucm scratch.u -thingy : Nat -thingy = - use Nat + - foo + 10 -``` - -Resolve the error and commit the upgrade. - -```unison -thingy = foo + +10 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - thingy : Int - -``` -```ucm -proj/upgrade-old-to-new> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -proj/upgrade-old-to-new> upgrade.commit - - I fast-forward merged proj/upgrade-old-to-new into proj/main. - -proj/main> view thingy - - thingy : Int - thingy = - use Int + - foo + +10 - -proj/main> ls lib - - 1. builtin/ (469 terms, 74 types) - 2. new/ (1 term) - -proj/main> branches - - Branch Remote branch - 1. main - -``` diff --git a/unison-src/transcripts/upgrade-suffixifies-properly.md b/unison-src/transcripts/upgrade-suffixifies-properly.md deleted file mode 100644 index 08c4b002d9..0000000000 --- a/unison-src/transcripts/upgrade-suffixifies-properly.md +++ /dev/null @@ -1,21 +0,0 @@ -```ucm:hide -myproject/main> builtins.merge lib.builtin -``` - -```unison -lib.old.foo = 25 -lib.new.foo = +30 -a.x.x.x.x = 100 -b.x.x.x.x = 100 -c.y.y.y.y = lib.old.foo + 10 -d.y.y.y.y = lib.old.foo + 10 -bar = a.x.x.x.x + c.y.y.y.y -``` - -```ucm -myproject/main> add -``` - -```ucm:error -myproject/main> upgrade old new -``` diff --git a/unison-src/transcripts/upgrade-suffixifies-properly.output.md b/unison-src/transcripts/upgrade-suffixifies-properly.output.md deleted file mode 100644 index 4b7b313199..0000000000 --- a/unison-src/transcripts/upgrade-suffixifies-properly.output.md +++ /dev/null @@ -1,80 +0,0 @@ -```unison -lib.old.foo = 25 -lib.new.foo = +30 -a.x.x.x.x = 100 -b.x.x.x.x = 100 -c.y.y.y.y = lib.old.foo + 10 -d.y.y.y.y = lib.old.foo + 10 -bar = a.x.x.x.x + c.y.y.y.y -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - a.x.x.x.x : Nat - b.x.x.x.x : Nat - bar : Nat - c.y.y.y.y : Nat - d.y.y.y.y : Nat - lib.new.foo : Int - lib.old.foo : Nat - -``` -```ucm -myproject/main> add - - ⍟ I've added these definitions: - - a.x.x.x.x : Nat - b.x.x.x.x : Nat - bar : Nat - c.y.y.y.y : Nat - d.y.y.y.y : Nat - lib.new.foo : Int - lib.old.foo : Nat - -``` -```ucm -myproject/main> upgrade old new - - I couldn't automatically upgrade old to new. However, I've - added the definitions that need attention to the top of - scratch.u. - - When you're done, you can run - - upgrade.commit - - to merge your changes back into main and delete the temporary - branch. Or, if you decide to cancel the upgrade instead, you - can run - - delete.branch /upgrade-old-to-new - - to delete the temporary branch and switch back to main. - -``` -```unison:added-by-ucm scratch.u -bar : Nat -bar = - use Nat + - x + c.y.y.y.y - -c.y.y.y.y : Nat -c.y.y.y.y = - use Nat + - foo + 10 - -d.y.y.y.y : Nat -d.y.y.y.y = - use Nat + - foo + 10 -``` - diff --git a/unison-src/transcripts/upgrade-with-old-alias.md b/unison-src/transcripts/upgrade-with-old-alias.md deleted file mode 100644 index aeb818947e..0000000000 --- a/unison-src/transcripts/upgrade-with-old-alias.md +++ /dev/null @@ -1,17 +0,0 @@ -```ucm:hide -myproject/main> builtins.merge lib.builtin -``` - -```unison -lib.old.foo = 141 -lib.new.foo = 142 -bar = 141 -mything = lib.old.foo + 100 -``` - -```ucm -myproject/main> update -myproject/main> upgrade old new -myproject/main> view mything -myproject/main> view bar -``` diff --git a/unison-src/transcripts/upgrade-with-old-alias.output.md b/unison-src/transcripts/upgrade-with-old-alias.output.md deleted file mode 100644 index 9fdea6d7bd..0000000000 --- a/unison-src/transcripts/upgrade-with-old-alias.output.md +++ /dev/null @@ -1,48 +0,0 @@ -```unison -lib.old.foo = 141 -lib.new.foo = 142 -bar = 141 -mything = lib.old.foo + 100 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - bar : Nat - lib.new.foo : Nat - lib.old.foo : Nat - mything : Nat - -``` -```ucm -myproject/main> update - - Okay, I'm searching the branch for code that needs to be - updated... - - Done. - -myproject/main> upgrade old new - - I upgraded old to new, and removed old. - -myproject/main> view mything - - mything : Nat - mything = - use Nat + - foo + 100 - -myproject/main> view bar - - bar : Nat - bar = 141 - -``` diff --git a/unison-src/transcripts/view.md b/unison-src/transcripts/view.md deleted file mode 100644 index 89b81cf51f..0000000000 --- a/unison-src/transcripts/view.md +++ /dev/null @@ -1,25 +0,0 @@ -# View commands - -```ucm:hide -.> builtins.merge -``` - -```unison:hide -a.thing = "a" -b.thing = "b" -``` - -```ucm:hide -.> add -``` - -```ucm --- Should suffix-search and find values in sub-namespaces -.> view thing --- Should be local to namespace -.a> view thing --- view.global should search globally and be absolutely qualified -.a> view.global thing --- Should support absolute paths outside of current namespace -.a> view .b.thing -``` diff --git a/unison-src/transcripts/view.output.md b/unison-src/transcripts/view.output.md deleted file mode 100644 index 71ebf98da7..0000000000 --- a/unison-src/transcripts/view.output.md +++ /dev/null @@ -1,39 +0,0 @@ -# View commands - -```unison -a.thing = "a" -b.thing = "b" -``` - -```ucm --- Should suffix-search and find values in sub-namespaces -.> view thing - - a.thing : Text - a.thing = "a" - - b.thing : Text - b.thing = "b" - --- Should be local to namespace -.a> view thing - - thing : ##Text - thing = "a" - --- view.global should search globally and be absolutely qualified -.a> view.global thing - - .a.thing : Text - .a.thing = "a" - - .b.thing : Text - .b.thing = "b" - --- Should support absolute paths outside of current namespace -.a> view .b.thing - - .b.thing : Text - .b.thing = "b" - -``` diff --git a/unison-src/transcripts/watch-expressions.md b/unison-src/transcripts/watch-expressions.md deleted file mode 100644 index e17d789a55..0000000000 --- a/unison-src/transcripts/watch-expressions.md +++ /dev/null @@ -1,25 +0,0 @@ -```ucm -.> builtins.mergeio -``` - -```unison -test> pass = [Ok "Passed"] -``` - -```ucm -.> add -``` - -```unison -test> pass = [Ok "Passed"] -``` - -```ucm -.> add -.> test -``` - -```unison -> ImmutableArray.fromList [?a, ?b, ?c] -> ImmutableByteArray.fromBytes 0xs123456 -``` diff --git a/unison-src/transcripts/watch-expressions.output.md b/unison-src/transcripts/watch-expressions.output.md deleted file mode 100644 index 3a12bbcac7..0000000000 --- a/unison-src/transcripts/watch-expressions.output.md +++ /dev/null @@ -1,98 +0,0 @@ -```ucm -.> builtins.mergeio - - Done. - -``` -```unison -test> pass = [Ok "Passed"] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - pass : [Result] - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | test> pass = [Ok "Passed"] - - ✅ Passed Passed - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - pass : [Result] - -``` -```unison -test> pass = [Ok "Passed"] -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked the definitions in scratch.u. This - file has been previously added to the codebase. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | test> pass = [Ok "Passed"] - - ✅ Passed Passed (cached) - -``` -```ucm -.> add - - ⊡ Ignored previously added definitions: pass - -.> test - - Cached test results (`help testcache` to learn more) - - ◉ pass Passed - - ✅ 1 test(s) passing - - Tip: Use view pass to view the source of a test. - -``` -```unison -> ImmutableArray.fromList [?a, ?b, ?c] -> ImmutableByteArray.fromBytes 0xs123456 -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > ImmutableArray.fromList [?a, ?b, ?c] - ⧩ - ImmutableArray.fromList [?a, ?b, ?c] - - 2 | > ImmutableByteArray.fromBytes 0xs123456 - ⧩ - fromBytes 0xs123456 - -``` diff --git a/unison-syntax/package.yaml b/unison-syntax/package.yaml index 8e1a478baf..0742346f40 100644 --- a/unison-syntax/package.yaml +++ b/unison-syntax/package.yaml @@ -4,40 +4,48 @@ copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors ghc-options: -Wall -dependencies: - - base - - bytes - - containers - - cryptonite - - extra - - lens - - megaparsec - - mtl - - parser-combinators - - text - - text-builder - - unison-core - - unison-core1 - - unison-hash - - unison-prelude - - unison-util-base32hex - - unison-util-bytes - library: source-dirs: src when: - condition: false other-modules: Paths_unison_syntax + dependencies: + - base + - bytes + - containers + - cryptonite + - deriving-compat + - extra + - free + - lens + - megaparsec + - mtl + - parser-combinators + - text + - unison-core + - unison-core1 + - unison-hash + - unison-prelude + - unison-util-base32hex + - unison-util-bytes + tests: syntax-tests: when: - condition: false other-modules: Paths_unison_syntax dependencies: + - base - code-page - easytest + - free + - megaparsec + - unison-core1 + - unison-prelude - unison-syntax + - unison-util-recursion + - text main: Main.hs source-dirs: test diff --git a/unison-syntax/src/Unison/Lexer/Pos.hs b/unison-syntax/src/Unison/Lexer/Pos.hs index b3297b9221..e78bb61c88 100644 --- a/unison-syntax/src/Unison/Lexer/Pos.hs +++ b/unison-syntax/src/Unison/Lexer/Pos.hs @@ -4,21 +4,13 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -module Unison.Lexer.Pos (Pos (..), Line, Column, line, column) where +module Unison.Lexer.Pos (Pos (..), Line, Column) where type Line = Int type Column = Int -data Pos = Pos {-# UNPACK #-} !Line {-# UNPACK #-} !Column deriving (Eq, Ord) - -line :: Pos -> Line -line (Pos line _) = line - -column :: Pos -> Column -column (Pos _ column) = column - -instance Show Pos where show (Pos line col) = "line " <> show line <> ", column " <> show col +data Pos = Pos {line :: {-# UNPACK #-} !Line, column :: {-# UNPACK #-} !Column} deriving (Show, Eq, Ord) instance Semigroup Pos where Pos line col <> Pos line2 col2 = diff --git a/unison-syntax/src/Unison/Parser/Ann.hs b/unison-syntax/src/Unison/Parser/Ann.hs index feec96279c..1b73adeaf6 100644 --- a/unison-syntax/src/Unison/Parser/Ann.hs +++ b/unison-syntax/src/Unison/Parser/Ann.hs @@ -4,7 +4,11 @@ module Unison.Parser.Ann where +import Control.Comonad.Cofree (Cofree ((:<))) +import Data.List.NonEmpty (NonEmpty) +import Data.Void (absurd) import Unison.Lexer.Pos qualified as L +import Unison.Prelude data Ann = -- Used for things like Builtins which don't have a source position. @@ -25,6 +29,7 @@ startingLine _ = Nothing instance Monoid Ann where mempty = External +-- | This instance is commutative. instance Semigroup Ann where Ann s1 e1 <> Ann s2 e2 = Ann (min s1 s2) (max e1 e2) -- If we have a concrete location from a file, use it @@ -79,3 +84,24 @@ encompasses (GeneratedFrom ann) other = encompasses ann other encompasses ann (GeneratedFrom other) = encompasses ann other encompasses (Ann start1 end1) (Ann start2 end2) = Just $ start1 <= start2 && end1 >= end2 + +class Annotated a where + ann :: a -> Ann + +instance Annotated Ann where + ann = id + +instance (Annotated a) => Annotated [a] where + ann = foldMap ann + +instance (Annotated a) => Annotated (NonEmpty a) where + ann = foldMap ann + +instance (Annotated a) => Annotated (Maybe a) where + ann = foldMap ann + +instance Annotated Void where + ann = absurd + +instance (Annotated a) => Annotated (Cofree f a) where + ann (a :< _) = ann a diff --git a/unison-syntax/src/Unison/Syntax/HashQualified'.hs b/unison-syntax/src/Unison/Syntax/HashQualified'.hs deleted file mode 100644 index 56fb96304b..0000000000 --- a/unison-syntax/src/Unison/Syntax/HashQualified'.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Syntax-related combinators for HashQualified' (to/from string types). -module Unison.Syntax.HashQualified' - ( -- * String conversions - parseText, - unsafeParseText, - toText, - - -- * Parsers - hashQualifiedP, - ) -where - -import Data.Text qualified as Text -import Text.Megaparsec (ParsecT) -import Text.Megaparsec qualified as P -import Text.Megaparsec.Internal qualified as P (withParsecT) -import Unison.HashQualified' qualified as HQ' -import Unison.Name (Name, Parse) -import Unison.Name qualified as Name -import Unison.Prelude hiding (fromString) -import Unison.Syntax.Lexer.Token (Token) -import Unison.Syntax.Name qualified as Name (nameP, toText) -import Unison.Syntax.NameSegment qualified as NameSegment -import Unison.Syntax.ShortHash qualified as ShortHash (shortHashP) - -instance Parse Text (HQ'.HashQualified Name) where - parse = parseText - ------------------------------------------------------------------------------------------------------------------------- --- String conversions - -parseText :: Text -> Maybe (HQ'.HashQualified Name) -parseText text = - eitherToMaybe (P.runParser parser "" (Text.unpack text)) - where - parser = - hashQualifiedP (P.withParsecT (fmap NameSegment.renderParseErr) Name.nameP) <* P.eof - -unsafeParseText :: (HasCallStack) => Text -> HQ'.HashQualified Name -unsafeParseText txt = fromMaybe msg (parseText txt) - where - msg = error ("HashQualified.unsafeFromText " <> show txt) - -toText :: HQ'.HashQualified Name -> Text -toText = - HQ'.toTextWith Name.toText - ------------------------------------------------------------------------------------------------------------------------- --- Hash-qualified parsers - --- | A hash-qualified parser. -hashQualifiedP :: - Monad m => - ParsecT (Token Text) [Char] m name -> - ParsecT (Token Text) [Char] m (HQ'.HashQualified name) -hashQualifiedP nameP = - P.try do - name <- nameP - optional ShortHash.shortHashP <&> \case - Nothing -> HQ'.NameOnly name - Just hash -> HQ'.HashQualified name hash diff --git a/unison-syntax/src/Unison/Syntax/HashQualified.hs b/unison-syntax/src/Unison/Syntax/HashQualified.hs index cb7175555a..9cc25f61cc 100644 --- a/unison-syntax/src/Unison/Syntax/HashQualified.hs +++ b/unison-syntax/src/Unison/Syntax/HashQualified.hs @@ -21,11 +21,10 @@ import Text.Megaparsec qualified as P import Text.Megaparsec.Internal qualified as P (withParsecT) import Unison.HashQualified (HashQualified (..)) import Unison.HashQualified qualified as HashQualified -import Unison.HashQualified' qualified as HQ' -import Unison.Name (Name, Parse) -import Unison.Name qualified as Name +import Unison.HashQualifiedPrime qualified as HQ' +import Unison.Name (Name) import Unison.Prelude hiding (fromString) -import Unison.Syntax.HashQualified' qualified as HQ' +import Unison.Syntax.HashQualifiedPrime qualified as HQ' import Unison.Syntax.Lexer.Token (Token) import Unison.Syntax.Name qualified as Name (nameP, toText) import Unison.Syntax.NameSegment qualified as NameSegment @@ -34,9 +33,6 @@ import Unison.Var (Var) import Unison.Var qualified as Var import Prelude hiding (take) -instance Parse Text (HashQualified Name) where - parse = parseText - parseText :: Text -> Maybe (HashQualified Name) parseText text = eitherToMaybe (P.runParser parser "" (Text.unpack text)) @@ -70,7 +66,7 @@ toVar = -- | A hash-qualified parser. hashQualifiedP :: - Monad m => + (Monad m) => ParsecT (Token Text) [Char] m name -> ParsecT (Token Text) [Char] m (HashQualified name) hashQualifiedP nameP = diff --git a/unison-syntax/src/Unison/Syntax/HashQualifiedPrime.hs b/unison-syntax/src/Unison/Syntax/HashQualifiedPrime.hs new file mode 100644 index 0000000000..406a8eae2f --- /dev/null +++ b/unison-syntax/src/Unison/Syntax/HashQualifiedPrime.hs @@ -0,0 +1,59 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Syntax-related combinators for HashQualified' (to/from string types). +module Unison.Syntax.HashQualifiedPrime + ( -- * String conversions + parseText, + unsafeParseText, + toText, + + -- * Parsers + hashQualifiedP, + ) +where + +import Data.Text qualified as Text +import Text.Megaparsec (ParsecT) +import Text.Megaparsec qualified as P +import Text.Megaparsec.Internal qualified as P (withParsecT) +import Unison.HashQualifiedPrime qualified as HQ' +import Unison.Name (Name) +import Unison.Prelude hiding (fromString) +import Unison.Syntax.Lexer.Token (Token) +import Unison.Syntax.Name qualified as Name (nameP, toText) +import Unison.Syntax.NameSegment qualified as NameSegment +import Unison.Syntax.ShortHash qualified as ShortHash (shortHashP) + +------------------------------------------------------------------------------------------------------------------------ +-- String conversions + +parseText :: Text -> Maybe (HQ'.HashQualified Name) +parseText text = + eitherToMaybe (P.runParser parser "" (Text.unpack text)) + where + parser = + hashQualifiedP (P.withParsecT (fmap NameSegment.renderParseErr) Name.nameP) <* P.eof + +unsafeParseText :: (HasCallStack) => Text -> HQ'.HashQualified Name +unsafeParseText txt = fromMaybe msg (parseText txt) + where + msg = error ("HashQualified.unsafeFromText " <> show txt) + +toText :: HQ'.HashQualified Name -> Text +toText = + HQ'.toTextWith Name.toText + +------------------------------------------------------------------------------------------------------------------------ +-- Hash-qualified parsers + +-- | A hash-qualified parser. +hashQualifiedP :: + (Monad m) => + ParsecT (Token Text) [Char] m name -> + ParsecT (Token Text) [Char] m (HQ'.HashQualified name) +hashQualifiedP nameP = + P.try do + name <- nameP + optional ShortHash.shortHashP <&> \case + Nothing -> HQ'.NameOnly name + Just hash -> HQ'.HashQualified name hash diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index 9938e2e41c..5e6d18293f 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -1,21 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-} - +-- | This currently contains a mix of general lexing utilities and identifier-y lexers. module Unison.Syntax.Lexer ( Token (..), Line, Column, - Err (..), Pos (..), - Lexeme (..), - lexer, - line, - column, - escapeChars, - debugFileLex, - debugLex', - debugLex'', - debugLex''', - showEscapeChar, touches, -- * Character classifiers @@ -23,121 +11,46 @@ module Unison.Syntax.Lexer wordyIdStartChar, symbolyIdChar, - -- * Error formatting - formatTrivialError, - displayLexeme, + -- * other utils + local, + space, + lit, + commitAfter2, + (<+>), + some', + someTill', + sepBy1', + separated, + wordySep, + pop, + typeOrAbilityAlt, + inc, ) where import Control.Monad.State qualified as S -import Data.Char (isAlphaNum, isControl, isDigit, isSpace, ord, toLower) -import Data.Foldable qualified as Foldable -import Data.List qualified as List -import Data.List.Extra qualified as List -import Data.List.NonEmpty qualified as Nel -import Data.List.NonEmpty qualified as NonEmpty -import Data.Map.Strict qualified as Map -import Data.Set qualified as Set -import Data.Text qualified as Text -import GHC.Exts (sortWith) +import Data.Char (isSpace) +import Data.List.NonEmpty (NonEmpty ((:|))) import Text.Megaparsec qualified as P -import Text.Megaparsec.Char (char) import Text.Megaparsec.Char qualified as CP import Text.Megaparsec.Char.Lexer qualified as LP -import Text.Megaparsec.Error qualified as EP -import Text.Megaparsec.Internal qualified as PI -import Unison.HashQualified' qualified as HQ' import Unison.Lexer.Pos (Column, Line, Pos (Pos), column, line) -import Unison.Name (Name) -import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment) -import Unison.NameSegment qualified as NameSegment (docSegment) -import Unison.NameSegment.Internal qualified as NameSegment import Unison.Prelude -import Unison.ShortHash (ShortHash) -import Unison.ShortHash qualified as SH -import Unison.Syntax.HashQualified' qualified as HQ' (toText) -import Unison.Syntax.Lexer.Token (Token (..), posP, tokenP) -import Unison.Syntax.Name qualified as Name (isSymboly, nameP, toText, unsafeParseText) +import Unison.Syntax.Lexer.Token (Token (..)) import Unison.Syntax.NameSegment (symbolyIdChar, wordyIdChar, wordyIdStartChar) -import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr (..), wordyP) -import Unison.Syntax.ReservedWords (delimiters, typeModifiers, typeOrAbility) -import Unison.Syntax.ShortHash qualified as ShortHash (shortHashP) -import Unison.Util.Bytes qualified as Bytes -import Unison.Util.Monoid (intercalateMap) - -type BlockName = String - -type Layout = [(BlockName, Column)] - -data ParsingEnv = ParsingEnv - { layout :: !Layout, -- layout stack - opening :: Maybe BlockName, -- `Just b` if a block of type `b` is being opened - inLayout :: Bool, -- are we inside a construct that uses layout? - parentSection :: Int, -- 1 means we are inside a # Heading 1 - parentListColumn :: Int -- 4 means we are inside a list starting at the fourth column - } - deriving (Show) +import Unison.Syntax.ReservedWords (typeOrAbility) -type P = P.ParsecT (Token Err) String (S.State ParsingEnv) - -local :: (ParsingEnv -> ParsingEnv) -> P a -> P a +local :: (P.MonadParsec e s' m, S.MonadState s m) => (s -> s) -> m a -> m a local f p = do env0 <- S.get S.put (f env0) e <- P.observing p S.put env0 case e of - Left e -> parseFailure e + Left e -> P.parseError e Right a -> pure a -parseFailure :: EP.ParseError [Char] (Token Err) -> P a -parseFailure e = PI.ParsecT $ \s _ _ _ eerr -> eerr e s - -data Err - = InvalidWordyId String - | ReservedWordyId String - | InvalidSymbolyId String - | ReservedSymbolyId String - | InvalidShortHash String - | InvalidBytesLiteral String - | InvalidHexLiteral - | InvalidOctalLiteral - | Both Err Err - | MissingFractional String -- ex `1.` rather than `1.04` - | MissingExponent String -- ex `1e` rather than `1e3` - | UnknownLexeme - | TextLiteralMissingClosingQuote String - | InvalidEscapeCharacter Char - | LayoutError - | CloseWithoutMatchingOpen String String -- open, close - | UnexpectedDelimiter String - | UnexpectedTokens String -- Catch-all for all other lexer errors, representing some unexpected tokens. - deriving stock (Eq, Ord, Show) -- richer algebra - --- Design principle: --- `[Lexeme]` should be sufficient information for parsing without --- further knowledge of spacing or indentation levels --- any knowledge of comments -data Lexeme - = Open String -- start of a block - | Semi IsVirtual -- separator between elements of a block - | Close -- end of a block - | Reserved String -- reserved tokens such as `{`, `(`, `type`, `of`, etc - | Textual String -- text literals, `"foo bar"` - | Character Char -- character literals, `?X` - | WordyId (HQ'.HashQualified Name) -- a (non-infix) identifier. invariant: last segment is wordy - | SymbolyId (HQ'.HashQualified Name) -- an infix identifier. invariant: last segment is symboly - | Blank String -- a typed hole or placeholder - | Numeric String -- numeric literals, left unparsed - | Bytes Bytes.Bytes -- bytes literals - | Hash ShortHash -- hash literals - | Err Err - deriving stock (Eq, Show, Ord) - -type IsVirtual = Bool -- is it a virtual semi or an actual semi? - -space :: P () +space :: (P.MonadParsec e String m) => m () space = LP.space CP.space1 @@ -146,1359 +59,48 @@ space = where fold = P.try $ lit "---" *> P.takeRest *> pure () -lit :: String -> P String +lit :: (P.MonadParsec e String m) => String -> m String lit = P.try . LP.symbol (pure ()) -token :: P Lexeme -> P [Token Lexeme] -token = token' (\a start end -> [Token a start end]) - --- Token parser: strips trailing whitespace and comments after a --- successful parse, and also takes care of emitting layout tokens --- (such as virtual semicolons and closing tokens). -token' :: (a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme] -token' tok p = LP.lexeme space (token'' tok p) - --- Committed failure -err :: Pos -> Err -> P x -err start t = do - stop <- posP - -- This consumes a character and therefore produces committed failure, - -- so `err s t <|> p2` won't try `p2` - _ <- void P.anySingle <|> P.eof - P.customFailure (Token t start stop) - -{- -commitAfter :: P a -> (a -> P b) -> P b -commitAfter a f = do - a <- P.try a - f a --} - -commitAfter2 :: P a -> P b -> (a -> b -> P c) -> P c +commitAfter2 :: (P.MonadParsec e s m) => m a -> m b -> (a -> b -> m c) -> m c commitAfter2 a b f = do (a, b) <- P.try $ liftA2 (,) a b f a b --- Token parser implementation which leaves trailing whitespace and comments --- but does emit layout tokens such as virtual semicolons and closing tokens. -token'' :: (a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme] -token'' tok p = do - start <- posP - -- We save the current state so we can backtrack the state if `p` fails. - env <- S.get - layoutToks <- case opening env of - -- If we're opening a block named b, we push (b, currentColumn) onto - -- the layout stack. Example: - -- - -- blah = cases - -- {- A comment -} - -- -- A one-line comment - -- 0 -> "hi" - -- 1 -> "bye" - -- - -- After the `cases` token, the state will be opening = Just "cases", - -- meaning the parser is searching for the next non-whitespace/comment - -- character to determine the leftmost column of the `cases` block. - -- That will be the column of the `0`. - Just blockname -> - -- special case - handling of empty blocks, as in: - -- foo = - -- bar = 42 - if blockname == "=" && column start <= top l && not (null l) - then do - S.put (env {layout = (blockname, column start + 1) : l, opening = Nothing}) - pops start - else [] <$ S.put (env {layout = layout', opening = Nothing}) - where - layout' = (blockname, column start) : l - l = layout env - -- If we're not opening a block, we potentially pop from - -- the layout stack and/or emit virtual semicolons. - Nothing -> if inLayout env then pops start else pure [] - beforeTokenPos <- posP - a <- p <|> (S.put env >> fail "resetting state") - endPos <- posP - pure $ layoutToks ++ tok a beforeTokenPos endPos - where - pops :: Pos -> P [Token Lexeme] - pops p = do - env <- S.get - let l = layout env - if top l == column p && topBlockName l /= Just "(" -- don't emit virtual semis inside parens - then pure [Token (Semi True) p p] - else - if column p > top l || topHasClosePair l - then pure [] - else - if column p < top l - then S.put (env {layout = pop l}) >> ((Token Close p p :) <$> pops p) - else error "impossible" - - topHasClosePair :: Layout -> Bool - topHasClosePair [] = False - topHasClosePair ((name, _) : _) = - name `elem` ["syntax.docTransclude", "{", "(", "[", "handle", "match", "if", "then"] - -showErrorFancy :: (P.ShowErrorComponent e) => P.ErrorFancy e -> String -showErrorFancy = \case - P.ErrorFail msg -> msg - P.ErrorIndentation ord ref actual -> - "incorrect indentation (got " - <> show (P.unPos actual) - <> ", should be " - <> p - <> show (P.unPos ref) - <> ")" - where - p = case ord of - LT -> "less than " - EQ -> "equal to " - GT -> "greater than " - P.ErrorCustom a -> P.showErrorComponent a - -lexer0' :: String -> String -> [Token Lexeme] -lexer0' scope rem = - case flip S.evalState env0 $ P.runParserT lexemes scope rem of - Left e -> - let errsWithSourcePos = - fst $ - P.attachSourcePos - P.errorOffset - (toList (P.bundleErrors e)) - (P.bundlePosState e) - errorToTokens :: (EP.ParseError String (Token Err), P.SourcePos) -> [Token Lexeme] - errorToTokens (err, top) = case err of - P.FancyError _ (customErrs -> es) | not (null es) -> es - P.FancyError _errOffset es -> - let msg = intercalateMap "\n" showErrorFancy es - in [Token (Err (UnexpectedTokens msg)) (toPos top) (toPos top)] - P.TrivialError _errOffset mayUnexpectedTokens expectedTokens -> - let unexpectedStr :: Set String - unexpectedStr = - mayUnexpectedTokens - & fmap errorItemToString - & maybeToList - & Set.fromList - errorLength :: Int - errorLength = case Set.toList unexpectedStr of - [] -> 0 - (x : _) -> length x - expectedStr :: Set String - expectedStr = - expectedTokens - & Set.map errorItemToString - err = UnexpectedTokens $ formatTrivialError unexpectedStr expectedStr - startPos = toPos top - -- This is just an attempt to highlight errors better in source excerpts. - -- It may not work in all cases, but should generally provide a better experience. - endPos = startPos & \(Pos l c) -> Pos l (c + errorLength) - in [Token (Err err) startPos endPos] - in errsWithSourcePos >>= errorToTokens - Right ts -> Token (Open scope) topLeftCorner topLeftCorner : tweak ts - where - errorItemToString :: EP.ErrorItem Char -> String - errorItemToString = \case - (P.Tokens ts) -> Foldable.toList ts - (P.Label ts) -> Foldable.toList ts - (P.EndOfInput) -> "end of input" - customErrs es = [Err <$> e | P.ErrorCustom e <- toList es] - toPos (P.SourcePos _ line col) = Pos (P.unPos line) (P.unPos col) - env0 = ParsingEnv [] (Just scope) True 0 0 - -- hacky postprocessing pass to do some cleanup of stuff that's annoying to - -- fix without adding more state to the lexer: - -- - 1+1 lexes as [1, +1], convert this to [1, +, 1] - -- - when a semi followed by a virtual semi, drop the virtual, lets you - -- write - -- foo x = action1; - -- 2 - -- - semi immediately after first Open is ignored - tweak [] = [] - tweak (h@(payload -> Semi False) : (payload -> Semi True) : t) = h : tweak t - tweak (h@(payload -> Reserved _) : t) = h : tweak t - tweak (t1 : t2@(payload -> Numeric num) : rem) - | notLayout t1 && touches t1 t2 && isSigned num = - t1 - : Token - (SymbolyId (HQ'.fromName (Name.unsafeParseText (Text.pack (take 1 num))))) - (start t2) - (inc $ start t2) - : Token (Numeric (drop 1 num)) (inc $ start t2) (end t2) - : tweak rem - tweak (h : t) = h : tweak t - isSigned num = all (\ch -> ch == '-' || ch == '+') $ take 1 num - -formatTrivialError :: Set String -> Set String -> [Char] -formatTrivialError unexpectedTokens expectedTokens = - let unexpectedMsg = case Set.toList unexpectedTokens of - [] -> "I found something I didn't expect." - [x] -> - let article = case x of - (c : _) | c `elem` ("aeiou" :: String) -> "an" - _ -> "a" - in "I was surprised to find " <> article <> " " <> x <> " here." - xs -> "I was surprised to find these:\n\n* " <> List.intercalate "\n* " xs - expectedMsg = case Set.toList expectedTokens of - [] -> Nothing - xs -> Just $ "\nI was expecting one of these instead:\n\n* " <> List.intercalate "\n* " xs - in concat $ catMaybes [Just unexpectedMsg, expectedMsg] - -displayLexeme :: Lexeme -> String -displayLexeme = \case - Open o -> o - Semi True -> "end of section" - Semi False -> "semicolon" - Close -> "end of section" - Reserved r -> "'" <> r <> "'" - Textual t -> "\"" <> t <> "\"" - Character c -> "?" <> [c] - WordyId hq -> Text.unpack (HQ'.toTextWith Name.toText hq) - SymbolyId hq -> Text.unpack (HQ'.toTextWith Name.toText hq) - Blank b -> b - Numeric n -> n - Bytes _b -> "bytes literal" - Hash h -> Text.unpack (SH.toText h) - Err e -> show e - infixl 2 <+> -(<+>) :: (Monoid a) => P a -> P a -> P a -p1 <+> p2 = do a1 <- p1; a2 <- p2; pure (a1 <> a2) - -lexemes :: P [Token Lexeme] -lexemes = lexemes' eof - where - eof :: P [Token Lexeme] - eof = P.try do - p <- P.eof >> posP - n <- maybe 0 (const 1) <$> S.gets opening - l <- S.gets layout - pure $ replicate (length l + n) (Token Close p p) - --- Runs the parser `p`, then: --- 1. resets the layout stack to be what it was before `p`. --- 2. emits enough closing tokens to reach `lbl` but not pop it. --- (you can think of this as just dealing with a final "unclosed" --- block at the end of `p`) -restoreStack :: String -> P [Token Lexeme] -> P [Token Lexeme] -restoreStack lbl p = do - layout1 <- S.gets layout - p <- p - s2 <- S.get - let (pos1, pos2) = foldl' (\_ b -> (start b, end b)) mempty p - unclosed = takeWhile (\(lbl', _) -> lbl' /= lbl) (layout s2) - closes = replicate (length unclosed) (Token Close pos1 pos2) - S.put (s2 {layout = layout1}) - pure $ p <> closes - -lexemes' :: P [Token Lexeme] -> P [Token Lexeme] -lexemes' eof = - P.optional space >> do - hd <- join <$> P.manyTill toks (P.lookAhead eof) - tl <- eof - pure $ hd <> tl - where - toks :: P [Token Lexeme] - toks = - doc2 - <|> doc - <|> token numeric - <|> token character - <|> reserved - <|> token blank - <|> token identifierLexemeP - <|> (asum . map token) [semi, textual, hash] - - doc2 :: P [Token Lexeme] - doc2 = do - -- Ensure we're at a doc before we start consuming tokens - P.lookAhead (lit "{{") - openStart <- posP - -- Produce any layout tokens, such as closing the last open block or virtual semicolons - -- We don't use 'token' on "{{" directly because we don't want to duplicate layout - -- tokens if we do the rewrite hack for type-docs below. - beforeStartToks <- token' ignore (pure ()) - void $ lit "{{" - openEnd <- posP - CP.space - -- Construct the token for opening the doc block. - let openTok = Token (Open "syntax.docUntitledSection") openStart openEnd - env0 <- S.get - -- Disable layout while parsing the doc block - (bodyToks0, closeTok) <- local (\env -> env {inLayout = False}) do - bodyToks <- body - closeStart <- posP - lit "}}" - closeEnd <- posP - pure (bodyToks, Token Close closeStart closeEnd) - let docToks = beforeStartToks <> [openTok] <> bodyToks0 <> [closeTok] - -- Parse any layout tokens after the doc block, e.g. virtual semicolon - endToks <- token' ignore (pure ()) - -- Hack to allow anonymous doc blocks before type decls - -- {{ Some docs }} Foo.doc = {{ Some docs }} - -- ability Foo where => ability Foo where - tn <- subsequentTypeName - pure $ case (tn) of - -- If we're followed by a type, we rewrite the doc block to be a named doc block. - (Just (WordyId tname)) - | isTopLevel -> - beforeStartToks - <> [WordyId (HQ'.fromName (Name.snoc (HQ'.toName tname) NameSegment.docSegment)) <$ openTok, Open "=" <$ openTok] - <> [openTok] - <> bodyToks0 - <> [closeTok] - -- We need an extra 'Close' here because we added an extra Open above. - <> [closeTok] - <> endToks - where - isTopLevel = length (layout env0) + maybe 0 (const 1) (opening env0) == 1 - _ -> docToks <> endToks - where - wordyKw kw = separated wordySep (lit kw) - subsequentTypeName = P.lookAhead . P.optional $ do - let lit' s = lit s <* sp - let modifier = typeModifiersAlt (lit' . Text.unpack) - let typeOrAbility' = typeOrAbilityAlt (wordyKw . Text.unpack) - _ <- optional modifier *> typeOrAbility' *> sp - Token name start stop <- tokenP identifierP - if Name.isSymboly (HQ'.toName name) - then P.customFailure (Token (InvalidSymbolyId (Text.unpack (HQ'.toTextWith Name.toText name))) start stop) - else pure (WordyId name) - ignore _ _ _ = [] - body = join <$> P.many (sectionElem <* CP.space) - sectionElem = section <|> fencedBlock <|> list <|> paragraph - paragraph = wrap "syntax.docParagraph" $ join <$> spaced leaf - reserved word = List.isPrefixOf "}}" word || all (== '#') word - - wordy closing = wrap "syntax.docWord" . tok . fmap Textual . P.try $ do - let end = - P.lookAhead $ - void docClose - <|> void docOpen - <|> void (P.satisfy isSpace) - <|> void closing - word <- P.manyTill (P.satisfy (\ch -> not (isSpace ch))) end - guard (not $ reserved word || null word) - pure word - - leafy closing = groupy closing gs - where - gs = - link - <|> externalLink - <|> exampleInline - <|> expr - <|> boldOrItalicOrStrikethrough closing - <|> verbatim - <|> atDoc - <|> wordy closing - - leaf = leafy mzero - - atDoc = src <|> evalInline <|> signature <|> signatureInline - where - comma = lit "," <* CP.space - src = - src' "syntax.docSource" "@source" - <|> src' "syntax.docFoldedSource" "@foldedSource" - srcElem = - wrap "syntax.docSourceElement" $ - (typeLink <|> termLink) - <+> ( fmap (fromMaybe []) . P.optional $ - (tok (Reserved <$> lit "@") <+> (CP.space *> annotations)) - ) - where - annotation = tok identifierLexemeP <|> expr <* CP.space - annotations = - join <$> P.some (wrap "syntax.docEmbedAnnotation" annotation) - src' name atName = wrap name $ do - _ <- lit atName *> (lit " {" <|> lit "{") *> CP.space - s <- P.sepBy1 srcElem comma - _ <- lit "}" - pure (join s) - signature = wrap "syntax.docSignature" $ do - _ <- (lit "@signatures" <|> lit "@signature") *> (lit " {" <|> lit "{") *> CP.space - s <- join <$> P.sepBy1 signatureLink comma - _ <- lit "}" - pure s - signatureInline = wrap "syntax.docSignatureInline" $ do - _ <- lit "@inlineSignature" *> (lit " {" <|> lit "{") *> CP.space - s <- signatureLink - _ <- lit "}" - pure s - evalInline = wrap "syntax.docEvalInline" $ do - _ <- lit "@eval" *> (lit " {" <|> lit "{") *> CP.space - let inlineEvalClose = [] <$ lit "}" - s <- lexemes' inlineEvalClose - pure s - - typeLink = wrap "syntax.docEmbedTypeLink" do - _ <- typeOrAbilityAlt (wordyKw . Text.unpack) <* CP.space - tok identifierLexemeP <* CP.space - - termLink = - wrap "syntax.docEmbedTermLink" $ - tok identifierLexemeP <* CP.space - - signatureLink = - wrap "syntax.docEmbedSignatureLink" $ - tok identifierLexemeP <* CP.space - - groupy closing p = do - Token p start stop <- tokenP p - after <- P.optional . P.try $ leafy closing - pure $ case after of - Nothing -> p - Just after -> - [ Token (Open "syntax.docGroup") start stop', - Token (Open "syntax.docJoin") start stop' - ] - <> p - <> after - <> (take 2 $ repeat (Token Close stop' stop')) - where - stop' = maybe stop end (lastMay after) - - verbatim = - P.label "code (examples: ''**unformatted**'', `words` or '''_words_''')" $ do - Token originalText start stop <- tokenP do - -- a single backtick followed by a non-backtick is treated as monospaced - let tick = P.try (lit "`" <* P.lookAhead (P.satisfy (/= '`'))) - -- also two or more ' followed by that number of closing ' - quotes <- tick <|> (lit "''" <+> P.takeWhileP Nothing (== '\'')) - P.someTill P.anySingle (lit quotes) - let isMultiLine = line start /= line stop - if isMultiLine - then do - let trimmed = (trimAroundDelimiters originalText) - let txt = trimIndentFromVerbatimBlock (column start - 1) trimmed - -- If it's a multi-line verbatim block we trim any whitespace representing - -- indentation from the pretty-printer. See 'trimIndentFromVerbatimBlock' - wrap "syntax.docVerbatim" $ - wrap "syntax.docWord" $ - pure [Token (Textual txt) start stop] - else - wrap "syntax.docCode" $ - wrap "syntax.docWord" $ - pure [Token (Textual originalText) start stop] - - exampleInline = - P.label "inline code (examples: ``List.map f xs``, ``[1] :+ 2``)" $ - wrap "syntax.docExample" $ do - n <- P.try $ do - _ <- lit "`" - length <$> P.takeWhile1P (Just "backticks") (== '`') - let end :: P [Token Lexeme] = [] <$ lit (replicate (n + 1) '`') - ex <- CP.space *> lexemes' end - pure ex - - docClose = [] <$ lit "}}" - docOpen = [] <$ lit "{{" - - link = - P.label "link (examples: {type List}, {Nat.+})" $ - wrap "syntax.docLink" $ - P.try $ - lit "{" *> (typeLink <|> termLink) <* lit "}" - - expr = - P.label "transclusion (examples: {{ doc2 }}, {{ sepBy s [doc1, doc2] }})" $ - openAs "{{" "syntax.docTransclude" - <+> do - env0 <- S.get - -- we re-allow layout within a transclusion, then restore it to its - -- previous state after - S.put (env0 {inLayout = True}) - -- Note: this P.lookAhead ensures the }} isn't consumed, - -- so it can be consumed below by the `close` which will - -- pop items off the layout stack up to the nearest enclosing - -- syntax.docTransclude. - ts <- lexemes' (P.lookAhead ([] <$ lit "}}")) - S.modify (\env -> env {inLayout = inLayout env0}) - pure ts - <+> close ["syntax.docTransclude"] (lit "}}") - - nonNewlineSpace ch = isSpace ch && ch /= '\n' && ch /= '\r' - nonNewlineSpaces = P.takeWhileP Nothing nonNewlineSpace - - -- Allows whitespace or a newline, but not more than two newlines in a row. - whitespaceWithoutParagraphBreak :: P () - whitespaceWithoutParagraphBreak = void do - void nonNewlineSpaces - optional newline >>= \case - Just _ -> void nonNewlineSpaces - Nothing -> pure () - - fencedBlock = - P.label "block eval (syntax: a fenced code block)" $ - evalUnison <|> exampleBlock <|> other - where - evalUnison = wrap "syntax.docEval" $ do - -- commit after seeing that ``` is on its own line - fence <- P.try $ do - fence <- lit "```" <+> P.takeWhileP Nothing (== '`') - b <- all isSpace <$> P.lookAhead (P.takeWhileP Nothing (/= '\n')) - fence <$ guard b - CP.space - *> local - (\env -> env {inLayout = True, opening = Just "docEval"}) - (restoreStack "docEval" $ lexemes' ([] <$ lit fence)) - - exampleBlock = wrap "syntax.docExampleBlock" $ do - void $ lit "@typecheck" <* CP.space - fence <- lit "```" <+> P.takeWhileP Nothing (== '`') - local - (\env -> env {inLayout = True, opening = Just "docExampleBlock"}) - (restoreStack "docExampleBlock" $ lexemes' ([] <$ lit fence)) - - uncolumn column tabWidth s = - let skip col r | col < 1 = r - skip col s@('\t' : _) | col < tabWidth = s - skip col ('\t' : r) = skip (col - tabWidth) r - skip col (c : r) - | isSpace c && (not $ isControl c) = - skip (col - 1) r - skip _ s = s - in List.intercalate "\n" $ skip column <$> lines s - - other = wrap "syntax.docCodeBlock" $ do - column <- (\x -> x - 1) . toInteger . P.unPos <$> LP.indentLevel - let tabWidth = toInteger . P.unPos $ P.defaultTabWidth - fence <- lit "```" <+> P.takeWhileP Nothing (== '`') - name <- - P.takeWhileP Nothing nonNewlineSpace - *> tok (Textual <$> P.takeWhile1P Nothing (not . isSpace)) - <* P.takeWhileP Nothing nonNewlineSpace - _ <- void CP.eol - verbatim <- - tok $ - Textual . uncolumn column tabWidth . trimAroundDelimiters - <$> P.someTill P.anySingle ([] <$ lit fence) - pure (name <> verbatim) - - boldOrItalicOrStrikethrough closing = do - let start = - some (P.satisfy (== '*')) - <|> some (P.satisfy (== '_')) - <|> some - (P.satisfy (== '~')) - name s = - if take 1 s == "~" - then "syntax.docStrikethrough" - else if take 1 s == "*" then "syntax.docBold" else "syntax.docItalic" - end <- P.try $ do - end <- start - P.lookAhead (P.satisfy (not . isSpace)) - pure end - wrap (name end) . wrap "syntax.docParagraph" $ - join - <$> P.someTill - (leafy (closing <|> (void $ lit end)) <* whitespaceWithoutParagraphBreak) - (lit end) - - externalLink = - P.label "hyperlink (example: [link name](https://destination.com))" $ - wrap "syntax.docNamedLink" $ do - _ <- lit "[" - p <- leafies (void $ char ']') - _ <- lit "]" - _ <- lit "(" - target <- - wrap "syntax.docGroup" . wrap "syntax.docJoin" $ - link <|> fmap join (P.some (expr <|> wordy (char ')'))) - _ <- lit ")" - pure (p <> target) - - -- newline = P.optional (lit "\r") *> lit "\n" - - sp = P.try $ do - spaces <- P.takeWhile1P (Just "space") isSpace - close <- P.optional (P.lookAhead (lit "}}")) - case close of - Nothing -> guard $ ok spaces - Just _ -> pure () - pure spaces - where - ok s = length [() | '\n' <- s] < 2 - - spaced p = P.some (p <* P.optional sp) - leafies close = wrap "syntax.docParagraph" $ join <$> spaced (leafy close) - - list = bulletedList <|> numberedList - - bulletedList = wrap "syntax.docBulletedList" $ join <$> P.sepBy1 bullet listSep - numberedList = wrap "syntax.docNumberedList" $ join <$> P.sepBy1 numberedItem listSep - - listSep = P.try $ newline *> nonNewlineSpaces *> P.lookAhead (bulletedStart <|> numberedStart) - - bulletedStart = P.try $ do - r <- listItemStart' $ [] <$ P.satisfy bulletChar - P.lookAhead (P.satisfy isSpace) - pure r - where - bulletChar ch = ch == '*' || ch == '-' || ch == '+' - - listItemStart' gutter = P.try $ do - nonNewlineSpaces - col <- column <$> posP - parentCol <- S.gets parentListColumn - guard (col > parentCol) - (col,) <$> gutter - - numberedStart = - listItemStart' $ P.try (tok . fmap num $ LP.decimal <* lit ".") - where - num :: Word -> Lexeme - num n = Numeric (show n) - - listItemParagraph = wrap "syntax.docParagraph" $ do - col <- column <$> posP - join <$> P.some (leaf <* sep col) - where - -- Trickiness here to support hard line breaks inside of - -- a bulleted list, so for instance this parses as expected: - -- - -- * uno dos - -- tres quatro - -- * alice bob - -- carol dave eve - sep col = do - _ <- nonNewlineSpaces - _ <- - P.optional . P.try $ - newline - *> nonNewlineSpaces - *> do - col2 <- column <$> posP - guard $ col2 >= col - (P.notFollowedBy $ numberedStart <|> bulletedStart) - pure () - - numberedItem = P.label msg $ do - (col, s) <- numberedStart - pure s - <+> ( wrap "syntax.docColumn" $ do - p <- nonNewlineSpaces *> listItemParagraph - subList <- - local (\e -> e {parentListColumn = col}) (P.optional $ listSep *> list) - pure (p <> fromMaybe [] subList) - ) - where - msg = "numbered list (examples: 1. item1, 8. start numbering at '8')" - - bullet = wrap "syntax.docColumn" . P.label "bullet (examples: * item1, - item2)" $ do - (col, _) <- bulletedStart - p <- nonNewlineSpaces *> listItemParagraph - subList <- - local - (\e -> e {parentListColumn = col}) - (P.optional $ listSep *> list) - pure (p <> fromMaybe [] subList) - - newline = P.label "newline" $ lit "\n" <|> lit "\r\n" - - -- ## Section title - -- - -- A paragraph under this section. - -- Part of the same paragraph. Blanklines separate paragraphs. - -- - -- ### A subsection title - -- - -- A paragraph under this subsection. - - -- # A section title (not a subsection) - section :: P [Token Lexeme] - section = wrap "syntax.docSection" $ do - n <- S.gets parentSection - hashes <- P.try $ lit (replicate n '#') *> P.takeWhile1P Nothing (== '#') <* sp - title <- paragraph <* CP.space - let m = length hashes + n - body <- - local (\env -> env {parentSection = m}) $ - P.many (sectionElem <* CP.space) - pure $ title <> join body +(<+>) :: (Applicative f, Monoid a) => f a -> f a -> f a +(<+>) = liftA2 (<>) - wrap :: String -> P [Token Lexeme] -> P [Token Lexeme] - wrap o p = do - start <- posP - lexemes <- p - pure $ go start lexemes - where - go start [] = [Token (Open o) start start, Token Close start start] - go start ts@(Token _ x _ : _) = - Token (Open o) start x : (ts ++ [Token Close (end final) (end final)]) - where - final = last ts +-- | Like `P.some`, but returns an actual `NonEmpty`. +some' :: (P.MonadParsec e s m) => m a -> m (NonEmpty a) +some' p = liftA2 (:|) p $ many p - doc :: P [Token Lexeme] - doc = open <+> (CP.space *> fmap fixup body) <+> (close <* space) - where - open = token'' (\t _ _ -> t) $ tok (Open <$> lit "[:") - close = tok (Close <$ lit ":]") - at = lit "@" - -- this removes some trailing whitespace from final textual segment - fixup [] = [] - fixup (Token (Textual (reverse -> txt)) start stop : []) = - [Token (Textual txt') start stop] - where - txt' = reverse (dropWhile (\c -> isSpace c && not (c == '\n')) txt) - fixup (h : t) = h : fixup t +-- | Like `P.someTill`, but returns an actual `NonEmpty`. +someTill' :: (P.MonadParsec e s m) => m a -> m end -> m (NonEmpty a) +someTill' p end = liftA2 (:|) p $ P.manyTill p end - body :: P [Token Lexeme] - body = txt <+> (atk <|> pure []) - where - ch = (":]" <$ lit "\\:]") <|> ("@" <$ lit "\\@") <|> (pure <$> P.anySingle) - txt = tok (Textual . join <$> P.manyTill ch (P.lookAhead sep)) - sep = void at <|> void close - ref = at *> (tok identifierLexemeP <|> docTyp) - atk = (ref <|> docTyp) <+> body - docTyp = do - _ <- lit "[" - typ <- tok (P.manyTill P.anySingle (P.lookAhead (lit "]"))) - _ <- lit "]" *> CP.space - t <- tok identifierLexemeP - pure $ (fmap Reserved <$> typ) <> t +-- | Like `P.sepBy1`, but returns an actual `NonEmpty`. +sepBy1' :: (P.MonadParsec e s m) => m a -> m sep -> m (NonEmpty a) +sepBy1' p sep = liftA2 (:|) p . many $ sep *> p - blank = - separated wordySep do - _ <- char '_' - seg <- P.optional wordyIdSegP - pure (Blank (maybe "" (Text.unpack . NameSegment.toUnescapedText) seg)) - - semi = char ';' $> Semi False - textual = Textual <$> quoted - quoted = quotedRaw <|> quotedSingleLine - quotedRaw = do - _ <- lit "\"\"\"" - n <- many (char '"') - _ <- optional (char '\n') -- initial newline is skipped - s <- P.manyTill P.anySingle (lit (replicate (length n + 3) '"')) - col0 <- column <$> posP - let col = col0 - (length n) - 3 -- this gets us first col of closing quotes - let leading = replicate (max 0 (col - 1)) ' ' - -- a last line that's equal to `leading` is ignored, since leading - -- spaces up to `col` are not considered part of the string - let tweak l = case reverse l of - last : rest - | col > 1 && last == leading -> reverse rest - | otherwise -> l - [] -> [] - pure $ case tweak (lines s) of - [] -> s - ls - | all (\l -> List.isPrefixOf leading l || all isSpace l) ls -> List.intercalate "\n" (drop (length leading) <$> ls) - | otherwise -> s - quotedSingleLine = char '"' *> P.manyTill (LP.charLiteral <|> sp) (char '"') - where - sp = lit "\\s" $> ' ' - character = Character <$> (char '?' *> (spEsc <|> LP.charLiteral)) - where - spEsc = P.try (char '\\' *> char 's' $> ' ') - - numeric = bytes <|> otherbase <|> float <|> intOrNat - where - intOrNat = P.try $ num <$> sign <*> LP.decimal - float = do - _ <- P.try (P.lookAhead (sign >> (LP.decimal :: P Int) >> (char '.' <|> char 'e' <|> char 'E'))) -- commit after this - start <- posP - sign <- fromMaybe "" <$> sign - base <- P.takeWhile1P (Just "base") isDigit - decimals <- - P.optional $ - let missingFractional = err start (MissingFractional $ base <> ".") - in liftA2 (<>) (lit ".") (P.takeWhile1P (Just "decimals") isDigit <|> missingFractional) - exp <- P.optional $ do - e <- map toLower <$> (lit "e" <|> lit "E") - sign <- fromMaybe "" <$> optional (lit "+" <|> lit "-") - let missingExp = err start (MissingExponent $ base <> fromMaybe "" decimals <> e <> sign) - exp <- P.takeWhile1P (Just "exponent") isDigit <|> missingExp - pure $ e <> sign <> exp - pure $ Numeric (sign <> base <> fromMaybe "" decimals <> fromMaybe "" exp) - - bytes = do - start <- posP - _ <- lit "0xs" - s <- map toLower <$> P.takeWhileP (Just "hexidecimal character") isAlphaNum - case Bytes.fromBase16 $ Bytes.fromWord8s (fromIntegral . ord <$> s) of - Left _ -> err start (InvalidBytesLiteral $ "0xs" <> s) - Right bs -> pure (Bytes bs) - otherbase = octal <|> hex - octal = do - start <- posP - commitAfter2 sign (lit "0o") $ \sign _ -> - fmap (num sign) LP.octal <|> err start InvalidOctalLiteral - hex = do - start <- posP - commitAfter2 sign (lit "0x") $ \sign _ -> - fmap (num sign) LP.hexadecimal <|> err start InvalidHexLiteral - - num :: Maybe String -> Integer -> Lexeme - num sign n = Numeric (fromMaybe "" sign <> show n) - sign = P.optional (lit "+" <|> lit "-") - - hash = Hash <$> P.try shortHashP - - reserved :: P [Token Lexeme] - reserved = - token' (\ts _ _ -> ts) $ - braces - <|> parens - <|> brackets - <|> commaSeparator - <|> delim - <|> delayOrForce - <|> keywords - <|> layoutKeywords - where - keywords = - -- yes "wordy" - just like a wordy keyword like "true", the literal "." (as in the dot in - -- "forall a. a -> a") is considered the keyword "." so long as it is either followed by EOF, a space, or some - -- non-wordy character (because ".foo" is a single identifier lexeme) - wordyKw "." - <|> symbolyKw ":" - <|> openKw "@rewrite" - <|> symbolyKw "@" - <|> symbolyKw "||" - <|> symbolyKw "|" - <|> symbolyKw "&&" - <|> wordyKw "true" - <|> wordyKw "false" - <|> wordyKw "use" - <|> wordyKw "forall" - <|> wordyKw "∀" - <|> wordyKw "termLink" - <|> wordyKw "typeLink" - - wordyKw s = separated wordySep (kw s) - symbolyKw s = separated (not . symbolyIdChar) (kw s) - - kw :: String -> P [Token Lexeme] - kw s = tokenP (lit s) <&> \token -> [Reserved <$> token] - - layoutKeywords :: P [Token Lexeme] - layoutKeywords = - ifElse - <|> withKw - <|> openKw "match" - <|> openKw "handle" - <|> typ - <|> arr - <|> rewriteArr - <|> eq - <|> openKw "cases" - <|> openKw "where" - <|> openKw "let" - <|> openKw "do" - where - ifElse = - openKw "if" - <|> closeKw' (Just "then") ["if"] (lit "then") - <|> closeKw' (Just "else") ["then"] (lit "else") - modKw = typeModifiersAlt (openKw1 wordySep . Text.unpack) - typeOrAbilityKw = typeOrAbilityAlt (openTypeKw1 . Text.unpack) - typ = modKw <|> typeOrAbilityKw - - withKw = do - [Token _ pos1 pos2] <- wordyKw "with" - env <- S.get - let l = layout env - case findClose ["handle", "match"] l of - Nothing -> err pos1 (CloseWithoutMatchingOpen msgOpen "'with'") - where - msgOpen = "'handle' or 'match'" - Just (withBlock, n) -> do - let b = withBlock <> "-with" - S.put (env {layout = drop n l, opening = Just b}) - let opens = [Token (Open "with") pos1 pos2] - pure $ replicate n (Token Close pos1 pos2) ++ opens - - -- In `structural/unique type` and `structural/unique ability`, - -- only the `structural` or `unique` opens a layout block, - -- and `ability` and `type` are just keywords. - openTypeKw1 t = do - b <- S.gets (topBlockName . layout) - case b of - Just mod | Set.member (Text.pack mod) typeModifiers -> wordyKw t - _ -> openKw1 wordySep t - - -- layout keyword which bumps the layout column by 1, rather than looking ahead - -- to the next token to determine the layout column - openKw1 :: (Char -> Bool) -> String -> P [Token Lexeme] - openKw1 sep kw = do - Token kw pos0 pos1 <- tokenP $ separated sep (lit kw) - S.modify (\env -> env {layout = (kw, column $ inc pos0) : layout env}) - pure [Token (Open kw) pos0 pos1] - - eq = do - [Token _ start end] <- symbolyKw "=" - env <- S.get - case topBlockName (layout env) of - -- '=' does not open a layout block if within a type declaration - Just t | t == "type" || Set.member (Text.pack t) typeModifiers -> pure [Token (Reserved "=") start end] - Just _ -> S.put (env {opening = Just "="}) >> pure [Token (Open "=") start end] - _ -> err start LayoutError - - rewriteArr = do - [Token _ start end] <- symbolyKw "==>" - env <- S.get - S.put (env {opening = Just "==>"}) >> pure [Token (Open "==>") start end] - - arr = do - [Token _ start end] <- symbolyKw "->" - env <- S.get - -- -> introduces a layout block if we're inside a `match with` or `cases` - case topBlockName (layout env) of - Just match | match `elem` matchWithBlocks -> do - S.put (env {opening = Just "->"}) - pure [Token (Open "->") start end] - _ -> pure [Token (Reserved "->") start end] - - -- a bit of lookahead here to reserve }} for closing a documentation block - braces = open "{" <|> close ["{"] p - where - p = do - l <- lit "}" - -- if we're within an existing {{ }} block, inLayout will be false - -- so we can actually allow }} to appear in normal code - inLayout <- S.gets inLayout - when (not inLayout) $ void $ P.lookAhead (P.satisfy (/= '}')) - pure l - matchWithBlocks = ["match-with", "cases"] - parens = open "(" <|> close ["("] (lit ")") - brackets = open "[" <|> close ["["] (lit "]") - -- `allowCommaToClose` determines if a comma should close inner blocks. - -- Currently there is a set of blocks where `,` is not treated specially - -- and it just emits a Reserved ",". There are currently only three: - -- `cases`, `match-with`, and `{` - allowCommaToClose match = not $ match `elem` ("{" : matchWithBlocks) - commaSeparator = do - env <- S.get - case topBlockName (layout env) of - Just match - | allowCommaToClose match -> - blockDelimiter ["[", "("] (lit ",") - _ -> fail "this comma is a pattern separator" - - delim = P.try $ do - ch <- P.satisfy (\ch -> ch /= ';' && Set.member ch delimiters) - pos <- posP - pure [Token (Reserved [ch]) pos (inc pos)] - - delayOrForce = separated ok $ do - token <- tokenP $ P.satisfy isDelayOrForce - pure [token <&> \op -> Reserved [op]] - where - ok c = isDelayOrForce c || isSpace c || isAlphaNum c || Set.member c delimiters || c == '\"' - --- | If it's a multi-line verbatim block we trim any whitespace representing --- indentation from the pretty-printer. --- --- E.g. --- --- @@ --- {{ --- # Heading --- ''' --- code --- indented --- ''' --- }} --- @@ --- --- Should lex to the text literal "code\n indented". --- --- If there's text in the literal that has LESS trailing whitespace than the --- opening delimiters, we don't trim it at all. E.g. --- --- @@ --- {{ --- # Heading --- ''' --- code --- ''' --- }} --- @@ --- --- Is parsed as " code". --- --- Trim the expected amount of whitespace from a text literal: --- >>> trimIndentFromVerbatimBlock 2 " code\n indented" --- "code\n indented" --- --- If the text literal has less leading whitespace than the opening delimiters, --- leave it as-is --- >>> trimIndentFromVerbatimBlock 2 "code\n indented" --- "code\n indented" -trimIndentFromVerbatimBlock :: Int -> String -> String -trimIndentFromVerbatimBlock leadingSpaces txt = fromMaybe txt $ do - List.intercalate "\n" <$> for (lines txt) \line -> do - -- If any 'stripPrefix' fails, we fail and return the unaltered text - case List.stripPrefix (replicate leadingSpaces ' ') line of - Just stripped -> Just stripped - Nothing -> - -- If it was a line with all white-space, just use an empty line, - -- this can happen easily in editors which trim trailing whitespace. - if all isSpace line - then Just "" - else Nothing - --- Trim leading/trailing whitespace from around delimiters, e.g. --- --- {{ --- '''___ <- whitespace here including newline --- text block --- 👇 or here --- __''' --- }} --- >>> trimAroundDelimiters " \n text block \n " --- " text block " --- --- Should leave leading and trailing line untouched if it contains non-whitespace, e.g.: --- --- ''' leading whitespace --- text block --- trailing whitespace: ''' --- >>> trimAroundDelimiters " leading whitespace\n text block \ntrailing whitespace: " --- " leading whitespace\n text block \ntrailing whitespace: " --- --- Should keep trailing newline if it's the only thing on the line, e.g.: --- --- ''' --- newline below --- --- ''' --- >>> trimAroundDelimiters "\nnewline below\n\n" --- "newline below\n\n" -trimAroundDelimiters :: String -> String -trimAroundDelimiters txt = - txt - & ( \s -> - List.breakOn "\n" s - & \case - (prefix, suffix) - | all isSpace prefix -> drop 1 suffix - | otherwise -> prefix <> suffix - ) - & ( \s -> - List.breakOnEnd "\n" s - & \case - (_prefix, "") -> s - (prefix, suffix) - | all isSpace suffix -> dropTrailingNewline prefix - | otherwise -> prefix <> suffix - ) - where - dropTrailingNewline = \case - [] -> [] - (x : xs) -> NonEmpty.init (x NonEmpty.:| xs) - -separated :: (Char -> Bool) -> P a -> P a +separated :: (P.MonadParsec e s m) => (P.Token s -> Bool) -> m a -> m a separated ok p = P.try $ p <* P.lookAhead (void (P.satisfy ok) <|> P.eof) -open :: String -> P [Token Lexeme] -open b = openAs b b - -openAs :: String -> String -> P [Token Lexeme] -openAs syntax b = do - token <- tokenP $ lit syntax - env <- S.get - S.put (env {opening = Just b}) - pure [Open b <$ token] - -openKw :: String -> P [Token Lexeme] -openKw s = separated wordySep $ do - token <- tokenP $ lit s - env <- S.get - S.put (env {opening = Just s}) - pure [Open <$> token] - wordySep :: Char -> Bool wordySep c = isSpace c || not (wordyIdChar c) -tok :: P a -> P [Token a] -tok p = do - token <- tokenP p - pure [token] - --- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is --- symboly (comprised of only symbols) or wordy (comprised of only alphanums). --- --- Examples: --- --- foo --- .foo.++.doc --- `.`.`..` (This is a two-segment identifier without a leading dot: "." then "..") -identifierP :: P (HQ'.HashQualified Name) -identifierP = do - P.label "identifier (ex: abba1, snake_case, .foo.bar#xyz, .foo.++#xyz, or 🌻)" do - name <- PI.withParsecT (fmap nameSegmentParseErrToErr) Name.nameP - P.optional shortHashP <&> \case - Nothing -> HQ'.fromName name - Just shorthash -> HQ'.HashQualified name shorthash - where - nameSegmentParseErrToErr :: NameSegment.ParseErr -> Err - nameSegmentParseErrToErr = \case - NameSegment.ReservedOperator s -> ReservedSymbolyId (Text.unpack s) - NameSegment.ReservedWord s -> ReservedWordyId (Text.unpack s) - --- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is --- symboly (comprised of only symbols) or wordy (comprised of only alphanums). --- --- Examples: --- --- foo --- .foo.++.doc --- `.`.`..` (This is a two-segment identifier without a leading dot: "." then "..") -identifierLexemeP :: P Lexeme -identifierLexemeP = do - name <- identifierP - pure - if Name.isSymboly (HQ'.toName name) - then SymbolyId name - else WordyId name - -wordyIdSegP :: P NameSegment -wordyIdSegP = - PI.withParsecT (fmap (ReservedWordyId . Text.unpack)) NameSegment.wordyP - -shortHashP :: P ShortHash -shortHashP = - PI.withParsecT (fmap (InvalidShortHash . Text.unpack)) ShortHash.shortHashP - -blockDelimiter :: [String] -> P String -> P [Token Lexeme] -blockDelimiter open closeP = do - Token close pos1 pos2 <- tokenP closeP - env <- S.get - case findClose open (layout env) of - Nothing -> err pos1 (UnexpectedDelimiter (quote close)) - where - quote s = "'" <> s <> "'" - Just (_, n) -> do - S.put (env {layout = drop (n - 1) (layout env)}) - let delims = [Token (Reserved close) pos1 pos2] - pure $ replicate (n - 1) (Token Close pos1 pos2) ++ delims - -close :: [String] -> P String -> P [Token Lexeme] -close = close' Nothing - -closeKw' :: Maybe String -> [String] -> P String -> P [Token Lexeme] -closeKw' reopenBlockname open closeP = close' reopenBlockname open (separated wordySep closeP) - -close' :: Maybe String -> [String] -> P String -> P [Token Lexeme] -close' reopenBlockname open closeP = do - Token close pos1 pos2 <- tokenP closeP - env <- S.get - case findClose open (layout env) of - Nothing -> err pos1 (CloseWithoutMatchingOpen msgOpen (quote close)) - where - msgOpen = List.intercalate " or " (quote <$> open) - quote s = "'" <> s <> "'" - Just (_, n) -> do - S.put (env {layout = drop n (layout env), opening = reopenBlockname}) - let opens = maybe [] (const $ [Token (Open close) pos1 pos2]) reopenBlockname - pure $ replicate n (Token Close pos1 pos2) ++ opens - -findClose :: [String] -> Layout -> Maybe (String, Int) -findClose _ [] = Nothing -findClose s ((h, _) : tl) = if h `elem` s then Just (h, 1) else fmap (1 +) <$> findClose s tl - -notLayout :: Token Lexeme -> Bool -notLayout t = case payload t of - Close -> False - Semi _ -> False - Open _ -> False - _ -> True - -- `True` if the tokens are adjacent, with no space separating the two touches :: Token a -> Token b -> Bool touches (end -> t) (start -> t2) = line t == line t2 && column t == column t2 -top :: Layout -> Column -top [] = 1 -top ((_, h) : _) = h - --- todo: make Layout a NonEmpty -topBlockName :: Layout -> Maybe BlockName -topBlockName [] = Nothing -topBlockName ((name, _) : _) = Just name - pop :: [a] -> [a] pop = drop 1 -topLeftCorner :: Pos -topLeftCorner = Pos 1 1 - -data T a = T a [T a] [a] | L a deriving (Functor, Foldable, Traversable) - -headToken :: T a -> a -headToken (T a _ _) = a -headToken (L a) = a - -instance (Show a) => Show (T a) where - show (L a) = show a - show (T open mid close) = - show open - ++ "\n" - ++ indent " " (intercalateMap "\n" show mid) - ++ "\n" - ++ intercalateMap "" show close - where - indent by s = by ++ (s >>= go by) - go by '\n' = '\n' : by - go _ c = [c] - -reorderTree :: ([T a] -> [T a]) -> T a -> T a -reorderTree _ l@(L _) = l -reorderTree f (T open mid close) = T open (f (reorderTree f <$> mid)) close - -tree :: [Token Lexeme] -> T (Token Lexeme) -tree toks = one toks const - where - one (open@(payload -> Open _) : ts) k = many (T open) [] ts k - one (t : ts) k = k (L t) ts - one [] k = k lastErr [] - where - lastErr = case drop (length toks - 1) toks of - [] -> L (Token (Err LayoutError) topLeftCorner topLeftCorner) - (t : _) -> L $ t {payload = Err LayoutError} - - many open acc [] k = k (open (reverse acc) []) [] - many open acc (t@(payload -> Close) : ts) k = k (open (reverse acc) [t]) ts - many open acc ts k = one ts $ \t ts -> many open (t : acc) ts k - -stanzas :: [T (Token Lexeme)] -> [[T (Token Lexeme)]] -stanzas = go [] - where - go acc [] = [reverse acc] - go acc (t : ts) = case payload $ headToken t of - Semi _ -> reverse (t : acc) : go [] ts - _ -> go (t : acc) ts - --- Moves type and ability declarations to the front of the token stream --- and move `use` statements to the front of each block -reorder :: [T (Token Lexeme)] -> [T (Token Lexeme)] -reorder = join . sortWith f . stanzas - where - f [] = 3 :: Int - f (t0 : _) = case payload $ headToken t0 of - Open mod | Set.member (Text.pack mod) typeModifiers -> 1 - Open typOrA | Set.member (Text.pack typOrA) typeOrAbility -> 1 - Reserved "use" -> 0 - _ -> 3 :: Int - -lexer :: String -> String -> [Token Lexeme] -lexer scope rem = - let t = tree $ lexer0' scope rem - -- after reordering can end up with trailing semicolon at the end of - -- a block, which we remove with this pass - fixup ((payload -> Semi _) : t@(payload -> Close) : tl) = t : fixup tl - fixup [] = [] - fixup (h : t) = h : fixup t - in fixup . toList $ reorderTree reorder t - -isDelayOrForce :: Char -> Bool -isDelayOrForce op = op == '\'' || op == '!' - --- Mapping between characters and their escape codes. Use parse/showEscapeChar to convert. -escapeChars :: [(Char, Char)] -escapeChars = - [ ('0', '\0'), - ('a', '\a'), - ('b', '\b'), - ('f', '\f'), - ('n', '\n'), - ('r', '\r'), - ('t', '\t'), - ('v', '\v'), - ('s', ' '), - ('\'', '\''), - ('"', '"'), - ('\\', '\\') - ] - --- Inverse of parseEscapeChar; map a character to its escaped version: -showEscapeChar :: Char -> Maybe Char -showEscapeChar c = - Map.lookup c (Map.fromList [(x, y) | (y, x) <- escapeChars]) - typeOrAbilityAlt :: (Alternative f) => (Text -> f a) -> f a typeOrAbilityAlt f = asum $ map f (toList typeOrAbility) -typeModifiersAlt :: (Alternative f) => (Text -> f a) -> f a -typeModifiersAlt f = - asum $ map f (toList typeModifiers) - inc :: Pos -> Pos inc (Pos line col) = Pos line (col + 1) - -debugFileLex :: String -> IO () -debugFileLex file = do - contents <- readUtf8 file - let s = debugLex'' (lexer file (Text.unpack contents)) - putStrLn s - -debugLex'' :: [Token Lexeme] -> String -debugLex'' [Token (Err (UnexpectedTokens msg)) start end] = - (if start == end then msg1 else msg2) <> ":\n" <> msg - where - msg1 = "Error on line " <> show (line start) <> ", column " <> show (column start) - msg2 = - "Error on line " - <> show (line start) - <> ", column " - <> show (column start) - <> " - line " - <> show (line end) - <> ", column " - <> show (column end) -debugLex'' ts = show . fmap payload . tree $ ts - -debugLex' :: String -> String -debugLex' = debugLex'' . lexer "debugLex" - -debugLex''' :: String -> String -> String -debugLex''' s = debugLex'' . lexer s - -instance EP.ShowErrorComponent (Token Err) where - showErrorComponent (Token err _ _) = go err - where - go = \case - UnexpectedTokens msg -> msg - CloseWithoutMatchingOpen open close -> "I found a closing " <> close <> " but no matching " <> open <> "." - Both e1 e2 -> go e1 <> "\n" <> go e2 - LayoutError -> "Indentation error" - TextLiteralMissingClosingQuote s -> "This text literal missing a closing quote: " <> excerpt s - e -> show e - excerpt s = if length s < 15 then s else take 15 s <> "..." - -instance P.VisualStream [Token Lexeme] where - showTokens _ xs = - join . Nel.toList . S.evalState (traverse go xs) . end $ Nel.head xs - where - go :: Token Lexeme -> S.State Pos String - go tok = do - prev <- S.get - S.put $ end tok - pure $ pad prev (start tok) ++ pretty (payload tok) - pretty (Open s) = s - pretty (Reserved w) = w - pretty (Textual t) = '"' : t ++ ['"'] - pretty (Character c) = - case showEscapeChar c of - Just c -> "?\\" ++ [c] - Nothing -> '?' : [c] - pretty (WordyId n) = Text.unpack (HQ'.toText n) - pretty (SymbolyId n) = Text.unpack (HQ'.toText n) - pretty (Blank s) = "_" ++ s - pretty (Numeric n) = n - pretty (Hash sh) = show sh - pretty (Err e) = show e - pretty (Bytes bs) = "0xs" <> show bs - pretty Close = "" - pretty (Semi True) = "" - pretty (Semi False) = ";" - pad (Pos line1 col1) (Pos line2 col2) = - if line1 == line2 - then replicate (col2 - col1) ' ' - else replicate (line2 - line1) '\n' ++ replicate col2 ' ' diff --git a/unison-syntax/src/Unison/Syntax/Lexer/Token.hs b/unison-syntax/src/Unison/Syntax/Lexer/Token.hs index 81842c409e..f778dd66c0 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer/Token.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer/Token.hs @@ -6,9 +6,10 @@ module Unison.Syntax.Lexer.Token where import Data.Text qualified as Text -import Text.Megaparsec (ParsecT, TraversableStream) +import Text.Megaparsec (MonadParsec, TraversableStream) import Text.Megaparsec qualified as P import Unison.Lexer.Pos (Pos (Pos)) +import Unison.Parser.Ann (Ann (Ann), Annotated (..)) import Unison.Prelude data Token a = Token @@ -18,6 +19,9 @@ data Token a = Token } deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) +instance Annotated (Token a) where + ann (Token _ s e) = Ann s e + instance Applicative Token where pure a = Token a (Pos 0 0) (Pos 0 0) Token f start _ <*> Token a _ end = Token (f a) start end @@ -39,14 +43,14 @@ instance Applicative Token where instance P.ShowErrorComponent (Token Text) where showErrorComponent = Text.unpack . payload -tokenP :: (Ord e, TraversableStream s) => ParsecT e s m a -> ParsecT e s m (Token a) +tokenP :: (Ord e, TraversableStream s, MonadParsec e s m) => m a -> m (Token a) tokenP p = do start <- posP payload <- p end <- posP pure Token {payload, start, end} -posP :: (Ord e, TraversableStream s) => ParsecT e s m Pos +posP :: (Ord e, TraversableStream s, MonadParsec e s m) => m Pos posP = do p <- P.getSourcePos pure (Pos (P.unPos (P.sourceLine p)) (P.unPos (P.sourceColumn p))) diff --git a/unison-syntax/src/Unison/Syntax/Lexer/Unison.hs b/unison-syntax/src/Unison/Syntax/Lexer/Unison.hs new file mode 100644 index 0000000000..6eb51da9cb --- /dev/null +++ b/unison-syntax/src/Unison/Syntax/Lexer/Unison.hs @@ -0,0 +1,1041 @@ +module Unison.Syntax.Lexer.Unison + ( Token (..), + Line, + Column, + Err (..), + Pos (..), + Lexeme (..), + lexer, + preParse, + escapeChars, + debugFilePreParse, + debugPreParse, + debugPreParse', + showEscapeChar, + touches, + + -- * Lexers + typeOrTerm, + + -- * Character classifiers + wordyIdChar, + wordyIdStartChar, + symbolyIdChar, + + -- * Error formatting + formatTrivialError, + displayLexeme, + ) +where + +import Control.Lens qualified as Lens +import Control.Monad.State qualified as S +import Data.Char (isAlphaNum, isDigit, isSpace, ord, toLower) +import Data.Foldable qualified as Foldable +import Data.Functor.Classes (Show1 (..), showsPrec1) +import Data.List qualified as List +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as Nel +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import GHC.Exts (sortWith) +import Text.Megaparsec qualified as P +import Text.Megaparsec.Char (char) +import Text.Megaparsec.Char qualified as CP +import Text.Megaparsec.Char.Lexer qualified as LP +import Text.Megaparsec.Error qualified as EP +import Text.Megaparsec.Internal qualified as PI +import U.Codebase.Reference (ReferenceType (..)) +import Unison.HashQualifiedPrime qualified as HQ' +import Unison.Name (Name) +import Unison.Name qualified as Name +import Unison.NameSegment qualified as NameSegment (docSegment) +import Unison.Prelude +import Unison.ShortHash (ShortHash) +import Unison.ShortHash qualified as SH +import Unison.Syntax.HashQualifiedPrime qualified as HQ' (toText) +import Unison.Syntax.Lexer +import Unison.Syntax.Lexer.Token (posP, tokenP) +import Unison.Syntax.Name qualified as Name (isSymboly, nameP, toText, unsafeParseText) +import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr (..)) +import Unison.Syntax.Parser.Doc qualified as Doc +import Unison.Syntax.Parser.Doc.Data qualified as Doc +import Unison.Syntax.ReservedWords (delimiters, typeModifiers, typeOrAbility) +import Unison.Syntax.ShortHash qualified as ShortHash (shortHashP) +import Unison.Util.Bytes qualified as Bytes +import Unison.Util.Monoid (intercalateMap) + +type BlockName = String + +type Layout = [(BlockName, Column)] + +data ParsingEnv = ParsingEnv + { -- | layout stack + layout :: !Layout, + -- | `Just b` if a block of type `b` is being opened + opening :: Maybe BlockName, + -- | are we inside a construct that uses layout? + inLayout :: Bool + } + deriving (Show) + +initialEnv :: BlockName -> ParsingEnv +initialEnv scope = ParsingEnv [] (Just scope) True + +type P = P.ParsecT (Token Err) String (S.State ParsingEnv) + +data Err + = ReservedWordyId String + | InvalidSymbolyId String + | ReservedSymbolyId String + | InvalidShortHash String + | InvalidBytesLiteral String + | InvalidHexLiteral + | InvalidOctalLiteral + | InvalidBinaryLiteral + | Both Err Err + | MissingFractional String -- ex `1.` rather than `1.04` + | MissingExponent String -- ex `1e` rather than `1e3` + | UnknownLexeme + | TextLiteralMissingClosingQuote String + | InvalidEscapeCharacter Char + | LayoutError + | CloseWithoutMatchingOpen String String -- open, close + | UnexpectedDelimiter String + | UnexpectedTokens String -- Catch-all for all other lexer errors, representing some unexpected tokens. + deriving stock (Eq, Ord, Show) -- richer algebra + +-- Design principle: +-- `[Lexeme]` should be sufficient information for parsing without +-- further knowledge of spacing or indentation levels +-- any knowledge of comments +data Lexeme + = -- | start of a block + Open String + | -- | separator between elements of a block + Semi IsVirtual + | -- | end of a block + Close + | -- | reserved tokens such as `{`, `(`, `type`, `of`, etc + Reserved String + | -- | text literals, `"foo bar"` + Textual String + | -- | character literals, `?X` + Character Char + | -- | a (non-infix) identifier. invariant: last segment is wordy + WordyId (HQ'.HashQualified Name) + | -- | an infix identifier. invariant: last segment is symboly + SymbolyId (HQ'.HashQualified Name) + | -- | numeric literals, left unparsed + Numeric String + | -- | bytes literals + Bytes Bytes.Bytes + | -- | hash literals + Hash ShortHash + | Err Err + | Doc (Doc.UntitledSection (Doc.Tree (Token (ReferenceType, HQ'.HashQualified Name)) [Token Lexeme])) + deriving stock (Eq, Show, Ord) + +type IsVirtual = Bool -- is it a virtual semi or an actual semi? + +-- Committed failure +err :: (P.TraversableStream s, P.MonadParsec (Token Err) s m) => Pos -> Err -> m x +err start t = do + stop <- posP + -- This consumes a character and therefore produces committed failure, + -- so `err s t <|> p2` won't try `p2` + _ <- void P.anySingle <|> P.eof + P.customFailure (Token t start stop) + +token :: P Lexeme -> P [Token Lexeme] +token = token' (\a start end -> [Token a start end]) + +-- Token parser: strips trailing whitespace and comments after a +-- successful parse, and also takes care of emitting layout tokens +-- (such as virtual semicolons and closing tokens). +token' :: (a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme] +token' tok p = LP.lexeme space (token'' tok p) + +-- Token parser implementation which leaves trailing whitespace and comments +-- but does emit layout tokens such as virtual semicolons and closing tokens. +token'' :: (a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme] +token'' tok p = do + start <- posP + -- We save the current state so we can backtrack the state if `p` fails. + env <- S.get + layoutToks <- case opening env of + -- If we're opening a block named b, we push (b, currentColumn) onto + -- the layout stack. Example: + -- + -- blah = cases + -- {- A comment -} + -- -- A one-line comment + -- 0 -> "hi" + -- 1 -> "bye" + -- + -- After the `cases` token, the state will be opening = Just "cases", + -- meaning the parser is searching for the next non-whitespace/comment + -- character to determine the leftmost column of the `cases` block. + -- That will be the column of the `0`. + Just blockname -> + -- special case - handling of empty blocks, as in: + -- foo = + -- bar = 42 + if blockname == "=" && column start <= top l && not (null l) + then do + S.put (env {layout = (blockname, column start + 1) : l, opening = Nothing}) + pops start + else [] <$ S.put (env {layout = layout', opening = Nothing}) + where + layout' = (blockname, column start) : l + l = layout env + -- If we're not opening a block, we potentially pop from + -- the layout stack and/or emit virtual semicolons. + Nothing -> if inLayout env then pops start else pure [] + beforeTokenPos <- posP + a <- p <|> (S.put env >> fail "resetting state") + endPos <- posP + pure $ layoutToks ++ tok a beforeTokenPos endPos + where + pops :: Pos -> P [Token Lexeme] + pops p = do + env <- S.get + let l = layout env + if column p == top l && topContainsVirtualSemis l + then pure [Token (Semi True) p p] + else + if column p > top l || topHasClosePair l + then pure [] + else + if column p < top l + then S.put (env {layout = pop l}) >> ((Token Close p p :) <$> pops p) + else -- we hit this branch exactly when `token''` is given the state + -- `{layout = [], opening = Nothing, inLayout = True}` + fail "internal error: token''" + + -- don't emit virtual semis in (, {, or [ blocks + topContainsVirtualSemis :: Layout -> Bool + topContainsVirtualSemis = \case + [] -> False + ((name, _) : _) -> name /= "(" && name /= "{" && name /= "[" + + topHasClosePair :: Layout -> Bool + topHasClosePair [] = False + topHasClosePair ((name, _) : _) = + name `elem` ["DUMMY", "{", "(", "[", "handle", "match", "if", "then"] + +showErrorFancy :: (P.ShowErrorComponent e) => P.ErrorFancy e -> String +showErrorFancy = \case + P.ErrorFail msg -> msg + P.ErrorIndentation ord ref actual -> + "incorrect indentation (got " + <> show (P.unPos actual) + <> ", should be " + <> p + <> show (P.unPos ref) + <> ")" + where + p = case ord of + LT -> "less than " + EQ -> "equal to " + GT -> "greater than " + P.ErrorCustom a -> P.showErrorComponent a + +lexer :: String -> String -> [Token Lexeme] +lexer scope rem = + case flip S.evalState env0 $ P.runParserT (lexemes eof) scope rem of + Left e -> + let errsWithSourcePos = + fst $ + P.attachSourcePos + P.errorOffset + (toList (P.bundleErrors e)) + (P.bundlePosState e) + errorToTokens :: (EP.ParseError String (Token Err), P.SourcePos) -> [Token Lexeme] + errorToTokens (err, top) = case err of + P.FancyError _ (customErrs -> es) | not (null es) -> es + P.FancyError _errOffset es -> + let msg = intercalateMap "\n" showErrorFancy es + in [Token (Err (UnexpectedTokens msg)) (toPos top) (toPos top)] + P.TrivialError _errOffset mayUnexpectedTokens expectedTokens -> + let unexpectedStr :: Set String + unexpectedStr = + mayUnexpectedTokens + & fmap errorItemToString + & maybeToList + & Set.fromList + errorLength :: Int + errorLength = case Set.toList unexpectedStr of + [] -> 0 + (x : _) -> length x + expectedStr :: Set String + expectedStr = + expectedTokens + & Set.map errorItemToString + err = UnexpectedTokens $ formatTrivialError unexpectedStr expectedStr + startPos = toPos top + -- This is just an attempt to highlight errors better in source excerpts. + -- It may not work in all cases, but should generally provide a better experience. + endPos = startPos & \(Pos l c) -> Pos l (c + errorLength) + in [Token (Err err) startPos endPos] + in errsWithSourcePos >>= errorToTokens + Right ts -> postLex $ Token (Open scope) topLeftCorner topLeftCorner : ts + where + eof :: P [Token Lexeme] + eof = P.try do + p <- P.eof >> posP + n <- maybe 0 (const 1) <$> S.gets opening + l <- S.gets layout + pure $ replicate (length l + n) (Token Close p p) + errorItemToString :: EP.ErrorItem Char -> String + errorItemToString = \case + (P.Tokens ts) -> Foldable.toList ts + (P.Label ts) -> Foldable.toList ts + (P.EndOfInput) -> "end of input" + customErrs es = [Err <$> e | P.ErrorCustom e <- toList es] + toPos (P.SourcePos _ line col) = Pos (P.unPos line) (P.unPos col) + env0 = initialEnv scope + +-- | hacky postprocessing pass to do some cleanup of stuff that's annoying to +-- fix without adding more state to the lexer: +-- - 1+1 lexes as [1, +1], convert this to [1, +, 1] +-- - when a semi followed by a virtual semi, drop the virtual, lets you +-- write +-- foo x = action1; +-- 2 +-- - semi immediately after first Open is ignored +tweak :: (Token Lexeme) -> [Token Lexeme] -> [Token Lexeme] +tweak h@(Token (Semi False) _ _) (Token (Semi True) _ _ : t) = h : t +-- __NB__: This case only exists to guard against the following one +tweak h@(Token (Reserved _) _ _) t = h : t +tweak t1 (t2@(Token (Numeric num) _ _) : rem) + | notLayout t1 && touches t1 t2 && isSigned num = + t1 + : Token + (SymbolyId (HQ'.fromName (Name.unsafeParseText (Text.pack (take 1 num))))) + (start t2) + (inc $ start t2) + : Token (Numeric (drop 1 num)) (inc $ start t2) (end t2) + : rem + where + isSigned num = all (\ch -> ch == '-' || ch == '+') $ take 1 num +tweak h t = h : t + +formatTrivialError :: Set String -> Set String -> [Char] +formatTrivialError unexpectedTokens expectedTokens = + let unexpectedMsg = case Set.toList unexpectedTokens of + [] -> "I found something I didn't expect." + [x] -> + let article = case x of + (c : _) | c `elem` ("aeiou" :: String) -> "an" + _ -> "a" + in "I was surprised to find " <> article <> " " <> x <> " here." + xs -> "I was surprised to find these:\n\n* " <> List.intercalate "\n* " xs + expectedMsg = case Set.toList expectedTokens of + [] -> Nothing + xs -> Just $ "\nI was expecting one of these instead:\n\n* " <> List.intercalate "\n* " xs + in concat $ catMaybes [Just unexpectedMsg, expectedMsg] + +displayLexeme :: Lexeme -> String +displayLexeme = \case + Open o -> o + Semi True -> "end of stanza" + Semi False -> "semicolon" + Close -> "end of section" + Reserved r -> "'" <> r <> "'" + Textual t -> "\"" <> t <> "\"" + Character c -> "?" <> [c] + WordyId hq -> Text.unpack (HQ'.toTextWith Name.toText hq) + SymbolyId hq -> Text.unpack (HQ'.toTextWith Name.toText hq) + Numeric n -> n + Bytes _b -> "bytes literal" + Hash h -> Text.unpack (SH.toText h) + Err e -> show e + Doc _ -> "doc structure" + +-- | The `Doc` lexer as documented on unison-lang.org +doc2 :: P [Token Lexeme] +doc2 = do + -- Ensure we're at a doc before we start consuming tokens + P.lookAhead (lit "{{") + openStart <- posP + -- Produce any layout tokens, such as closing the last open block or virtual semicolons + -- We don't use 'token' on "{{" directly because we don't want to duplicate layout + -- tokens if we do the rewrite hack for type-docs below. + beforeStartToks <- token' ignore (pure ()) + void $ lit "{{" + openEnd <- posP + CP.space + env0 <- S.get + -- Disable layout while parsing the doc block and reset the section number + (docTok, closeTok) <- local + (\env -> env {inLayout = False}) + do + body <- Doc.doc (tokenP typeOrTerm) lexemes' . P.lookAhead $ lit "}}" + closeStart <- posP + lit "}}" + closeEnd <- posP + pure (Token (Doc body) openStart closeEnd, Token Close closeStart closeEnd) + -- Parse any layout tokens after the doc block, e.g. virtual semicolon + endToks <- token' ignore (pure ()) + -- Hack to allow anonymous doc blocks before type decls + -- {{ Some docs }} Foo.doc = {{ Some docs }} + -- ability Foo where => ability Foo where + -- + -- __FIXME__: This should be done _after_ parsing, not in lexing. + tn <- subsequentTypeName + pure $ + beforeStartToks <> case (tn) of + -- If we're followed by a type, we rewrite the doc block to be a named doc block. + Just (WordyId tname) + | isTopLevel -> + Token (WordyId (HQ'.fromName (Name.snoc (HQ'.toName tname) NameSegment.docSegment))) openStart openEnd + : Token (Open "=") openStart openEnd + : docTok + -- We need an extra 'Close' here because we added an extra Open above. + : closeTok + : endToks + where + isTopLevel = length (layout env0) + maybe 0 (const 1) (opening env0) == 1 + _ -> docTok : endToks + where + subsequentTypeName = P.lookAhead . P.optional $ do + let lit' s = lit s <* sp + let modifier = typeModifiersAlt (lit' . Text.unpack) + _ <- optional modifier *> typeOrAbility' *> sp + Token name start stop <- tokenP identifierP + if Name.isSymboly (HQ'.toName name) + then P.customFailure (Token (InvalidSymbolyId (Text.unpack (HQ'.toTextWith Name.toText name))) start stop) + else pure (WordyId name) + ignore _ _ _ = [] + -- DUPLICATED + sp = P.try $ do + spaces <- P.takeWhile1P (Just "space") isSpace + close <- P.optional (P.lookAhead (lit "}}")) + case close of + Nothing -> guard $ ok spaces + Just _ -> pure () + pure spaces + where + ok s = length [() | '\n' <- s] < 2 + +typeOrTerm :: (Monad m) => P.ParsecT (Token Err) String m (ReferenceType, HQ'.HashQualified Name) +typeOrTerm = do + mtype <- P.optional $ typeOrAbility' <* CP.space + ident <- identifierP <* CP.space + pure (maybe RtTerm (const RtType) mtype, ident) + +typeOrAbility' :: (Monad m) => P.ParsecT (Token Err) String m String +typeOrAbility' = typeOrAbilityAlt (wordyKw . Text.unpack) + where + wordyKw kw = separated wordySep (lit kw) + +lexemes' :: P () -> P [Token Lexeme] +lexemes' eof = + -- NB: `postLex` requires the token stream to start with an `Open`, otherwise it can’t create a `BlockTree`, so this + -- adds one, runs `postLex`, then removes it. + fmap (tail . postLex . (Token (Open "fake") mempty mempty :)) $ + local (const $ initialEnv "DUMMY") do + p <- lexemes $ [] <$ eof + -- deals with a final "unclosed" block at the end of `p`) + unclosed <- takeWhile (("DUMMY" /=) . fst) . layout <$> S.get + finalPos <- posP + pure $ p <> replicate (length unclosed) (Token Close finalPos finalPos) + +-- | Consumes an entire Unison “module”. +lexemes :: P [Token Lexeme] -> P [Token Lexeme] +lexemes eof = + P.optional space >> do + hd <- join <$> P.manyTill toks (P.lookAhead eof) + tl <- eof + pure $ hd <> tl + where + toks :: P [Token Lexeme] + toks = + doc2 + <|> doc + <|> token numeric + <|> token character + <|> reserved + <|> token identifierLexemeP + <|> (asum . map token) [semi, textual, hash] + + doc :: P [Token Lexeme] + doc = open <+> (CP.space *> fmap fixup body) <+> (close <* space) + where + open = token'' (\t _ _ -> t) $ tok (Open <$> lit "[:") + close = tok (Close <$ lit ":]") + at = lit "@" + -- this removes some trailing whitespace from final textual segment + fixup [] = [] + fixup (Token (Textual (reverse -> txt)) start stop : []) = + [Token (Textual txt') start stop] + where + txt' = reverse (dropWhile (\c -> isSpace c && not (c == '\n')) txt) + fixup (h : t) = h : fixup t + + body :: P [Token Lexeme] + body = txt <+> (atk <|> pure []) + where + ch = (":]" <$ lit "\\:]") <|> ("@" <$ lit "\\@") <|> (pure <$> P.anySingle) + txt = tok (Textual . join <$> P.manyTill ch (P.lookAhead sep)) + sep = void at <|> void close + ref = at *> (tok identifierLexemeP <|> docTyp) + atk = (ref <|> docTyp) <+> body + docTyp = do + _ <- lit "[" + typ <- tok (P.manyTill P.anySingle (P.lookAhead (lit "]"))) + _ <- lit "]" *> CP.space + t <- tok identifierLexemeP + pure $ (fmap Reserved <$> typ) <> t + + semi = char ';' $> Semi False + textual = Textual <$> quoted + quoted = quotedRaw <|> quotedSingleLine + quotedRaw = do + _ <- lit "\"\"\"" + n <- many (char '"') + _ <- optional (char '\n') -- initial newline is skipped + s <- P.manyTill P.anySingle (lit (replicate (length n + 3) '"')) + col0 <- column <$> posP + let col = col0 - (length n) - 3 -- this gets us first col of closing quotes + let leading = replicate (max 0 (col - 1)) ' ' + -- a last line that's equal to `leading` is ignored, since leading + -- spaces up to `col` are not considered part of the string + let tweak l = case reverse l of + last : rest + | col > 1 && last == leading -> reverse rest + | otherwise -> l + [] -> [] + pure $ case tweak (lines s) of + [] -> s + ls + | all (\l -> List.isPrefixOf leading l || all isSpace l) ls -> List.intercalate "\n" (drop (length leading) <$> ls) + | otherwise -> s + quotedSingleLine = char '"' *> P.manyTill (LP.charLiteral <|> sp) (char '"') + where + sp = lit "\\s" $> ' ' + character = Character <$> (char '?' *> (spEsc <|> LP.charLiteral)) + where + spEsc = P.try (char '\\' *> char 's' $> ' ') + + numeric = bytes <|> otherbase <|> float <|> intOrNat + where + intOrNat = P.try $ num <$> sign <*> LP.decimal + float = do + _ <- P.try (P.lookAhead (sign >> (LP.decimal :: P Int) >> (char '.' <|> char 'e' <|> char 'E'))) -- commit after this + start <- posP + sign <- fromMaybe "" <$> sign + base <- P.takeWhile1P (Just "base") isDigit + decimals <- + P.optional $ + let missingFractional = err start (MissingFractional $ base <> ".") + in liftA2 (<>) (lit ".") (P.takeWhile1P (Just "decimals") isDigit <|> missingFractional) + exp <- P.optional $ do + e <- map toLower <$> (lit "e" <|> lit "E") + sign <- fromMaybe "" <$> optional (lit "+" <|> lit "-") + let missingExp = err start (MissingExponent $ base <> fromMaybe "" decimals <> e <> sign) + exp <- P.takeWhile1P (Just "exponent") isDigit <|> missingExp + pure $ e <> sign <> exp + pure $ Numeric (sign <> base <> fromMaybe "" decimals <> fromMaybe "" exp) + + bytes = do + start <- posP + _ <- lit "0xs" + s <- map toLower <$> P.takeWhileP (Just "hexidecimal character") isAlphaNum + case Bytes.fromBase16 $ Bytes.fromWord8s (fromIntegral . ord <$> s) of + Left _ -> err start (InvalidBytesLiteral $ "0xs" <> s) + Right bs -> pure (Bytes bs) + otherbase = octal <|> hex <|> binary + octal = do + start <- posP + commitAfter2 sign (lit "0o") $ \sign _ -> + fmap (num sign) LP.octal <|> err start InvalidOctalLiteral + hex = do + start <- posP + commitAfter2 sign (lit "0x") $ \sign _ -> + fmap (num sign) LP.hexadecimal <|> err start InvalidHexLiteral + binary = do + start <- posP + commitAfter2 sign (lit "0b") $ \sign _ -> + fmap (num sign) LP.binary <|> err start InvalidBinaryLiteral + + num :: Maybe String -> Integer -> Lexeme + num sign n = Numeric (fromMaybe "" sign <> show n) + sign = P.optional (lit "+" <|> lit "-") + + hash = Hash <$> P.try shortHashP + + reserved :: P [Token Lexeme] + reserved = + token' (\ts _ _ -> ts) $ + braces + <|> parens + <|> brackets + <|> commaSeparator + <|> delim + <|> delayOrForce + <|> keywords + <|> layoutKeywords + where + keywords = + -- yes "wordy" - just like a wordy keyword like "true", the literal "." (as in the dot in + -- "forall a. a -> a") is considered the keyword "." so long as it is either followed by EOF, a space, or some + -- non-wordy character (because ".foo" is a single identifier lexeme) + wordyKw "." + <|> symbolyKw ":" + <|> openKw "@rewrite" + <|> symbolyKw "@" + <|> symbolyKw "||" + <|> symbolyKw "|" + <|> symbolyKw "&&" + <|> wordyKw "true" + <|> wordyKw "false" + <|> wordyKw "namespace" + <|> wordyKw "use" + <|> wordyKw "forall" + <|> wordyKw "∀" + <|> wordyKw "termLink" + <|> wordyKw "typeLink" + + wordyKw s = separated wordySep (kw s) + symbolyKw s = separated (not . symbolyIdChar) (kw s) + + kw :: String -> P [Token Lexeme] + kw s = tokenP (lit s) <&> \token -> [Reserved <$> token] + + layoutKeywords :: P [Token Lexeme] + layoutKeywords = + ifElse + <|> withKw + <|> openKw "match" + <|> openKw "handle" + <|> typ + <|> arr + <|> rewriteArr + <|> eq + <|> openKw "cases" + <|> openKw "where" + <|> openKw "let" + <|> openKw "do" + where + ifElse = + openKw "if" + <|> closeKw' (Just "then") ["if"] (lit "then") + <|> closeKw' (Just "else") ["then"] (lit "else") + modKw = typeModifiersAlt (openKw1 wordySep . Text.unpack) + typeOrAbilityKw = typeOrAbilityAlt (openTypeKw1 . Text.unpack) + typ = modKw <|> typeOrAbilityKw + + withKw = do + [Token _ pos1 pos2] <- wordyKw "with" + env <- S.get + let l = layout env + case findClose ["handle", "match"] l of + Nothing -> err pos1 (CloseWithoutMatchingOpen msgOpen "'with'") + where + msgOpen = "'handle' or 'match'" + Just (withBlock, n) -> do + let b = withBlock <> "-with" + S.put (env {layout = drop n l, opening = Just b}) + let opens = [Token (Open "with") pos1 pos2] + pure $ replicate n (Token Close pos1 pos2) ++ opens + + -- In `structural/unique type` and `structural/unique ability`, + -- only the `structural` or `unique` opens a layout block, + -- and `ability` and `type` are just keywords. + openTypeKw1 t = do + b <- S.gets (topBlockName . layout) + case b of + Just mod | Set.member (Text.pack mod) typeModifiers -> wordyKw t + _ -> openKw1 wordySep t + + -- layout keyword which bumps the layout column by 1, rather than looking ahead + -- to the next token to determine the layout column + openKw1 :: (Char -> Bool) -> String -> P [Token Lexeme] + openKw1 sep kw = do + Token kw pos0 pos1 <- tokenP $ separated sep (lit kw) + S.modify (\env -> env {layout = (kw, column $ inc pos0) : layout env}) + pure [Token (Open kw) pos0 pos1] + + eq = do + [Token _ start end] <- symbolyKw "=" + env <- S.get + case topBlockName (layout env) of + -- '=' does not open a layout block if within a type declaration + Just t | t == "type" || Set.member (Text.pack t) typeModifiers -> pure [Token (Reserved "=") start end] + Just _ -> S.put (env {opening = Just "="}) >> pure [Token (Open "=") start end] + _ -> err start LayoutError + + rewriteArr = do + [Token _ start end] <- symbolyKw "==>" + env <- S.get + S.put (env {opening = Just "==>"}) >> pure [Token (Open "==>") start end] + + arr = do + [Token _ start end] <- symbolyKw "->" + env <- S.get + -- -> introduces a layout block if we're inside a `match with` or `cases` + case topBlockName (layout env) of + Just match | match `elem` matchWithBlocks -> do + S.put (env {opening = Just "->"}) + pure [Token (Open "->") start end] + _ -> pure [Token (Reserved "->") start end] + + -- a bit of lookahead here to reserve }} for closing a documentation block + braces = open "{" <|> close ["{"] p + where + p = do + l <- lit "}" + -- if we're within an existing {{ }} block, inLayout will be false + -- so we can actually allow }} to appear in normal code + inLayout <- S.gets inLayout + when (not inLayout) $ void $ P.lookAhead (P.satisfy (/= '}')) + pure l + matchWithBlocks = ["match-with", "cases"] + parens = open "(" <|> close ["("] (lit ")") + brackets = open "[" <|> close ["["] (lit "]") + -- `allowCommaToClose` determines if a comma should close inner blocks. + -- Currently there is a set of blocks where `,` is not treated specially + -- and it just emits a Reserved ",". There are currently only three: + -- `cases`, `match-with`, and `{` + allowCommaToClose match = not $ match `elem` ("{" : matchWithBlocks) + commaSeparator = do + env <- S.get + case topBlockName (layout env) of + Just match + | allowCommaToClose match -> + blockDelimiter ["[", "("] (lit ",") + _ -> fail "this comma is a pattern separator" + + delim = P.try $ do + ch <- P.satisfy (\ch -> ch /= ';' && Set.member ch delimiters) + pos <- posP + pure [Token (Reserved [ch]) pos (inc pos)] + + delayOrForce = separated ok $ do + token <- tokenP $ P.satisfy isDelayOrForce + pure [token <&> \op -> Reserved [op]] + where + ok c = isDelayOrForce c || isSpace c || isAlphaNum c || Set.member c delimiters || c == '\"' + +open :: String -> P [Token Lexeme] +open b = do + token <- tokenP $ lit b + env <- S.get + S.put (env {opening = Just b}) + pure [Open b <$ token] + +openKw :: String -> P [Token Lexeme] +openKw s = separated wordySep $ do + token <- tokenP $ lit s + env <- S.get + S.put (env {opening = Just s}) + pure [Open <$> token] + +tok :: P a -> P [Token a] +tok p = do + token <- tokenP p + pure [token] + +-- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is +-- symboly (comprised of only symbols) or wordy (comprised of only alphanums). +-- +-- Examples: +-- +-- foo +-- .foo.++.doc +-- `.`.`..` (This is a two-segment identifier without a leading dot: "." then "..") +identifierP :: (Monad m) => P.ParsecT (Token Err) String m (HQ'.HashQualified Name) +identifierP = do + P.label "identifier (ex: abba1, snake_case, .foo.bar#xyz, .foo.++#xyz, or 🌻)" do + name <- PI.withParsecT (fmap nameSegmentParseErrToErr) Name.nameP + P.optional shortHashP <&> \case + Nothing -> HQ'.fromName name + Just shorthash -> HQ'.HashQualified name shorthash + where + nameSegmentParseErrToErr :: NameSegment.ParseErr -> Err + nameSegmentParseErrToErr = \case + NameSegment.ReservedOperator s -> ReservedSymbolyId (Text.unpack s) + NameSegment.ReservedWord s -> ReservedWordyId (Text.unpack s) + +-- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is +-- symboly (comprised of only symbols) or wordy (comprised of only alphanums). +-- +-- Examples: +-- +-- foo +-- .foo.++.doc +-- `.`.`..` (This is a two-segment identifier without a leading dot: "." then "..") +identifierLexemeP :: P Lexeme +identifierLexemeP = identifierLexeme <$> identifierP + +identifierLexeme :: HQ'.HashQualified Name -> Lexeme +identifierLexeme name = + if Name.isSymboly (HQ'.toName name) + then SymbolyId name + else WordyId name + +shortHashP :: P.ParsecT (Token Err) String m ShortHash +shortHashP = + PI.withParsecT (fmap (InvalidShortHash . Text.unpack)) ShortHash.shortHashP + +blockDelimiter :: [String] -> P String -> P [Token Lexeme] +blockDelimiter open closeP = do + Token close pos1 pos2 <- tokenP closeP + env <- S.get + case findClose open (layout env) of + Nothing -> err pos1 (UnexpectedDelimiter (quote close)) + where + quote s = "'" <> s <> "'" + Just (_, n) -> do + S.put (env {layout = drop (n - 1) (layout env)}) + let delims = [Token (Reserved close) pos1 pos2] + pure $ replicate (n - 1) (Token Close pos1 pos2) ++ delims + +close :: [String] -> P String -> P [Token Lexeme] +close = close' Nothing + +closeKw' :: Maybe String -> [String] -> P String -> P [Token Lexeme] +closeKw' reopenBlockname open closeP = close' reopenBlockname open (separated wordySep closeP) + +close' :: Maybe String -> [String] -> P String -> P [Token Lexeme] +close' reopenBlockname open closeP = do + Token close pos1 pos2 <- tokenP closeP + env <- S.get + case findClose open (layout env) of + Nothing -> err pos1 (CloseWithoutMatchingOpen msgOpen (quote close)) + where + msgOpen = List.intercalate " or " (quote <$> open) + quote s = "'" <> s <> "'" + Just (_, n) -> do + S.put (env {layout = drop n (layout env), opening = reopenBlockname}) + let opens = maybe [] (const $ [Token (Open close) pos1 pos2]) reopenBlockname + pure $ replicate n (Token Close pos1 pos2) ++ opens + +findClose :: [String] -> Layout -> Maybe (String, Int) +findClose _ [] = Nothing +findClose s ((h, _) : tl) = if h `elem` s then Just (h, 1) else fmap (1 +) <$> findClose s tl + +notLayout :: Token Lexeme -> Bool +notLayout t = case payload t of + Close -> False + Semi _ -> False + Open _ -> False + _ -> True + +top :: Layout -> Column +top [] = 1 +top ((_, h) : _) = h + +-- todo: make Layout a NonEmpty +topBlockName :: Layout -> Maybe BlockName +topBlockName [] = Nothing +topBlockName ((name, _) : _) = Just name + +topLeftCorner :: Pos +topLeftCorner = Pos 1 1 + +data BlockTree a + = Block + -- | The token that opens the block + a + -- | “Stanzas” of nested tokens + [[BlockTree a]] + -- | The closing token, if any + (Maybe a) + | Leaf a + deriving (Functor, Foldable, Traversable) + +headToken :: BlockTree a -> a +headToken (Block a _ _) = a +headToken (Leaf a) = a + +instance (Show a) => Show (BlockTree a) where + showsPrec = showsPrec1 + +-- | This instance should be compatible with `Read`, but inserts newlines and indentation to make it more +-- /human/-readable. +instance Show1 BlockTree where + liftShowsPrec spa sla = shows "" + where + shows by prec = + showParen (prec > appPrec) . \case + Leaf a -> showString "Leaf " . showsNext spa "" a + Block open mid close -> + showString "Block " + . showsNext spa "" open + . showString "\n" + . showIndentedList (showIndentedList (\b -> showsIndented (shows b 0) b)) (" " <> by) mid + . showString "\n" + . showsNext (liftShowsPrec spa sla) (" " <> by) close + appPrec = 10 + showsNext :: (Int -> x -> ShowS) -> String -> x -> ShowS + showsNext fn = showsIndented (fn $ appPrec + 1) + showsIndented :: (x -> ShowS) -> String -> x -> ShowS + showsIndented fn by x = showString by . fn x + showIndentedList :: (String -> x -> ShowS) -> String -> [x] -> ShowS + showIndentedList fn by xs = + showString by + . showString "[" + . foldr (\x acc -> showString "\n" . fn (" " <> by) x . showString "," . acc) id xs + . showString "\n" + . showString by + . showString "]" + +reorderTree :: ([[BlockTree a]] -> [[BlockTree a]]) -> BlockTree a -> BlockTree a +reorderTree f (Block open mid close) = Block open (f (fmap (reorderTree f) <$> mid)) close +reorderTree _ l = l + +tree :: [Token Lexeme] -> BlockTree (Token Lexeme) +tree toks = one toks const + where + one (open@(payload -> Open _) : ts) k = many (Block open . stanzas) [] ts k + one (t : ts) k = k (Leaf t) ts + one [] k = k lastErr [] + where + lastErr = Leaf case drop (length toks - 1) toks of + [] -> Token (Err LayoutError) topLeftCorner topLeftCorner + (t : _) -> t {payload = Err LayoutError} + + many open acc [] k = k (open (reverse acc) Nothing) [] + many open acc (t@(payload -> Close) : ts) k = k (open (reverse acc) $ pure t) ts + many open acc ts k = one ts $ \t ts -> many open (t : acc) ts k + +stanzas :: [BlockTree (Token Lexeme)] -> [[BlockTree (Token Lexeme)]] +stanzas = + toList + . foldr + ( \tok (curr :| stanzas) -> case tok of + Leaf (Token (Semi _) _ _) -> [tok] :| curr : stanzas + _ -> (tok : curr) :| stanzas + ) + ([] :| []) + +-- Moves type and ability declarations to the front of the token stream (but not before the leading optional namespace +-- directive) and move `use` statements to the front of each block +reorder :: [[BlockTree (Token Lexeme)]] -> [[BlockTree (Token Lexeme)]] +reorder = foldr fixup [] . sortWith f + where + f [] = 4 :: Int + f (t0 : _) = case payload $ headToken t0 of + Open mod | Set.member (Text.pack mod) typeModifiers -> 3 + Open typOrA | Set.member (Text.pack typOrA) typeOrAbility -> 3 + -- put `namespace` before `use` because the file parser only accepts a namespace directive at the top of the file + Reserved "namespace" -> 1 + Reserved "use" -> 2 + _ -> 4 :: Int + -- after reordering can end up with trailing semicolon at the end of + -- a block, which we remove with this pass + fixup stanza [] = case Lens.unsnoc stanza of + Nothing -> [] + -- remove any trailing `Semi` from the last non-empty stanza + Just (init, Leaf (Token (Semi _) _ _)) -> [init] + -- don’t touch other stanzas + Just (_, _) -> [stanza] + fixup stanza tail = stanza : tail + +-- | This turns the lexeme stream into a tree, reordering some lexeme subsequences. +preParse :: [Token Lexeme] -> BlockTree (Token Lexeme) +preParse = reorderTree reorder . tree + +-- | A few transformations that happen between lexing and parsing. +-- +-- All of these things should move out of the lexer, and be applied in the parse. +postLex :: [Token Lexeme] -> [Token Lexeme] +postLex = toList . preParse . foldr tweak [] + +isDelayOrForce :: Char -> Bool +isDelayOrForce op = op == '\'' || op == '!' + +-- Mapping between characters and their escape codes. Use parse/showEscapeChar to convert. +escapeChars :: [(Char, Char)] +escapeChars = + [ ('0', '\0'), + ('a', '\a'), + ('b', '\b'), + ('f', '\f'), + ('n', '\n'), + ('r', '\r'), + ('t', '\t'), + ('v', '\v'), + ('s', ' '), + ('\'', '\''), + ('"', '"'), + ('\\', '\\') + ] + +-- Inverse of parseEscapeChar; map a character to its escaped version: +showEscapeChar :: Char -> Maybe Char +showEscapeChar c = + Map.lookup c (Map.fromList [(x, y) | (y, x) <- escapeChars]) + +typeModifiersAlt :: (Alternative f) => (Text -> f a) -> f a +typeModifiersAlt f = + asum $ map f (toList typeModifiers) + +debugFilePreParse :: FilePath -> IO () +debugFilePreParse file = putStrLn . debugPreParse . preParse . lexer file . Text.unpack =<< readUtf8 file + +debugPreParse :: BlockTree (Token Lexeme) -> String +debugPreParse (Leaf (Token (Err (UnexpectedTokens msg)) start end)) = + (if start == end then msg1 else msg2) <> ":\n" <> msg + where + msg1 = "Error on line " <> show (line start) <> ", column " <> show (column start) + msg2 = + "Error on line " + <> show (line start) + <> ", column " + <> show (column start) + <> " - line " + <> show (line end) + <> ", column " + <> show (column end) +debugPreParse ts = show $ payload <$> ts + +debugPreParse' :: String -> String +debugPreParse' = debugPreParse . preParse . lexer "debugPreParse" + +instance EP.ShowErrorComponent (Token Err) where + showErrorComponent (Token err _ _) = go err + where + go = \case + UnexpectedTokens msg -> msg + CloseWithoutMatchingOpen open close -> "I found a closing " <> close <> " but no matching " <> open <> "." + Both e1 e2 -> go e1 <> "\n" <> go e2 + LayoutError -> "Indentation error" + TextLiteralMissingClosingQuote s -> "This text literal missing a closing quote: " <> excerpt s + e -> show e + excerpt s = if length s < 15 then s else take 15 s <> "..." + +instance P.VisualStream [Token Lexeme] where + showTokens _ xs = + join . Nel.toList . S.evalState (traverse go xs) . end $ Nel.head xs + where + go :: Token Lexeme -> S.State Pos String + go tok = do + prev <- S.get + S.put $ end tok + pure $ pad prev (start tok) ++ pretty (payload tok) + pretty (Open s) = s + pretty (Reserved w) = w + pretty (Textual t) = '"' : t ++ ['"'] + pretty (Character c) = + case showEscapeChar c of + Just c -> "?\\" ++ [c] + Nothing -> '?' : [c] + pretty (WordyId n) = Text.unpack (HQ'.toText n) + pretty (SymbolyId n) = Text.unpack (HQ'.toText n) + pretty (Numeric n) = n + pretty (Hash sh) = show sh + pretty (Err e) = show e + pretty (Bytes bs) = "0xs" <> show bs + pretty Close = "" + pretty (Semi True) = "" + pretty (Semi False) = ";" + pretty (Doc d) = show d + pad (Pos line1 col1) (Pos line2 col2) = + if line1 == line2 + then replicate (col2 - col1) ' ' + else replicate (line2 - line1) '\n' ++ replicate col2 ' ' diff --git a/unison-syntax/src/Unison/Syntax/Name.hs b/unison-syntax/src/Unison/Syntax/Name.hs index 17112b6b95..a0de444b2b 100644 --- a/unison-syntax/src/Unison/Syntax/Name.hs +++ b/unison-syntax/src/Unison/Syntax/Name.hs @@ -85,7 +85,7 @@ toText (Name pos (x0 :| xs)) = Relative -> "" -- | Parse a name from a var, by first rendering the var as a string. -parseVar :: Var v => v -> Maybe Name +parseVar :: (Var v) => v -> Maybe Name parseVar = parseText . Var.name @@ -105,7 +105,7 @@ toVar = -- Name parsers -- | A name parser. -nameP :: Monad m => ParsecT (Token NameSegment.ParseErr) [Char] m Name +nameP :: (Monad m) => ParsecT (Token NameSegment.ParseErr) [Char] m Name nameP = P.try do leadingDot <- isJust <$> P.optional (P.char '.') @@ -113,7 +113,7 @@ nameP = pure (if leadingDot then Name.makeAbsolute name else name) -- | A relative name parser. -relativeNameP :: forall m. Monad m => ParsecT (Token NameSegment.ParseErr) [Char] m Name +relativeNameP :: forall m. (Monad m) => ParsecT (Token NameSegment.ParseErr) [Char] m Name relativeNameP = do Name.fromSegments <$> Monad.sepBy1 NameSegment.segmentP separatorP where @@ -123,7 +123,7 @@ relativeNameP = do -- This allows (for example) the "a." in "forall a. a -> a" to successfully parse as an identifier "a" followed by -- the reserved symbol ".", rathern than fail to parse as an identifier, because it looks like the prefix of some -- "a.b" that stops in the middle. - separatorP :: Ord e => ParsecT e [Char] m Char + separatorP :: (Ord e) => ParsecT e [Char] m Char separatorP = P.try do c <- P.char '.' diff --git a/unison-syntax/src/Unison/Syntax/Parser.hs b/unison-syntax/src/Unison/Syntax/Parser.hs index 28bbdf042e..b013075145 100644 --- a/unison-syntax/src/Unison/Syntax/Parser.hs +++ b/unison-syntax/src/Unison/Syntax/Parser.hs @@ -1,20 +1,25 @@ {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Unison.Syntax.Parser ( Annotated (..), Err, Error (..), - Input, + -- FIXME: Don’t export the data constructor + Input (..), P, ParsingEnv (..), - UniqueName, + UniqueName (..), anyToken, blank, bytesToken, chainl1, chainr1, + chainl1Accum, character, closeBlock, + optionalCloseBlock, + doc, failCommitted, failureIf, hqInfixId, @@ -33,12 +38,14 @@ module Unison.Syntax.Parser prefixTermName, queryToken, reserved, + resolveUniqueTypeGuid, root, rootFile, run', run, semi, Unison.Syntax.Parser.seq, + Unison.Syntax.Parser.seq', sepBy, sepBy1, string, @@ -53,9 +60,10 @@ module Unison.Syntax.Parser ) where -import Control.Monad.Reader (ReaderT (..)) +import Control.Monad.Reader (ReaderT (..), ask) import Control.Monad.Reader.Class (asks) import Crypto.Random qualified as Random +import Data.Bool (bool) import Data.Bytes.Put (runPutS) import Data.Bytes.Serial (serialize) import Data.Bytes.VarInt (VarInt (..)) @@ -66,24 +74,30 @@ import Data.Set qualified as Set import Data.Text qualified as Text import Text.Megaparsec (runParserT) import Text.Megaparsec qualified as P +import U.Codebase.Reference (ReferenceType (..)) import U.Util.Base32Hex qualified as Base32Hex import Unison.ABT qualified as ABT -import Unison.ConstructorReference (ConstructorReference) +import Unison.DataDeclaration (Modifier (Unique)) import Unison.Hash qualified as Hash import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Hashable qualified as Hashable import Unison.Name as Name +import Unison.NameSegment (NameSegment) +import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Names.ResolutionResult qualified as Names -import Unison.Parser.Ann (Ann (..)) +import Unison.Parser.Ann (Ann (..), Annotated (..)) import Unison.Pattern (Pattern) import Unison.Pattern qualified as Pattern import Unison.Prelude import Unison.Reference (Reference) import Unison.Referent (Referent) -import Unison.Syntax.Lexer qualified as L -import Unison.Syntax.Name qualified as Name (toVar, unsafeParseText) +import Unison.Syntax.Lexer.Unison qualified as L +import Unison.Syntax.Name qualified as Name (toVar, unsafeParseVar) +import Unison.Syntax.Parser.Doc qualified as Doc +import Unison.Syntax.Parser.Doc.Data qualified as Doc +import Unison.Syntax.Var qualified as Var import Unison.Term (MatchCase (..)) import Unison.UnisonFile.Error qualified as UF import Unison.Util.Bytes (Bytes) @@ -106,7 +120,36 @@ data ParsingEnv (m :: Type -> Type) = ParsingEnv -- The name (e.g. `Foo` in `unique type Foo`) is passed in, and if the function returns a Just, that GUID is used; -- otherwise, a random one is generated from `uniqueNames`. uniqueTypeGuid :: Name -> m (Maybe Text), - names :: Names + names :: Names, + -- The namespace block we are currently parsing under, and the file-bound namespace-prefixed type and constructor + -- names in scope (we've already parsed all type declarations by the time we need this, in the term parser). + -- + -- Ideally these ought to have no affect on parsing: "applying" a namespace should be a pre-processing pass. All + -- bindings are prefixed with the namespace (easy), and all free variables that match a binding are prefixed (also + -- easy). + -- + -- ... but our "parser" is also doing parse-time name resolution for hash-qualified names, type references, + -- constructors in patterns, and term/type links. + -- + -- For constructors in patterns, when parsing a pattern `Foo.Bar` in a namespace `baz`, if `baz.Foo.Bar` is among + -- the file-bound namespace-prefixed constructor names in scope, then resolve to that constructor. Otherwise, + -- proceed as normal to look for `Foo.Bar` in the names environment. + -- + -- For type links, similar deal: we (only because we parse and hash all types before terms) could conceivably + -- properly handle code like + -- + -- namespace foo + -- type Bar = ... + -- baz = ... typeLink Bar ... + -- + -- And for term links we are certainly out of luck: we can't look up a resolved file-bound term by hash *during + -- parsing*. That's an issue with term links in general, unrelated to namespaces, but perhaps complicated by + -- namespaces nonetheless. + -- + -- New development: this namespace is now also used during decl parsing, because in order to accurately reuse a + -- unique type guid we need to look up by namespaced name. + maybeNamespace :: Maybe Name, + localNamespacePrefixedTypesAndConstructors :: Names } newtype UniqueName = UniqueName (L.Pos -> Int -> Maybe Text) @@ -143,29 +186,38 @@ uniqueName lenInBase32Hex = do let none = Base32Hex.toText . Base32Hex.fromByteString . encodeUtf8 . Text.pack $ show pos pure . fromMaybe none $ mkName pos lenInBase32Hex +resolveUniqueTypeGuid :: (Monad m, Var v) => v -> P v m Modifier +resolveUniqueTypeGuid name0 = do + ParsingEnv {maybeNamespace, uniqueTypeGuid} <- ask + let name = Name.unsafeParseVar (maybe id (Var.namespaced2 . Name.toVar) maybeNamespace name0) + guid <- + lift (lift (uniqueTypeGuid name)) >>= \case + Nothing -> uniqueName 32 + Just guid -> pure guid + pure (Unique guid) + data Error v = SignatureNeedsAccompanyingBody (L.Token v) | DisallowedAbsoluteName (L.Token Name) | EmptyBlock (L.Token String) - | UnknownAbilityConstructor (L.Token (HQ.HashQualified Name)) (Set ConstructorReference) - | UnknownDataConstructor (L.Token (HQ.HashQualified Name)) (Set ConstructorReference) | UnknownTerm (L.Token (HQ.HashQualified Name)) (Set Referent) | UnknownType (L.Token (HQ.HashQualified Name)) (Set Reference) | UnknownId (L.Token (HQ.HashQualified Name)) (Set Referent) (Set Reference) | ExpectedBlockOpen String (L.Token L.Lexeme) - | -- Indicates a cases or match/with which doesn't have any patterns - EmptyMatch (L.Token ()) | EmptyWatch Ann | UseInvalidPrefixSuffix (Either (L.Token Name) (L.Token Name)) (Maybe [L.Token Name]) | UseEmpty (L.Token String) -- an empty `use` statement | DidntExpectExpression (L.Token L.Lexeme) (Maybe (L.Token L.Lexeme)) | TypeDeclarationErrors [UF.Error v Ann] - | -- MissingTypeModifier (type|ability) name + | -- | MissingTypeModifier (type|ability) name MissingTypeModifier (L.Token String) (L.Token v) - | ResolutionFailures [Names.ResolutionFailure v Ann] + | -- | A type was found in a position that requires a term + TypeNotAllowed (L.Token (HQ.HashQualified Name)) + | ResolutionFailures [Names.ResolutionFailure Ann] | DuplicateTypeNames [(v, [Ann])] | DuplicateTermNames [(v, [Ann])] - | PatternArityMismatch Int Int Ann -- PatternArityMismatch expectedArity actualArity location + | -- | PatternArityMismatch expectedArity actualArity location + PatternArityMismatch Int Int Ann | FloatPattern Ann deriving (Show, Eq, Ord) @@ -176,25 +228,12 @@ newtype Input = Input {inputStream :: [L.Token L.Lexeme]} deriving stock (Eq, Ord, Show) deriving newtype (P.Stream, P.VisualStream) -class Annotated a where - ann :: a -> Ann - -instance Annotated Ann where - ann = id - -instance Annotated (L.Token a) where - ann (L.Token _ s e) = Ann s e - instance (Annotated a) => Annotated (ABT.Term f v a) where ann = ann . ABT.annotation instance (Annotated a) => Annotated (Pattern a) where ann = ann . Pattern.loc -instance (Annotated a) => Annotated [a] where - ann [] = mempty - ann (h : t) = foldl' (\acc a -> acc <> ann a) (ann h) t - instance (Annotated a, Annotated b) => Annotated (MatchCase a b) where ann (MatchCase p _ b) = ann p <> ann b @@ -206,8 +245,7 @@ label = P.label traceRemainingTokens :: (Ord v) => String -> P v m () traceRemainingTokens label = do remainingTokens <- lookAhead $ many anyToken - let _ = - trace ("REMAINDER " ++ label ++ ":\n" ++ L.debugLex'' remainingTokens) () + let _ = trace ("REMAINDER " ++ label ++ ":\n" ++ L.debugPreParse (L.preParse remainingTokens)) () pure () mkAnn :: (Annotated a, Annotated b) => a -> b -> Ann @@ -238,23 +276,20 @@ rootFile p = p <* P.eof run' :: (Monad m, Ord v) => P v m a -> String -> String -> ParsingEnv m -> m (Either (Err v) a) run' p s name env = - let lex = - if debug - then L.lexer name (trace (L.debugLex''' "lexer receives" s) s) - else L.lexer name s + let lex = bool id (traceWith L.debugPreParse) debug . L.preParse $ L.lexer name s pTraced = traceRemainingTokens "parser receives" *> p - in runReaderT (runParserT pTraced name (Input lex)) env <&> \case + in runReaderT (runParserT pTraced name . Input $ toList lex) env <&> \case Left err -> Left (Nel.head (P.bundleErrors err)) Right x -> Right x run :: (Monad m, Ord v) => P v m a -> String -> ParsingEnv m -> m (Either (Err v) a) run p s = run' p s "" --- Virtual pattern match on a lexeme. +-- | Virtual pattern match on a lexeme. queryToken :: (Ord v) => (L.Lexeme -> Maybe a) -> P v m (L.Token a) queryToken f = P.token (traverse f) Set.empty --- Consume a block opening and return the string that opens the block. +-- | Consume a block opening and return the string that opens the block. openBlock :: (Ord v) => P v m (L.Token String) openBlock = queryToken getOpen where @@ -264,72 +299,84 @@ openBlock = queryToken getOpen openBlockWith :: (Ord v) => String -> P v m (L.Token ()) openBlockWith s = void <$> P.satisfy ((L.Open s ==) . L.payload) --- Match a particular lexeme exactly, and consume it. +-- | Match a particular lexeme exactly, and consume it. matchToken :: (Ord v) => L.Lexeme -> P v m (L.Token L.Lexeme) matchToken x = P.satisfy ((==) x . L.payload) --- Consume a virtual semicolon +-- | Consume a virtual semicolon semi :: (Ord v) => P v m (L.Token ()) semi = label "newline or semicolon" $ queryToken go where go (L.Semi _) = Just () go _ = Nothing --- Consume the end of a block +-- | Consume the end of a block closeBlock :: (Ord v) => P v m (L.Token ()) closeBlock = void <$> matchToken L.Close -wordyPatternName :: Var v => P v m (L.Token v) +-- | With layout, blocks might “close” without an explicit outdent (e.g., not even a newline at the end of a +-- `Doc.Transclude`). This allows those blocks to be closed by EOF. +optionalCloseBlock :: (Ord v) => P v m (L.Token ()) +optionalCloseBlock = closeBlock <|> (\() -> L.Token () mempty mempty) <$> P.eof + +-- | A `Name` is blank when it is unqualified and begins with a `_` (also implying that it is wordy) +isBlank :: Name -> Bool +isBlank n = isUnqualified n && Text.isPrefixOf "_" (NameSegment.toUnescapedText $ lastSegment n) + +-- | A HQ Name is blank when its Name is blank and it has no hash. +isBlank' :: HQ'.HashQualified Name -> Bool +isBlank' = \case + HQ'.NameOnly n -> isBlank n + HQ'.HashQualified _ _ -> False + +wordyPatternName :: (Var v) => P v m (L.Token v) wordyPatternName = queryToken \case - L.WordyId (HQ'.NameOnly n) -> Just $ Name.toVar n + L.WordyId (HQ'.NameOnly n) -> if isBlank n then Nothing else Just $ Name.toVar n _ -> Nothing --- Parse an prefix identifier e.g. Foo or (+), discarding any hash +-- | Parse a prefix identifier e.g. Foo or (+), discarding any hash prefixDefinitionName :: (Var v) => P v m (L.Token v) prefixDefinitionName = wordyDefinitionName <|> parenthesize symbolyDefinitionName --- Parse a prefix identifier e.g. Foo or (+), rejecting any hash --- This is useful for term declarations, where type signatures and term names should not have hashes. +-- | Parse a prefix identifier e.g. Foo or (+), rejecting any hash +-- This is useful for term declarations, where type signatures and term names should not have hashes. prefixTermName :: (Var v) => P v m (L.Token v) prefixTermName = wordyTermName <|> parenthesize symbolyTermName where wordyTermName = queryToken \case L.WordyId (HQ'.NameOnly n) -> Just $ Name.toVar n - L.Blank s -> Just $ Var.nameds ("_" <> s) _ -> Nothing symbolyTermName = queryToken \case L.SymbolyId (HQ'.NameOnly n) -> Just $ Name.toVar n _ -> Nothing --- Parse a wordy identifier e.g. Foo, discarding any hash -wordyDefinitionName :: Var v => P v m (L.Token v) -wordyDefinitionName = queryToken $ \case +-- | Parse a wordy identifier e.g. Foo, discarding any hash +wordyDefinitionName :: (Var v) => P v m (L.Token v) +wordyDefinitionName = queryToken \case L.WordyId n -> Just $ Name.toVar (HQ'.toName n) - L.Blank s -> Just $ Var.nameds ("_" <> s) _ -> Nothing --- Parse a wordyId as a Name, rejecting any hash -importWordyId :: Ord v => P v m (L.Token Name) +-- | Parse a wordyId as a Name, rejecting any hash +importWordyId :: (Ord v) => P v m (L.Token Name) importWordyId = queryToken \case L.WordyId (HQ'.NameOnly n) -> Just n - L.Blank s | not (null s) -> Just $ Name.unsafeParseText (Text.pack ("_" <> s)) _ -> Nothing --- The `+` in: use Foo.bar + as a Name -importSymbolyId :: Ord v => P v m (L.Token Name) +-- | The `+` in: use Foo.bar + as a Name +importSymbolyId :: (Ord v) => P v m (L.Token Name) importSymbolyId = queryToken \case L.SymbolyId (HQ'.NameOnly n) -> Just n _ -> Nothing --- Parse a symboly ID like >>= or &&, discarding any hash -symbolyDefinitionName :: Var v => P v m (L.Token v) +-- | Parse a symboly ID like >>= or &&, discarding any hash +symbolyDefinitionName :: (Var v) => P v m (L.Token v) symbolyDefinitionName = queryToken $ \case L.SymbolyId n -> Just $ Name.toVar (HQ'.toName n) _ -> Nothing -- | Expect parentheses around a token, includes the parentheses within the start/end --- annotations of the resulting token. +-- annotations of the resulting token. parenthesize :: (Ord v) => P v m (L.Token a) -> P v m (L.Token a) parenthesize p = do (start, a) <- P.try do @@ -343,32 +390,31 @@ hqPrefixId, hqInfixId :: (Ord v) => P v m (L.Token (HQ.HashQualified Name)) hqPrefixId = hqWordyId_ <|> parenthesize hqSymbolyId_ hqInfixId = hqSymbolyId_ --- Parse a hash-qualified alphanumeric identifier -hqWordyId_ :: Ord v => P v m (L.Token (HQ.HashQualified Name)) +-- | Parse a hash-qualified alphanumeric identifier +hqWordyId_ :: (Ord v) => P v m (L.Token (HQ.HashQualified Name)) hqWordyId_ = queryToken \case L.WordyId n -> Just $ HQ'.toHQ n L.Hash h -> Just $ HQ.HashOnly h - L.Blank s | not (null s) -> Just $ HQ.NameOnly (Name.unsafeParseText (Text.pack ("_" <> s))) _ -> Nothing --- Parse a hash-qualified symboly ID like >>=#foo or && -hqSymbolyId_ :: Ord v => P v m (L.Token (HQ.HashQualified Name)) +-- | Parse a hash-qualified symboly ID like >>=#foo or && +hqSymbolyId_ :: (Ord v) => P v m (L.Token (HQ.HashQualified Name)) hqSymbolyId_ = queryToken \case L.SymbolyId n -> Just (HQ'.toHQ n) _ -> Nothing --- Parse a reserved word +-- | Parse a reserved word reserved :: (Ord v) => String -> P v m (L.Token String) reserved w = label w $ queryToken getReserved where getReserved (L.Reserved w') | w == w' = Just w getReserved _ = Nothing --- Parse a placeholder or typed hole -blank :: (Ord v) => P v m (L.Token String) +-- | Parse a placeholder or typed hole +blank :: (Ord v) => P v m (L.Token NameSegment) blank = label "blank" $ queryToken getBlank where - getBlank (L.Blank s) = Just ('_' : s) + getBlank (L.WordyId n) = if isBlank' n then Just (Name.lastSegment $ HQ'.toName n) else Nothing getBlank _ = Nothing numeric :: (Ord v) => P v m (L.Token String) @@ -404,11 +450,18 @@ string = queryToken getString getString (L.Textual s) = Just (Text.pack s) getString _ = Nothing +doc :: + (Ord v) => + P v m (L.Token (Doc.UntitledSection (Doc.Tree (L.Token (ReferenceType, HQ'.HashQualified Name)) [L.Token L.Lexeme]))) +doc = queryToken \case + L.Doc d -> pure d + _ -> Nothing + -- | Parses a tuple of 'a's, or a single parenthesized 'a' -- -- returns the result of combining elements with 'pair', alongside the annotation containing -- the full parenthesized expression. -tupleOrParenthesized :: Ord v => P v m a -> (Ann -> a) -> (a -> a -> a) -> P v m (Ann {- spanAnn -}, a) +tupleOrParenthesized :: (Ord v) => P v m a -> (Ann -> a) -> (a -> a -> a) -> P v m (Ann {- spanAnn -}, a) tupleOrParenthesized p unit pair = do seq' "(" go p where @@ -434,12 +487,33 @@ chainr1 p op = go1 go1 = p >>= go2 go2 hd = do { op <- op; op hd <$> go1 } <|> pure hd --- Parse `p` 1+ times, combining with `op` +-- | Parse `p` 1+ times, combining with `op` chainl1 :: (Ord v) => P v m a -> P v m (a -> a -> a) -> P v m a chainl1 p op = foldl (flip ($)) <$> p <*> P.many (flip <$> op <*> p) --- If `p` would succeed, this fails uncommitted. --- Otherwise, `failIfOk` used to produce the output +-- chainl1Accum is like chainl1, but it accumulates intermediate results +-- instead of applying them immediately. It's used to implement infix +-- operators that may or may not have precedence rules. +chainl1Accum :: + (P.Stream u, Ord s) => + P.ParsecT s u m a -> + P.ParsecT s u m (a -> a -> a) -> + P.ParsecT s u m (a, [a -> a]) +chainl1Accum p op = do + x <- p + fs <- rest [] + pure (x, fs) + where + rest fs = + ( do + f <- op + y <- p + rest (fs ++ [flip f y]) + ) + <|> return fs + +-- | If `p` would succeed, this fails uncommitted. +-- Otherwise, `failIfOk` used to produce the output failureIf :: (Ord v) => P v m (P v m b) -> P v m a -> P v m b failureIf failIfOk p = do dontwant <- P.try . P.lookAhead $ failIfOk @@ -447,9 +521,9 @@ failureIf failIfOk p = do when (isJust p) $ fail "failureIf" dontwant --- Gives this var an id based on its position - a useful trick to --- obtain a variable whose id won't match any other id in the file --- `positionalVar a Var.missingResult` +-- | Gives this var an id based on its position - a useful trick to +-- obtain a variable whose id won't match any other id in the file +-- `positionalVar a Var.missingResult` positionalVar :: (Annotated a, Var v) => a -> v -> v positionalVar a v = let s = start (ann a) diff --git a/unison-syntax/src/Unison/Syntax/Parser/Doc.hs b/unison-syntax/src/Unison/Syntax/Parser/Doc.hs new file mode 100644 index 0000000000..715666866f --- /dev/null +++ b/unison-syntax/src/Unison/Syntax/Parser/Doc.hs @@ -0,0 +1,590 @@ +-- | The parser for Unison’s @Doc@ syntax. +-- +-- This is completely independent of the Unison language, and requires a couple parsers to be passed in to then +-- provide a parser for @Doc@ applied to any host language. +-- +-- - an identifer parser +-- - a code parser (that accepts a termination parser) +-- - a termination parser, for this parser to know when to give up +-- +-- Each of those parsers is expected to satisfy @(`Ord` e, `P.MonadParsec` e `String` m)@. +module Unison.Syntax.Parser.Doc + ( Tree, + Leaves, + initialEnv, + doc, + untitledSection, + sectionElem, + leaf, + + -- * section elements + section, + eval, + exampleBlock, + codeBlock, + list, + bulletedList, + numberedList, + paragraph, + + -- * leaves + link, + namedLink, + example, + transclude, + bold, + italic, + strikethrough, + verbatim, + keyedInline, + group, + word, + + -- * other components + column', + embedLink, + join, + ) +where + +import Control.Comonad.Cofree (Cofree ((:<))) +import Control.Monad.Reader qualified as R +import Data.Char (isControl, isSpace) +import Data.List qualified as List +import Data.List.Extra qualified as List +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Text.Megaparsec qualified as P +import Text.Megaparsec.Char (char, letterChar) +import Text.Megaparsec.Char qualified as CP +import Text.Megaparsec.Char.Lexer qualified as LP +import Unison.Parser.Ann (Ann (Ann)) +import Unison.Prelude hiding (Word, join) +import Unison.Syntax.Lexer (column, line, lit, sepBy1', some', someTill', (<+>)) +import Unison.Syntax.Lexer.Token (Token (Token), posP, tokenP) +import Unison.Syntax.Parser.Doc.Data +import Prelude hiding (Word) + +type Leaves ident code = Cofree (Leaf ident code) Ann + +type Tree ident code = Cofree (Top code (Leaves ident code)) Ann + +data ParsingEnv = ParsingEnv + { -- | Use a stack to remember the parent section and allow docSections within docSections. + -- - 1 means we are inside a # Heading 1 + parentSections :: [Int], + -- | 4 means we are inside a list starting at the fourth column + parentListColumn :: Int + } + deriving (Show) + +initialEnv :: ParsingEnv +initialEnv = ParsingEnv [0] 0 + +doc :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m end -> + m (UntitledSection (Tree ident code)) +doc ident code = flip R.runReaderT initialEnv . untitledSection . wrap . sectionElem ident code . void + +-- | This is the actual `Doc` lexer. Unlike `doc2`, it doesn’t do any Unison-side lexing (i.e., it doesn’t know that +-- Unison wraps `Doc` literals in `}}`). +untitledSection :: (P.MonadParsec e String m) => m a -> m (UntitledSection a) +untitledSection a = UntitledSection <$> P.many (a <* CP.space) + +sectionElem :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + R.ReaderT ParsingEnv m (Top code (Leaves ident code) (Tree ident code)) +sectionElem ident code docClose = + section ident code docClose + <|> lift (P.label "block eval (syntax: a fenced code block)" (eval code <|> exampleBlock code <|> codeBlock)) + <|> fmap List' (list ident code docClose) + <|> lift (Paragraph' <$> paragraph ident code docClose) + +paragraph :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + m (Paragraph (Leaves ident code)) +paragraph ident code docClose = fmap Paragraph . spaced docClose $ leafy ident code docClose + +word :: (Ord e, P.MonadParsec e String m) => m end -> m Word +word closing = fmap Word . P.try $ do + let end = P.lookAhead $ void (P.satisfy isSpace) <|> void closing + word <- P.manyTill (P.satisfy (\ch -> not (isSpace ch))) end + guard (not $ reserved word || null word) + pure word + where + reserved word = List.isPrefixOf "}}" word || all (== '#') word + +leaf :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + m (Leaf ident code (Leaves ident code)) +leaf ident code closing = + link ident + <|> namedLink ident code closing + <|> example code + <|> (Transclude' <$> transclude code) + <|> bold ident code closing + <|> italic ident code closing + <|> strikethrough ident code closing + <|> verbatim + <|> keyedInline ident code + <|> (Word' <$> word closing) + +leafy :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + m (Leaves ident code) +leafy ident code closing = do + p <- wrap $ leaf ident code closing + after <- P.optional . P.try $ leafy ident code closing + case after of + Nothing -> pure p + Just after -> wrap . fmap Group' . group . pure $ p :| pure after + +comma :: (P.MonadParsec e String m) => m String +comma = lit "," <* CP.space + +-- | A syntactic pattern of “@keyword{…}”, where we process the contents differently depending on the keyword provided. +keyedInline :: (Ord e, P.MonadParsec e String m) => m ident -> (m () -> m code) -> m (Leaf ident code a) +keyedInline ident code = P.try do + keyword <- lit "@" *> P.many letterChar <* (lit " {" <|> lit "{") + case keyword of + "source" -> Source <$> sepBy1' srcElem comma <* lit "}" + "foldedSource" -> FoldedSource <$> sepBy1' srcElem comma <* lit "}" + "eval" -> fmap EvalInline . code . void $ lit "}" + "signature" -> Signature <$> sepBy1' (embedSignatureLink ident) comma <* lit "}" + "signatures" -> Signature <$> sepBy1' (embedSignatureLink ident) comma <* lit "}" + "inlineSignature" -> SignatureInline <$> embedSignatureLink ident <* lit "}" + keyword -> P.unexpected . maybe (P.Label $ '@' :| "keyword{...}") P.Tokens $ nonEmpty keyword + where + srcElem = + SourceElement + <$> embedLink ident + <*> ( fmap (fromMaybe []) . P.optional $ + (lit "@") *> (CP.space *> annotations) + ) + where + annotation = fmap Left ident <|> fmap Right (transclude code) <* CP.space + annotations = P.some (EmbedAnnotation <$> annotation) + embedSignatureLink ident = EmbedSignatureLink <$> ident <* CP.space + +-- | Not an actual node, but this pattern is referenced in multiple places +embedLink :: (Ord e, P.MonadParsec e s m, P.TraversableStream s) => m ident -> m (EmbedLink ident) +embedLink = fmap EmbedLink + +verbatim :: (Ord e, P.MonadParsec e String m) => m (Leaf ident code a) +verbatim = + P.label "code (examples: ''**unformatted**'', `words` or '''_words_''')" $ do + Token originalText start stop <- tokenP do + -- a single backtick followed by a non-backtick is treated as monospaced + let tick = P.try (lit "`" <* P.lookAhead (P.satisfy (/= '`'))) + -- also two or more ' followed by that number of closing ' + quotes <- tick <|> (lit "''" <+> P.takeWhileP Nothing (== '\'')) + P.someTill P.anySingle (lit quotes) + let isMultiLine = line start /= line stop + pure + if isMultiLine + then + let trimmed = (trimAroundDelimiters originalText) + txt = trimIndentFromVerbatimBlock (column start - 1) trimmed + in -- If it's a multi-line verbatim block we trim any whitespace representing + -- indentation from the pretty-printer. See 'trimIndentFromVerbatimBlock' + Verbatim . Word $ txt + else Code . Word $ originalText + +example :: (P.MonadParsec e String m) => (m () -> m code) -> m (Leaf ident code void) +example code = + P.label "inline code (examples: ``List.map f xs``, ``[1] :+ 2``)" $ + fmap Example $ do + n <- P.try $ do + _ <- lit "`" + length <$> P.takeWhile1P (Just "backticks") (== '`') + let end = void . lit $ replicate (n + 1) '`' + CP.space *> code end + +link :: (Ord e, P.MonadParsec e String m) => m ident -> m (Leaf ident code a) +link ident = P.label "link (examples: {type List}, {Nat.+})" $ Link <$> P.try (lit "{" *> embedLink ident <* lit "}") + +transclude :: (P.MonadParsec e String m) => (m () -> m code) -> m (Transclude code) +transclude code = + fmap Transclude . P.label "transclusion (examples: {{ doc2 }}, {{ sepBy s [doc1, doc2] }})" $ + lit "{{" *> code (void $ lit "}}") + +nonNewlineSpaces :: (P.MonadParsec e String m) => m String +nonNewlineSpaces = P.takeWhileP Nothing nonNewlineSpace + where + nonNewlineSpace ch = isSpace ch && ch /= '\n' && ch /= '\r' + +eval :: + (P.MonadParsec e String m) => (m () -> m code) -> m (Top code (Leaves ident code) (Tree ident code)) +eval code = + Eval <$> do + -- commit after seeing that ``` is on its own line + fence <- P.try $ do + fence <- lit "```" <+> P.takeWhileP Nothing (== '`') + b <- all isSpace <$> P.lookAhead (P.takeWhileP Nothing (/= '\n')) + fence <$ guard b + CP.space *> code (void $ lit fence) + +exampleBlock :: (P.MonadParsec e String m) => (m () -> m code) -> m (Top code (Leaves ident code) (Tree ident code)) +exampleBlock code = + ExampleBlock + <$> do + void $ lit "@typecheck" <* CP.space + fence <- lit "```" <+> P.takeWhileP Nothing (== '`') + code . void $ lit fence + +codeBlock :: (Ord e, P.MonadParsec e String m) => m (Top code (Leaves ident code) (Tree ident code)) +codeBlock = do + column <- (\x -> x - 1) . toInteger . P.unPos <$> LP.indentLevel + let tabWidth = toInteger . P.unPos $ P.defaultTabWidth + fence <- lit "```" <+> P.takeWhileP Nothing (== '`') + name <- nonNewlineSpaces *> P.takeWhile1P Nothing (not . isSpace) <* nonNewlineSpaces + _ <- void CP.eol + verbatim <- uncolumn column tabWidth . trimAroundDelimiters <$> P.someTill P.anySingle ([] <$ lit fence) + pure $ CodeBlock name verbatim + where + uncolumn column tabWidth s = + let skip col r | col < 1 = r + skip col s@('\t' : _) | col < tabWidth = s + skip col ('\t' : r) = skip (col - tabWidth) r + skip col (c : r) + | isSpace c && (not $ isControl c) = + skip (col - 1) r + skip _ s = s + in List.intercalate "\n" $ skip column <$> lines s + +emphasis :: + (Ord e, P.MonadParsec e String m) => + Char -> + m ident -> + (m () -> m code) -> + m () -> + m (Paragraph (Leaves ident code)) +emphasis delimiter ident code closing = do + let start = some (P.satisfy (== delimiter)) + end <- P.try $ do + end <- start + P.lookAhead (P.satisfy (not . isSpace)) + pure end + Paragraph + <$> someTill' + (leafy ident code (closing <|> (void $ lit end)) <* void whitespaceWithoutParagraphBreak) + (lit end) + where + -- Allows whitespace including up to one newline + whitespaceWithoutParagraphBreak = void do + void nonNewlineSpaces + optional newline >>= \case + Just _ -> void nonNewlineSpaces + Nothing -> pure () + +bold :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + m (Leaf ident code (Leaves ident code)) +bold ident code = fmap Bold . emphasis '*' ident code + +italic :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + m (Leaf ident code (Leaves ident code)) +italic ident code = fmap Italic . emphasis '_' ident code + +strikethrough :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + m (Leaf ident code (Leaves ident code)) +strikethrough ident code = fmap Strikethrough . emphasis '~' ident code + +namedLink :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + m (Leaf ident code (Leaves ident code)) +namedLink ident code docClose = + P.label "hyperlink (example: [link name](https://destination.com))" do + _ <- lit "[" + p <- spaced docClose . leafy ident code . void $ char ']' + _ <- lit "]" + _ <- lit "(" + target <- group $ fmap pure (wrap $ link ident) <|> some' (wrap (Transclude' <$> transclude code) <|> wrap (Word' <$> word (docClose <|> void (char ')')))) + _ <- lit ")" + pure $ NamedLink (Paragraph p) target + +sp :: (P.MonadParsec e String m) => m () -> m String +sp docClose = P.try $ do + spaces <- P.takeWhile1P (Just "space") isSpace + close <- P.optional (P.lookAhead docClose) + case close of + Nothing -> guard $ ok spaces + Just _ -> pure () + pure spaces + where + ok s = length [() | '\n' <- s] < 2 + +spaced :: (P.MonadParsec e String m) => m () -> m a -> m (NonEmpty a) +spaced docClose p = some' $ p <* P.optional (sp docClose) + +-- | Not an actual node, but this pattern is referenced in multiple places +list :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + R.ReaderT ParsingEnv m (List (Leaves ident code)) +list ident code docClose = bulletedList ident code docClose <|> numberedList ident code docClose + +listSep :: (Ord e, R.MonadReader ParsingEnv m, P.MonadParsec e String m) => m () +listSep = P.try $ newline *> nonNewlineSpaces *> P.lookAhead (void bulletedStart <|> void numberedStart) + +bulletedStart :: (Ord e, R.MonadReader ParsingEnv m, P.MonadParsec e String m) => m (Int, [a]) +bulletedStart = P.try $ do + r <- listItemStart $ [] <$ P.satisfy bulletChar + P.lookAhead (P.satisfy isSpace) + pure r + where + bulletChar ch = ch == '*' || ch == '-' || ch == '+' + +listItemStart :: (Ord e, R.MonadReader ParsingEnv m, P.MonadParsec e String m) => m a -> m (Int, a) +listItemStart gutter = P.try do + nonNewlineSpaces + col <- column <$> posP + parentCol <- R.asks parentListColumn + guard (col > parentCol) + (col,) <$> gutter + +numberedStart :: (Ord e, R.MonadReader ParsingEnv m, P.MonadParsec e String m) => m (Int, Word64) +numberedStart = listItemStart . P.try $ LP.decimal <* lit "." + +-- | FIXME: This should take a @`P` a@ +numberedList :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + R.ReaderT ParsingEnv m (List (Leaves ident code)) +numberedList ident code docClose = NumberedList <$> sepBy1' numberedItem listSep + where + numberedItem = P.label "numbered list (examples: 1. item1, 8. start numbering at '8')" do + (col, s) <- numberedStart + (s,) <$> column' ident code docClose col + +-- | FIXME: This should take a @`P` a@ +bulletedList :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + R.ReaderT ParsingEnv m (List (Leaves ident code)) +bulletedList ident code docClose = BulletedList <$> sepBy1' bullet listSep + where + bullet = P.label "bullet (examples: * item1, - item2)" do + (col, _) <- bulletedStart + column' ident code docClose col + +column' :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + Int -> + R.ReaderT ParsingEnv m (Column (Leaves ident code)) +column' ident code docClose col = + Column + <$> (nonNewlineSpaces *> listItemParagraph) + <*> R.local (\e -> e {parentListColumn = col}) (P.optional $ listSep *> list ident code docClose) + where + listItemParagraph = + Paragraph <$> do + col <- column <$> posP + some' (lift (leafy ident code docClose) <* sep col) + where + -- Trickiness here to support hard line breaks inside of + -- a bulleted list, so for instance this parses as expected: + -- + -- * uno dos + -- tres quatro + -- * alice bob + -- carol dave eve + sep col = do + _ <- nonNewlineSpaces + _ <- + P.optional . P.try $ + newline + *> nonNewlineSpaces + *> do + col2 <- column <$> posP + guard $ col2 >= col + (P.notFollowedBy $ void numberedStart <|> void bulletedStart) + pure () + +newline :: (P.MonadParsec e String m) => m String +newline = P.label "newline" $ lit "\n" <|> lit "\r\n" + +-- | +-- +-- > ## Section title +-- > +-- > A paragraph under this section. +-- > Part of the same paragraph. Blanklines separate paragraphs. +-- > +-- > ### A subsection title +-- > +-- > A paragraph under this subsection. +-- > +-- > # A section title (not a subsection) +section :: + (Ord e, P.MonadParsec e String m) => + m ident -> + (m () -> m code) -> + m () -> + R.ReaderT ParsingEnv m (Top code (Leaves ident code) (Tree ident code)) +section ident code docClose = do + ns <- R.asks parentSections + hashes <- lift $ P.try $ lit (replicate (head ns) '#') *> P.takeWhile1P Nothing (== '#') <* sp docClose + title <- lift $ paragraph ident code docClose <* CP.space + let m = length hashes + head ns + body <- + R.local (\env -> env {parentSections = m : tail ns}) $ + P.many (wrap (sectionElem ident code docClose) <* CP.space) + pure $ Section title body + +-- | FIXME: This should just take a @`P` code@ and @`P` a@. +group :: (P.MonadParsec e s m) => m (NonEmpty (Leaves ident code)) -> m (Group (Leaves ident code)) +group = fmap Group . join + +-- | FIXME: This should just take a @`P` a@ +join :: (P.MonadParsec e s m) => m (NonEmpty a) -> m (Join a) +join = fmap Join + +-- * utility functions + +wrap :: (Ord e, P.MonadParsec e s m, P.TraversableStream s) => m (f (Cofree f Ann)) -> m (Cofree f Ann) +wrap p = do + start <- posP + val <- p + end <- posP + pure (Ann start end :< val) + +-- | If it's a multi-line verbatim block we trim any whitespace representing +-- indentation from the pretty-printer. +-- +-- E.g. +-- +-- @@ +-- {{ +-- # Heading +-- ''' +-- code +-- indented +-- ''' +-- }} +-- @@ +-- +-- Should lex to the text literal "code\n indented". +-- +-- If there's text in the literal that has LESS trailing whitespace than the +-- opening delimiters, we don't trim it at all. E.g. +-- +-- @@ +-- {{ +-- # Heading +-- ''' +-- code +-- ''' +-- }} +-- @@ +-- +-- Is parsed as " code". +-- +-- Trim the expected amount of whitespace from a text literal: +-- >>> trimIndentFromVerbatimBlock 2 " code\n indented" +-- "code\n indented" +-- +-- If the text literal has less leading whitespace than the opening delimiters, +-- leave it as-is +-- >>> trimIndentFromVerbatimBlock 2 "code\n indented" +-- "code\n indented" +trimIndentFromVerbatimBlock :: Int -> String -> String +trimIndentFromVerbatimBlock leadingSpaces txt = fromMaybe txt $ do + List.intercalate "\n" <$> for (lines txt) \line -> do + -- If any 'stripPrefix' fails, we fail and return the unaltered text + case List.stripPrefix (replicate leadingSpaces ' ') line of + Just stripped -> Just stripped + Nothing -> + -- If it was a line with all white-space, just use an empty line, + -- this can happen easily in editors which trim trailing whitespace. + if all isSpace line + then Just "" + else Nothing + +-- | Trim leading/trailing whitespace from around delimiters, e.g. +-- +-- {{ +-- '''___ <- whitespace here including newline +-- text block +-- 👇 or here +-- __''' +-- }} +-- >>> trimAroundDelimiters " \n text block \n " +-- " text block " +-- +-- Should leave leading and trailing line untouched if it contains non-whitespace, e.g.: +-- +-- ''' leading whitespace +-- text block +-- trailing whitespace: ''' +-- >>> trimAroundDelimiters " leading whitespace\n text block \ntrailing whitespace: " +-- " leading whitespace\n text block \ntrailing whitespace: " +-- +-- Should keep trailing newline if it's the only thing on the line, e.g.: +-- +-- ''' +-- newline below +-- +-- ''' +-- >>> trimAroundDelimiters "\nnewline below\n\n" +-- "newline below\n\n" +trimAroundDelimiters :: String -> String +trimAroundDelimiters txt = + txt + & ( \s -> + List.breakOn "\n" s + & \case + (prefix, suffix) + | all isSpace prefix -> drop 1 suffix + | otherwise -> prefix <> suffix + ) + & ( \s -> + List.breakOnEnd "\n" s + & \case + (_prefix, "") -> s + (prefix, suffix) + | all isSpace suffix -> dropTrailingNewline prefix + | otherwise -> prefix <> suffix + ) + where + dropTrailingNewline = \case + [] -> [] + (x : xs) -> NonEmpty.init (x NonEmpty.:| xs) diff --git a/unison-syntax/src/Unison/Syntax/Parser/Doc/Data.hs b/unison-syntax/src/Unison/Syntax/Parser/Doc/Data.hs new file mode 100644 index 0000000000..fbc1e042b0 --- /dev/null +++ b/unison-syntax/src/Unison/Syntax/Parser/Doc/Data.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Haskell parallel to @unison/base.Doc@. +-- +-- These types have two significant parameters: @ident@ and @code@ that are expected to be parameterized by some +-- representation of identifiers and source code of the host language. +-- +-- This is much more restricted than @unison/base.Doc@, but it covers everything we can parse from Haskell. The +-- mismatch with Unison is a problem, as someone can create a Unison Doc with explicit constructors or function calls, +-- have it rendered to a scratch file, and then we can’t parse it. Changing the types here to match Unison wouldn’t +-- fix the issue. We have to modify the types and parser in concert (in both Haskell and Unison) to bring them in +-- line. +module Unison.Syntax.Parser.Doc.Data where + +import Data.Bifoldable (Bifoldable, bifoldr) +import Data.Bitraversable (Bitraversable, bitraverse) +import Data.Eq.Deriving (deriveEq1, deriveEq2) +import Data.Functor.Classes (Eq1 (..), Ord1 (..), Show1 (..)) +import Data.List.NonEmpty (NonEmpty) +import Data.Ord.Deriving (deriveOrd1, deriveOrd2) +import Text.Show.Deriving (deriveShow1, deriveShow2) +import Unison.Prelude hiding (Word) +import Prelude hiding (Word) + +newtype UntitledSection a = UntitledSection [a] + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +newtype Paragraph a = Paragraph (NonEmpty a) + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +$(deriveEq1 ''Paragraph) +$(deriveOrd1 ''Paragraph) +$(deriveShow1 ''Paragraph) + +data List a + = BulletedList (NonEmpty (Column a)) + | NumberedList (NonEmpty (Word64, Column a)) + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +instance Eq1 List where + liftEq eqA = curry \case + (BulletedList as, BulletedList as') -> liftEq (liftEq eqA) as as' + (NumberedList as, NumberedList as') -> liftEq (liftEq (liftEq eqA)) as as' + (_, _) -> False + +instance Ord1 List where + liftCompare compareA = curry \case + (BulletedList as, BulletedList as') -> liftCompare (liftCompare compareA) as as' + (NumberedList as, NumberedList as') -> liftCompare (liftCompare (liftCompare compareA)) as as' + (BulletedList _, NumberedList _) -> LT + (NumberedList _, BulletedList _) -> GT + +instance Show1 List where + liftShowsPrec showsPrecA showListA prec = + showParen (prec <= 11) . \case + BulletedList as -> + showString "BulletedList " + . liftShowsPrec (liftShowsPrec showsPrecA showListA) (liftShowList showsPrecA showListA) 11 as + NumberedList as -> + showString "NumberedList " + . liftShowsPrec + (liftShowsPrec (liftShowsPrec showsPrecA showListA) (liftShowList showsPrecA showListA)) + (liftShowList (liftShowsPrec showsPrecA showListA) (liftShowList showsPrecA showListA)) + 11 + as + +data Column a + = Column (Paragraph a) (Maybe (List a)) + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +instance Eq1 Column where + liftEq eqA (Column para mlist) (Column para' mlist') = + liftEq eqA para para' && liftEq (liftEq eqA) mlist mlist' + +instance Ord1 Column where + liftCompare compareA (Column para mlist) (Column para' mlist') = + liftCompare compareA para para' <> liftCompare (liftCompare compareA) mlist mlist' + +instance Show1 Column where + liftShowsPrec showsPrecA showListA prec (Column para mlist) = + showParen (prec <= 11) $ + showString "Column " + . liftShowsPrec showsPrecA showListA 11 para + . liftShowsPrec (liftShowsPrec showsPrecA showListA) (liftShowList showsPrecA showListA) 11 mlist + +data Top code leaf a + = Section (Paragraph leaf) [a] + | Eval code + | ExampleBlock code + | CodeBlock String String + | List' (List leaf) + | Paragraph' (Paragraph leaf) + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +instance Bifoldable (Top code) where + bifoldr f g z = \case + Section para as -> foldr f (foldr g z as) para + Eval _ -> z + ExampleBlock _ -> z + CodeBlock _ _ -> z + List' list -> foldr f z list + Paragraph' para -> foldr f z para + +instance Bifunctor (Top code) where + bimap f g = \case + Section para as -> Section (fmap f para) $ fmap g as + Eval code -> Eval code + ExampleBlock code -> ExampleBlock code + CodeBlock title body -> CodeBlock title body + List' list -> List' $ fmap f list + Paragraph' para -> Paragraph' $ fmap f para + +instance Bitraversable (Top code) where + bitraverse f g = \case + Section para as -> Section <$> traverse f para <*> traverse g as + Eval code -> pure $ Eval code + ExampleBlock code -> pure $ ExampleBlock code + CodeBlock title body -> pure $ CodeBlock title body + List' list -> List' <$> traverse f list + Paragraph' para -> Paragraph' <$> traverse f para + +$(deriveEq1 ''Top) +$(deriveOrd1 ''Top) +$(deriveShow1 ''Top) +$(deriveEq2 ''Top) +$(deriveOrd2 ''Top) +$(deriveShow2 ''Top) + +-- | This is a deviation from the Unison Doc data model – in Unison, Doc distinguishes between type and term links, but +-- here Doc knows nothing about what namespaces may exist. +data EmbedLink a = EmbedLink a + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +$(deriveEq1 ''EmbedLink) +$(deriveOrd1 ''EmbedLink) +$(deriveShow1 ''EmbedLink) + +newtype Transclude a = Transclude a + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +$(deriveEq1 ''Transclude) +$(deriveOrd1 ''Transclude) +$(deriveShow1 ''Transclude) + +newtype EmbedAnnotation ident a + = EmbedAnnotation (Either ident a) + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +$(deriveEq1 ''EmbedAnnotation) +$(deriveOrd1 ''EmbedAnnotation) +$(deriveShow1 ''EmbedAnnotation) +$(deriveEq2 ''EmbedAnnotation) +$(deriveOrd2 ''EmbedAnnotation) +$(deriveShow2 ''EmbedAnnotation) + +data SourceElement ident a = SourceElement (EmbedLink ident) [EmbedAnnotation ident a] + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +$(deriveEq1 ''SourceElement) +$(deriveOrd1 ''SourceElement) +$(deriveShow1 ''SourceElement) +$(deriveEq2 ''SourceElement) +$(deriveOrd2 ''SourceElement) +$(deriveShow2 ''SourceElement) + +newtype EmbedSignatureLink a = EmbedSignatureLink a + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +newtype Word = Word String + deriving (Eq, Ord, Show) + +newtype Join a = Join (NonEmpty a) + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +$(deriveEq1 ''Join) +$(deriveOrd1 ''Join) +$(deriveShow1 ''Join) + +newtype Group a = Group (Join a) + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +$(deriveEq1 ''Group) +$(deriveOrd1 ''Group) +$(deriveShow1 ''Group) + +data Leaf ident code a + = Link (EmbedLink ident) + | -- | the Group always contains either a single Term/Type link or list of `Transclude`s & `Word`s + NamedLink (Paragraph a) (Group a) + | Example code + | Transclude' (Transclude code) + | Bold (Paragraph a) + | Italic (Paragraph a) + | Strikethrough (Paragraph a) + | Verbatim Word + | Code Word + | Source (NonEmpty (SourceElement ident (Transclude code))) + | FoldedSource (NonEmpty (SourceElement ident (Transclude code))) + | EvalInline code + | Signature (NonEmpty (EmbedSignatureLink ident)) + | SignatureInline (EmbedSignatureLink ident) + | Word' Word + | Group' (Group a) + deriving (Eq, Ord, Show, Foldable, Functor, Traversable) + +instance Bifunctor (Leaf ident) where + bimap f g = \case + Link x -> Link x + NamedLink para group -> NamedLink (g <$> para) $ g <$> group + Example code -> Example $ f code + Transclude' trans -> Transclude' $ f <$> trans + Bold para -> Bold $ g <$> para + Italic para -> Italic $ g <$> para + Strikethrough para -> Strikethrough $ g <$> para + Verbatim word -> Verbatim word + Code word -> Code word + Source elems -> Source $ fmap (fmap f) <$> elems + FoldedSource elems -> FoldedSource $ fmap (fmap f) <$> elems + EvalInline code -> EvalInline $ f code + Signature x -> Signature x + SignatureInline x -> SignatureInline x + Word' word -> Word' word + Group' group -> Group' $ g <$> group + +$(deriveEq1 ''Leaf) +$(deriveOrd1 ''Leaf) +$(deriveShow1 ''Leaf) +$(deriveEq2 ''Leaf) +$(deriveOrd2 ''Leaf) +$(deriveShow2 ''Leaf) diff --git a/unison-syntax/src/Unison/Syntax/Var.hs b/unison-syntax/src/Unison/Syntax/Var.hs index 9fbc934d29..9f92e2c758 100644 --- a/unison-syntax/src/Unison/Syntax/Var.hs +++ b/unison-syntax/src/Unison/Syntax/Var.hs @@ -1,5 +1,6 @@ module Unison.Syntax.Var ( namespaced, + namespaced2, ) where @@ -13,3 +14,8 @@ import Unison.Var (Var) namespaced :: (Var v) => List.NonEmpty v -> v namespaced (v :| vs) = Name.toVar (foldl' Name.joinDot (Name.unsafeParseVar v) (map Name.unsafeParseVar vs)) + +-- | Like 'namespaced', but for the common case that you have two vars to join. +namespaced2 :: (Var v) => v -> v -> v +namespaced2 v1 v2 = + namespaced (v1 :| [v2]) diff --git a/unison-syntax/test/Main.hs b/unison-syntax/test/Main.hs index e566b52609..825bf870d5 100644 --- a/unison-syntax/test/Main.hs +++ b/unison-syntax/test/Main.hs @@ -1,237 +1,25 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - module Main (main) where -import Data.Maybe (fromJust) -import Data.Text qualified as Text import EasyTest +import System.Environment (getArgs) +import System.IO import System.IO.CodePage (withCP65001) -import Unison.Prelude -import Unison.ShortHash (ShortHash) -import Unison.ShortHash qualified as ShortHash -import Unison.Syntax.HashQualified' qualified as HQ' (unsafeParseText) -import Unison.Syntax.Lexer - -main :: IO () -main = - withCP65001 (run test) +import Unison.Test.Doc qualified as Doc +import Unison.Test.Unison qualified as Unison test :: Test () test = - scope "lexer" . tests $ - [ t "1" [Numeric "1"], - t "+1" [Numeric "+1"], - t "-1" [Numeric "-1"], - t "-1.0" [Numeric "-1.0"], - t "+1.0" [Numeric "+1.0"], - t "1e3" [Numeric "1e3"], - t "1e+3" [Numeric "1e+3"], - t "1e-3" [Numeric "1e-3"], - t "+1e3" [Numeric "+1e3"], - t "+1e+3" [Numeric "+1e+3"], - t "+1e-3" [Numeric "+1e-3"], - t "-1e3" [Numeric "-1e3"], - t "-1e+3" [Numeric "-1e+3"], - t "-1e-3" [Numeric "-1e-3"], - t "1.2e3" [Numeric "1.2e3"], - t "1.2e+3" [Numeric "1.2e+3"], - t "1.2e-3" [Numeric "1.2e-3"], - t "+1.2e3" [Numeric "+1.2e3"], - t "+1.2e+3" [Numeric "+1.2e+3"], - t "+1.2e-3" [Numeric "+1.2e-3"], - t "-1.2e3" [Numeric "-1.2e3"], - t "-1.2e+3" [Numeric "-1.2e+3"], - t "-1.2e-3" [Numeric "-1.2e-3"], - t "1E3" [Numeric "1e3"], - t "1E+3" [Numeric "1e+3"], - t "1E-3" [Numeric "1e-3"], - t "+1E3" [Numeric "+1e3"], - t "+1E+3" [Numeric "+1e+3"], - t "+1E-3" [Numeric "+1e-3"], - t "-1E3" [Numeric "-1e3"], - t "-1E+3" [Numeric "-1e+3"], - t "-1E-3" [Numeric "-1e-3"], - t "1.2E3" [Numeric "1.2e3"], - t "1.2E+3" [Numeric "1.2e+3"], - t "1.2E-3" [Numeric "1.2e-3"], - t "+1.2E3" [Numeric "+1.2e3"], - t "+1.2E+3" [Numeric "+1.2e+3"], - t "+1.2E-3" [Numeric "+1.2e-3"], - t "-1.2E3" [Numeric "-1.2e3"], - t "-1.2E+3" [Numeric "-1.2e+3"], - t "-1.2E-3" [Numeric "-1.2e-3"], - t "1-1" [Numeric "1", simpleSymbolyId "-", Numeric "1"], - t "1+1" [Numeric "1", simpleSymbolyId "+", Numeric "1"], - t "1 +1" [Numeric "1", Numeric "+1"], - t "1+ 1" [Numeric "1", simpleSymbolyId "+", Numeric "1"], - t "x+y" [simpleWordyId "x", simpleSymbolyId "+", simpleWordyId "y"], - t "++;++" [simpleSymbolyId "++", Semi False, simpleSymbolyId "++"], - t "++; woot" [simpleSymbolyId "++", Semi False, simpleWordyId "woot"], - t "woot;woot" [simpleWordyId "woot", Semi False, simpleWordyId "woot"], - t "woot;(woot)" [simpleWordyId "woot", Semi False, Open "(", simpleWordyId "woot", Close], - t - "[+1,+1]" - [Open "[", Numeric "+1", Reserved ",", Numeric "+1", Close], - t - "[ +1 , +1 ]" - [Open "[", Numeric "+1", Reserved ",", Numeric "+1", Close], - t "-- a comment 1.0" [], - t "\"woot\" -- a comment 1.0" [Textual "woot"], - t "0:Int" [Numeric "0", Reserved ":", simpleWordyId "Int"], - t "0 : Int" [Numeric "0", Reserved ":", simpleWordyId "Int"], - t - ".Foo Foo `.` .foo.bar.baz" - [ simpleWordyId ".Foo", - simpleWordyId "Foo", - simpleSymbolyId "`.`", - simpleWordyId ".foo.bar.baz" - ], - t ".Foo.Bar.+" [simpleSymbolyId ".Foo.Bar.+"], - t ".Foo.++.+" [simpleSymbolyId ".Foo.++.+"], - t ".Foo.`++`.+" [simpleSymbolyId ".Foo.`++`.+"], - t ".Foo.`+.+`.+" [simpleSymbolyId ".Foo.`+.+`.+"], - -- idents with hashes - t "foo#bar" [simpleWordyId "foo#bar"], - t "+#bar" [simpleSymbolyId "+#bar"], - -- note - these are all the same, just with different spacing - let ex1 = "if x then y else z" - ex2 = unlines ["if", " x", "then", " y", "else z"] - ex3 = unlines ["if", " x", " then", " y", "else z"] - ex4 = unlines ["if", " x", " then", " y", "else z"] - expected = - [ Open "if", - simpleWordyId "x", - Close, - Open "then", - simpleWordyId "y", - Close, - Open "else", - simpleWordyId "z", - Close - ] - in -- directly close empty = block - tests $ map (`t` expected) [ex1, ex2, ex3, ex4], - let ex = unlines ["test =", "", "x = 1"] - in -- directly close nested empty blocks - t - ex - [ simpleWordyId "test", - Open "=", - Close, - (Semi True), - simpleWordyId "x", - Open "=", - Numeric "1", - Close - ], - let ex = unlines ["test =", " test2 =", "", "x = 1"] - in t - ex - [ simpleWordyId "test", - Open "=", - simpleWordyId "test2", - Open "=", - Close, - Close, - (Semi True), - simpleWordyId "x", - Open "=", - Numeric "1", - Close - ], - let ex = - unlines - ["if a then b", "else if c then d", "else if e then f", "else g"] -- close of the three `else` blocks - in -- In an empty `then` clause, the `else` is interpreted as a `Reserved` token - t - ex - [ Open "if", - simpleWordyId "a", - Close, - Open "then", - simpleWordyId "b", - Close, - Open "else", - Open "if", - simpleWordyId "c", - Close, - Open "then", - simpleWordyId "d", - Close, - Open "else", - Open "if", - simpleWordyId "e", - Close, - Open "then", - simpleWordyId "f", - Close, - Open "else", - simpleWordyId "g", - Close, - Close, - Close - ], - t - "if x then else" - [ Open "if", - simpleWordyId "x", - Close, - Open "then", - Close, - Open "else", - Close - ], - -- Empty `else` clause - t - "if x then 1 else" - [ Open "if", - simpleWordyId "x", - Close, - Open "then", - Numeric "1", - Close, - Open "else", - Close - ], - -- shouldn't be too eager to find keywords at the front of identifiers, - -- particularly for block-closing keywords (see #2727) - tests $ do - kw <- ["if", "then", "else"] - suffix <- ["0", "x", "!", "'"] -- examples of wordyIdChar - let i = kw ++ suffix - -- a keyword at the front of an identifier should still be an identifier - pure $ t i [simpleWordyId (Text.pack i)], - -- Test string literals - t - "\"simple string without escape characters\"" - [Textual "simple string without escape characters"], - t - "\"test escaped quotes \\\"in quotes\\\"\"" - [Textual "test escaped quotes \"in quotes\""], - t "\"\\n \\t \\b \\a\"" [Textual "\n \t \b \a"], - -- Delayed string - t "'\"\"" [Reserved "'", Textual ""] + tests + [ Doc.test, + Unison.test ] -t :: String -> [Lexeme] -> Test () -t s expected = - let actual0 = payload <$> lexer "ignored filename" s - actual = take (length actual0 - 2) . drop 1 $ actual0 - in scope s $ - if actual == expected - then ok - else do - note $ "expected: " ++ show expected - note $ "actual : " ++ show actual - crash "actual != expected" - -simpleSymbolyId :: Text -> Lexeme -simpleSymbolyId = - SymbolyId . HQ'.unsafeParseText - -simpleWordyId :: Text -> Lexeme -simpleWordyId = - WordyId . HQ'.unsafeParseText - -instance IsString ShortHash where - fromString = fromJust . ShortHash.fromText . Text.pack +main :: IO () +main = withCP65001 do + args <- getArgs + mapM_ (`hSetEncoding` utf8) [stdout, stdin, stderr] + case args of + [] -> runOnly "" test + [prefix] -> runOnly prefix test + [seed, prefix] -> rerunOnly (read seed) prefix test + _ -> error "expected no args, a prefix, or a seed and a prefix" diff --git a/unison-syntax/test/Unison/Test/Doc.hs b/unison-syntax/test/Unison/Test/Doc.hs new file mode 100644 index 0000000000..9028404ada --- /dev/null +++ b/unison-syntax/test/Unison/Test/Doc.hs @@ -0,0 +1,169 @@ +module Unison.Test.Doc (test) where + +import Control.Comonad.Trans.Cofree (CofreeF ((:<))) +import Data.Bifunctor (first) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text (Text) +import EasyTest +import Text.Megaparsec qualified as P +import Unison.HashQualifiedPrime qualified as HQ' +import Unison.Syntax.Lexer.Unison +import Unison.Syntax.Name qualified as Name +import Unison.Syntax.Parser.Doc qualified as DP +import Unison.Syntax.Parser.Doc.Data qualified as Doc +import Unison.Util.Recursion + +test :: Test () +test = + scope "DocParser" . tests $ + [ t "# Hello" [Doc.Section (Doc.Paragraph $ docWord "Hello" :| []) []], + t + ( unlines + [ "# Hello", + "## Again" + ] + ) + [ Doc.Section + (Doc.Paragraph $ docWord "Hello" :| []) + [Fix $ Doc.Section (Doc.Paragraph $ docWord "Again" :| []) []] + ], + t + ( unlines + [ "## Hello", + "# Again" + ] + ) + [ Doc.Section (Doc.Paragraph $ docWord "Hello" :| []) [], + Doc.Section (Doc.Paragraph $ docWord "Again" :| []) [] + ], + t + "*some bold words*" + [Doc.Paragraph' . Doc.Paragraph $ docBold (docWord "some" :| [docWord "bold", docWord "words"]) :| []], + t + "_some italic words_" + [Doc.Paragraph' . Doc.Paragraph $ docItalic (docWord "some" :| [docWord "italic", docWord "words"]) :| []], + t + "~some struck-through words~" + [ Doc.Paragraph' . Doc.Paragraph $ + docStrikethrough (docWord "some" :| [docWord "struck-through", docWord "words"]) :| [] + ], + -- any number of emphasis delimiters is allowed + t + "__some italic words__" + [Doc.Paragraph' . Doc.Paragraph $ docItalic (docWord "some" :| [docWord "italic", docWord "words"]) :| []], + t + "________some italic words________" + [Doc.Paragraph' . Doc.Paragraph $ docItalic (docWord "some" :| [docWord "italic", docWord "words"]) :| []], + t + "***some bold words***" + [ Doc.Paragraph' . Doc.Paragraph $ docBold (docWord "some" :| [docWord "bold", docWord "words"]) :| [] + ], + t + "***some _nested_ emphasis***" + [ Doc.Paragraph' . Doc.Paragraph $ + docBold (docWord "some" :| [docItalic $ docWord "nested" :| [], docWord "emphasis"]) :| [] + ], + -- mismatched delimiters should be preserved as text + t "*" [Doc.Paragraph' . Doc.Paragraph $ docWord "*" :| []], + t "`" [Doc.Paragraph' . Doc.Paragraph $ docWord "`" :| []], + -- various code blocks (although we’re not testing the Unison code block lexer/parser with these) + t + ( unlines + [ "```", + "You might think this is code, but it’s not", + "```" + ] + ) + [Doc.Eval "You might think this is code, but it’s not\n"], + t + ( unlines + [ "`````````", + "This one has extra delimiters", + "`````````" + ] + ) + [Doc.Eval "This one has extra delimiters\n"], + t + ( unlines + [ "``` unison", + "You might think this is code, but it’s not", + "```" + ] + ) + [Doc.CodeBlock "unison" "You might think this is code, but it’s not"], + t + ( unlines + [ "````````` unison", + "This one has extra delimiters", + "`````````" + ] + ) + [Doc.CodeBlock "unison" "This one has extra delimiters"], + t + ( unlines + [ "@typecheck ```", + "You might think this is code, but it’s not", + "```" + ] + ) + [Doc.ExampleBlock "\nYou might think this is code, but it’s not\n"], + t + ( unlines + [ "@typecheck`````````", + "This one has extra delimiters", + "`````````" + ] + ) + [Doc.ExampleBlock "\nThis one has extra delimiters\n"], + t "`some verbatim text`" [Doc.Paragraph' . Doc.Paragraph $ docCode "some verbatim text" :| []], + t "''some verbatim text''" [Doc.Paragraph' . Doc.Paragraph $ docCode "some verbatim text" :| []], + t "'''''some verbatim text'''''" [Doc.Paragraph' . Doc.Paragraph $ docCode "some verbatim text" :| []] + ] + +-- round-trip tests need to be in unison-parser-typechecker +-- +-- -- want to get this to `Text` (or `String`), for round-trip testing +-- showPrettyDoc :: (Var v) => PrettyPrintEnv -> Term v a -> Pretty ColorText +-- showPrettyDoc ppe tm = PP.syntaxToColor . runPretty (avoidShadowing tm ppe) <$> prettyDoc2 emptyAc (printAnnotate ppe tm) + +t :: + String -> + -- | Despite the long type, this is a simplified `Doc` – no annotations, and ident and code are Text & String, + -- respectively. + [Doc.Top String (Fix (Doc.Leaf Text String)) (Fix (Doc.Top String (Fix (Doc.Leaf Text String))))] -> + Test () +t s expected = + scope s + . either + (crash . P.errorBundlePretty) + ( \actual -> + let expected' = Doc.UntitledSection $ embed <$> expected + actual' = cata (\(_ :< top) -> embed $ first (cata \(_ :< leaf) -> embed leaf) top) <$> actual + in if actual' == expected' + then ok + else do + note $ "expected: " ++ show expected' + note $ "actual : " ++ show actual' + crash "actual != expected" + ) + $ P.runParser (DP.doc (Name.toText . HQ'.toName . snd <$> typeOrTerm) (P.manyTill P.anySingle) P.eof) "test case" s + +-- * Helper functions to make it easier to read the examples. + +-- Once the parser gets generalized, these should be able to be removed, as they won’t require multiple layers of +-- constructor. + +docBold :: NonEmpty (Fix (Doc.Leaf ident code)) -> Fix (Doc.Leaf ident code) +docBold = embed . Doc.Bold . Doc.Paragraph + +docCode :: String -> Fix (Doc.Leaf ident code) +docCode = embed . Doc.Code . Doc.Word + +docItalic :: NonEmpty (Fix (Doc.Leaf ident code)) -> Fix (Doc.Leaf ident code) +docItalic = embed . Doc.Italic . Doc.Paragraph + +docStrikethrough :: NonEmpty (Fix (Doc.Leaf ident code)) -> Fix (Doc.Leaf ident code) +docStrikethrough = embed . Doc.Strikethrough . Doc.Paragraph + +docWord :: String -> Fix (Doc.Leaf ident code) +docWord = embed . Doc.Word' . Doc.Word diff --git a/unison-syntax/test/Unison/Test/Unison.hs b/unison-syntax/test/Unison/Test/Unison.hs new file mode 100644 index 0000000000..5468046400 --- /dev/null +++ b/unison-syntax/test/Unison/Test/Unison.hs @@ -0,0 +1,235 @@ +module Unison.Test.Unison (test) where + +import Data.Text qualified as Text +import EasyTest +import Unison.Prelude +import Unison.Syntax.HashQualifiedPrime qualified as HQ' (unsafeParseText) +import Unison.Syntax.Lexer.Unison + +test :: Test () +test = + scope "lexer" . tests $ + [ t "" [], + t "1" [Numeric "1"], + t "+1" [Numeric "+1"], + t "-1" [Numeric "-1"], + t "-1.0" [Numeric "-1.0"], + t "+1.0" [Numeric "+1.0"], + t "1e3" [Numeric "1e3"], + t "1e+3" [Numeric "1e+3"], + t "1e-3" [Numeric "1e-3"], + t "+1e3" [Numeric "+1e3"], + t "+1e+3" [Numeric "+1e+3"], + t "+1e-3" [Numeric "+1e-3"], + t "-1e3" [Numeric "-1e3"], + t "-1e+3" [Numeric "-1e+3"], + t "-1e-3" [Numeric "-1e-3"], + t "1.2e3" [Numeric "1.2e3"], + t "1.2e+3" [Numeric "1.2e+3"], + t "1.2e-3" [Numeric "1.2e-3"], + t "+1.2e3" [Numeric "+1.2e3"], + t "+1.2e+3" [Numeric "+1.2e+3"], + t "+1.2e-3" [Numeric "+1.2e-3"], + t "-1.2e3" [Numeric "-1.2e3"], + t "-1.2e+3" [Numeric "-1.2e+3"], + t "-1.2e-3" [Numeric "-1.2e-3"], + t "1E3" [Numeric "1e3"], + t "1E+3" [Numeric "1e+3"], + t "1E-3" [Numeric "1e-3"], + t "+1E3" [Numeric "+1e3"], + t "+1E+3" [Numeric "+1e+3"], + t "+1E-3" [Numeric "+1e-3"], + t "-1E3" [Numeric "-1e3"], + t "-1E+3" [Numeric "-1e+3"], + t "-1E-3" [Numeric "-1e-3"], + t "1.2E3" [Numeric "1.2e3"], + t "1.2E+3" [Numeric "1.2e+3"], + t "1.2E-3" [Numeric "1.2e-3"], + t "+1.2E3" [Numeric "+1.2e3"], + t "+1.2E+3" [Numeric "+1.2e+3"], + t "+1.2E-3" [Numeric "+1.2e-3"], + t "-1.2E3" [Numeric "-1.2e3"], + t "-1.2E+3" [Numeric "-1.2e+3"], + t "-1.2E-3" [Numeric "-1.2e-3"], + t "1-1" [Numeric "1", simpleSymbolyId "-", Numeric "1"], + t "1+1" [Numeric "1", simpleSymbolyId "+", Numeric "1"], + t "1 +1" [Numeric "1", Numeric "+1"], + t "1+ 1" [Numeric "1", simpleSymbolyId "+", Numeric "1"], + t "x+y" [simpleWordyId "x", simpleSymbolyId "+", simpleWordyId "y"], + t "++;++" [simpleSymbolyId "++", Semi False, simpleSymbolyId "++"], + t "++; woot" [simpleSymbolyId "++", Semi False, simpleWordyId "woot"], + t "woot;woot" [simpleWordyId "woot", Semi False, simpleWordyId "woot"], + t "woot;(woot)" [simpleWordyId "woot", Semi False, Open "(", simpleWordyId "woot", Close], + t + "[+1,+1]" + [Open "[", Numeric "+1", Reserved ",", Numeric "+1", Close], + t + "[ +1 , +1 ]" + [Open "[", Numeric "+1", Reserved ",", Numeric "+1", Close], + t "-- a comment 1.0" [], + t "\"woot\" -- a comment 1.0" [Textual "woot"], + t "0:Int" [Numeric "0", Reserved ":", simpleWordyId "Int"], + t "0 : Int" [Numeric "0", Reserved ":", simpleWordyId "Int"], + t + ".Foo Foo `.` .foo.bar.baz" + [ simpleWordyId ".Foo", + simpleWordyId "Foo", + simpleSymbolyId "`.`", + simpleWordyId ".foo.bar.baz" + ], + t ".Foo.Bar.+" [simpleSymbolyId ".Foo.Bar.+"], + t ".Foo.++.+" [simpleSymbolyId ".Foo.++.+"], + t ".Foo.`++`.+" [simpleSymbolyId ".Foo.`++`.+"], + t ".Foo.`+.+`.+" [simpleSymbolyId ".Foo.`+.+`.+"], + -- idents with hashes + t "foo#bar" [simpleWordyId "foo#bar"], + t "+#bar" [simpleSymbolyId "+#bar"], + -- note - these are all the same, just with different spacing + let ex1 = "if x then y else z" + ex2 = unlines ["if", " x", "then", " y", "else z"] + ex3 = unlines ["if", " x", " then", " y", "else z"] + ex4 = unlines ["if", " x", " then", " y", "else z"] + expected = + [ Open "if", + simpleWordyId "x", + Close, + Open "then", + simpleWordyId "y", + Close, + Open "else", + simpleWordyId "z", + Close + ] + in -- directly close empty = block + tests $ map (`t` expected) [ex1, ex2, ex3, ex4], + let ex = unlines ["test =", "", "x = 1"] + in -- directly close nested empty blocks + t + ex + [ simpleWordyId "test", + Open "=", + Close, + (Semi True), + simpleWordyId "x", + Open "=", + Numeric "1", + Close + ], + let ex = unlines ["test =", " test2 =", "", "x = 1"] + in t + ex + [ simpleWordyId "test", + Open "=", + simpleWordyId "test2", + Open "=", + Close, + Close, + (Semi True), + simpleWordyId "x", + Open "=", + Numeric "1", + Close + ], + let ex = + unlines + ["if a then b", "else if c then d", "else if e then f", "else g"] -- close of the three `else` blocks + in -- In an empty `then` clause, the `else` is interpreted as a `Reserved` token + t + ex + [ Open "if", + simpleWordyId "a", + Close, + Open "then", + simpleWordyId "b", + Close, + Open "else", + Open "if", + simpleWordyId "c", + Close, + Open "then", + simpleWordyId "d", + Close, + Open "else", + Open "if", + simpleWordyId "e", + Close, + Open "then", + simpleWordyId "f", + Close, + Open "else", + simpleWordyId "g", + Close, + Close, + Close + ], + t + "if x then else" + [ Open "if", + simpleWordyId "x", + Close, + Open "then", + Close, + Open "else", + Close + ], + -- Empty `else` clause + t + "if x then 1 else" + [ Open "if", + simpleWordyId "x", + Close, + Open "then", + Numeric "1", + Close, + Open "else", + Close + ], + -- shouldn't be too eager to find keywords at the front of identifiers, + -- particularly for block-closing keywords (see #2727) + tests $ do + kw <- ["if", "then", "else"] + suffix <- ["0", "x", "!", "'"] -- examples of wordyIdChar + let i = kw ++ suffix + -- a keyword at the front of an identifier should still be an identifier + pure $ t i [simpleWordyId (Text.pack i)], + -- Test string literals + t + "\"simple string without escape characters\"" + [Textual "simple string without escape characters"], + t + "\"test escaped quotes \\\"in quotes\\\"\"" + [Textual "test escaped quotes \"in quotes\""], + t "\"\\n \\t \\b \\a\"" [Textual "\n \t \b \a"], + -- Delayed string + t "'\"\"" [Reserved "'", Textual ""], + -- https://github.com/unisonweb/unison/issues/4683 + -- don't emit virtual semis in ability lists or normal lists + t "{foo\n,bar}" [Open "{", simpleWordyId "foo", Reserved ",", simpleWordyId "bar", Close], + t "{foo\n ,bar}" [Open "{", simpleWordyId "foo", Reserved ",", simpleWordyId "bar", Close], + t "[foo\n,bar]" [Open "[", simpleWordyId "foo", Reserved ",", simpleWordyId "bar", Close], + t "[foo\n ,bar]" [Open "[", simpleWordyId "foo", Reserved ",", simpleWordyId "bar", Close] + ] + +t :: String -> [Lexeme] -> Test () +t s expected = case toList . preParse $ lexer filename s of + [token@(Token (Err _) _ _)] -> crash $ show token + tokened -> + let actual = payload <$> tokened + expected' = Open filename : expected <> pure Close + in scope s $ + if actual == expected' + then ok + else do + note $ "expected: " ++ show expected' + note $ "actual : " ++ show actual + crash "actual != expected" + where + filename = "test case" + +simpleSymbolyId :: Text -> Lexeme +simpleSymbolyId = + SymbolyId . HQ'.unsafeParseText + +simpleWordyId :: Text -> Lexeme +simpleWordyId = + WordyId . HQ'.unsafeParseText diff --git a/unison-syntax/unison-syntax.cabal b/unison-syntax/unison-syntax.cabal index 9c3241e394..8a3e2948ef 100644 --- a/unison-syntax/unison-syntax.cabal +++ b/unison-syntax/unison-syntax.cabal @@ -20,12 +20,15 @@ library Unison.Lexer.Pos Unison.Parser.Ann Unison.Syntax.HashQualified - Unison.Syntax.HashQualified' + Unison.Syntax.HashQualifiedPrime Unison.Syntax.Lexer Unison.Syntax.Lexer.Token + Unison.Syntax.Lexer.Unison Unison.Syntax.Name Unison.Syntax.NameSegment Unison.Syntax.Parser + Unison.Syntax.Parser.Doc + Unison.Syntax.Parser.Doc.Data Unison.Syntax.ReservedWords Unison.Syntax.ShortHash Unison.Syntax.Var @@ -68,13 +71,14 @@ library , bytes , containers , cryptonite + , deriving-compat , extra + , free , lens , megaparsec , mtl , parser-combinators , text - , text-builder , unison-core , unison-core1 , unison-hash @@ -86,6 +90,9 @@ library test-suite syntax-tests type: exitcode-stdio-1.0 main-is: Main.hs + other-modules: + Unison.Test.Doc + Unison.Test.Unison hs-source-dirs: test default-extensions: @@ -121,23 +128,13 @@ test-suite syntax-tests ghc-options: -Wall build-depends: base - , bytes , code-page - , containers - , cryptonite , easytest - , extra - , lens + , free , megaparsec - , mtl - , parser-combinators , text - , text-builder - , unison-core , unison-core1 - , unison-hash , unison-prelude , unison-syntax - , unison-util-base32hex - , unison-util-bytes + , unison-util-recursion default-language: Haskell2010