mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
Merge pull request #4675 from unisonweb/topic/native-compiler
Rework racket based runtime/compilation
This commit is contained in:
Arya Irani
GitHub
commit
27b29c1ee3
112
.github/workflows/ci.md
vendored
Normal file
112
.github/workflows/ci.md
vendored
Normal file
@ -0,0 +1,112 @@
|
||||
The new CI workflow builds `ucm`, generates racket source, and generates `unison-runtime` (aka `ucr`), saving them all as build artifacts.
|
||||
|
||||
At a high level, the CI process is:
|
||||
1. On all platforms, build `unisonweb/unison` Haskell program and run tests; save the resulting binaries as build artifacts
|
||||
2. On Ubuntu, generate and save the Racket sources as a build artifact
|
||||
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.11"`
|
||||
|
||||
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.
|
||||
|
||||
`*-cache-key-version` — increment one of these to invalidate its corresponding cache, though you shouldn't have to:
|
||||
- `ucm-binaries`
|
||||
- `unison-src-test-results`
|
||||
- `stack`
|
||||
- `stack-work`
|
||||
- `base-codebase`
|
||||
- `jit-src`
|
||||
- `jit-dist`
|
||||
|
||||
### Cached directories:
|
||||
|
||||
One reason for this change is to reduce the CI time for commits that only change docs, or yaml or other uninteresting things.
|
||||
|
||||
#### `.stack`
|
||||
Caches build dependencies needed by unison packages.
|
||||
|
||||
- The **cache key** includes the os, the stackage resolver, `stack.yaml`, and any `package.yaml`.
|
||||
|
||||
This currently will re-save on success or failure, but only on a cache miss (source changed).If we find we want to re-save even on a cache key miss (e.g. due to `stack` weirdness), we can change the condition.
|
||||
|
||||
#### `.stack-work`
|
||||
Caches build outputs for unison packages themselves.
|
||||
|
||||
- The **cache key** includes the os, the stackage resolver, `stack.yaml`, and any `package.yaml`.
|
||||
|
||||
This currently will re-save on success or failure, but only on a cache miss (source changed).If we find we want to re-save even on a cache key miss (e.g. due to `stack` weirdness), we can change the condition.
|
||||
|
||||
#### `ucm_local_bin`
|
||||
A built `ucm` is cached in `ucm_local_bin` after a successful build and Haskell tests pass.
|
||||
- The **cache key** includes the os, `stack.yaml`, any `package.yaml`, and any `.hs` file.
|
||||
- On an exact cache hit, these steps are skipped, otherwise they are run:
|
||||
- restore `.stack`
|
||||
- restore `.stack-work`
|
||||
- install `stack`
|
||||
- build `ucm` dependencies
|
||||
- build `ucm`
|
||||
- `unison-cli` tests
|
||||
- `unison-core` tests
|
||||
- `unison-parser-typechecker` tests
|
||||
- `unison-sqlite` tests
|
||||
- `unison-syntax` tests
|
||||
- `unison-util-bytes` tests
|
||||
- `unison-util-cache` tests
|
||||
- `unison-util-relation` tests
|
||||
- `cli-integration-tests`
|
||||
- verification of `stack ghci` startup
|
||||
- `interpreter-tests.md`
|
||||
|
||||
#### `unison_src_test_results`
|
||||
A bit is cached in `unison_src_test_results` after non-Haskell tests in the `unison` repo pass.
|
||||
- The **cache key** includes os, `stack.yaml`, any `package.yaml`, any `.hs` file, and any file in `unison-src/`
|
||||
- On an exact cache hit, these steps are skipped, otherwise they are run:
|
||||
- `round-trip-tests`
|
||||
- `transcripts`
|
||||
- `unison-src/builtin-tests/interpreter-tests.md`
|
||||
- If all steps suceed, the `unison_src_test_results` bit is saved.
|
||||
|
||||
#### `base-codebase`
|
||||
This stores the result of `base.md`, which can be reused later to save the cost of a `pull`.
|
||||
No steps are skipped on a cache hit; however, a second `pull` will mostly be a no-op.
|
||||
|
||||
#### `jit_src_scheme`
|
||||
JIT sources are cached in `jit_src_scheme` if the `generate-jit-source` job completes.
|
||||
- The **cache key** includes the version of Racket, and the release version of `@unison/internal`.
|
||||
- If the cache contains `{data-info, boot-generated, simple-wrappers, builtin-generated, compound-wrappers}.ss`, then these steps are skipped, otherwise they are run:
|
||||
- "create transcript" to produce pull `@unison/internal` and run `generateSchemeBoot`.
|
||||
- download `ucm artifact` saved in the previous step
|
||||
- set `ucm` permissions
|
||||
- checkout `unison` repo, which includes some static scheme and racket files.
|
||||
- run the previously generated transcript
|
||||
- If all steps succeed, the `jit_src_scheme` cache is saved.
|
||||
|
||||
#### `jit_dist`
|
||||
JIT binaries are cached in `jit_dist` if the `build-jit-binary` job completes.
|
||||
- The **cache key** includes the version of Racket, and the release version of `@unison/internal`.
|
||||
- On an exact cache hit, these steps are skipped, otherwise they are run:
|
||||
- Restore Racket dependencies
|
||||
- setup Racket
|
||||
- restore apt cache (Linux only)
|
||||
- download jit source from previous job
|
||||
- use `raco` to build jit binary
|
||||
- download `ucm` artifact from previous job
|
||||
- set `ucm` permissions
|
||||
- restore `base` codebase saved in previous job
|
||||
- jit integration test
|
||||
- If all of these steps succeed, the `jit_dist` cache is saved.
|
||||
537
.github/workflows/ci.yaml
vendored
537
.github/workflows/ci.yaml
vendored
@ -17,9 +17,29 @@ on:
|
||||
- release/*
|
||||
workflow_dispatch:
|
||||
|
||||
env:
|
||||
ormolu_version: "0.5.0.1"
|
||||
racket_version: "8.7"
|
||||
ucm_local_bin: "ucm-local-bin"
|
||||
jit_version: "@unison/internal/releases/0.0.11"
|
||||
jit_src_scheme: "unison-jit-src/scheme-libs/racket"
|
||||
jit_dist: "unison-jit-dist"
|
||||
jit_generator_os: ubuntu-20.04
|
||||
base-codebase: "~/.cache/unisonlanguage/base.unison"
|
||||
|
||||
# refers to all tests that depend on **/unison-src/**
|
||||
unison_src_test_results: "unison-src-test-results"
|
||||
|
||||
# cache key versions, increment to invalidate one, though you aren't expected to have to.
|
||||
ucm-binaries-cache-key-version: 1
|
||||
unison-src-test-results-cache-key-version: 1
|
||||
stack-cache-key-version: 1
|
||||
stack-work-cache-key-version: 4
|
||||
base-codebase-cache-key-version: 1
|
||||
jit-src-cache-key-version: 1
|
||||
jit-dist-cache-key-version: 1
|
||||
|
||||
jobs:
|
||||
|
||||
ormolu:
|
||||
runs-on: ubuntu-20.04
|
||||
# Only run formatting on trunk commits
|
||||
@ -27,7 +47,7 @@ jobs:
|
||||
# contributor forks on contributor PRs.
|
||||
if: github.ref_name == 'trunk'
|
||||
steps:
|
||||
- uses: actions/checkout@v2
|
||||
- uses: actions/checkout@v4
|
||||
- name: Get changed files
|
||||
id: changed-files
|
||||
uses: tj-actions/changed-files@v41
|
||||
@ -39,7 +59,7 @@ jobs:
|
||||
separator: "\n"
|
||||
- uses: haskell-actions/run-ormolu@v14
|
||||
with:
|
||||
version: "0.5.0.1"
|
||||
version: ${{ env.ormolu_version }}
|
||||
mode: inplace
|
||||
pattern: ${{ steps.changed-files.outputs.all_changed_files }}
|
||||
- name: apply formatting changes
|
||||
@ -47,16 +67,11 @@ jobs:
|
||||
if: ${{ always() }}
|
||||
with:
|
||||
commit_message: automatically run ormolu
|
||||
|
||||
build:
|
||||
name: ${{ matrix.os }}
|
||||
build-ucm:
|
||||
name: Build UCM ${{ matrix.os }}
|
||||
runs-on: ${{ matrix.os }}
|
||||
# The 'always()' causes this to build even if the ormolu job is skipped.
|
||||
if: ${{ always() }}
|
||||
if: always()
|
||||
needs: ormolu
|
||||
defaults:
|
||||
run:
|
||||
shell: bash
|
||||
strategy:
|
||||
# Run each build to completion, regardless of if any have failed
|
||||
fail-fast: false
|
||||
@ -66,59 +81,79 @@ jobs:
|
||||
- ubuntu-20.04
|
||||
- macOS-12
|
||||
- windows-2019
|
||||
# - windows-2022
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@v2
|
||||
- uses: actions/checkout@v4
|
||||
|
||||
- name: tweak environment
|
||||
run: |
|
||||
ucm_local_bin="${RUNNER_TEMP//\\//}/${ucm_local_bin}"
|
||||
unison_src_test_results="${RUNNER_TEMP//\\//}/${unison_src_test_results}"
|
||||
|
||||
echo "ucm_local_bin=$ucm_local_bin" >> $GITHUB_ENV
|
||||
if [[ ${{runner.os}} = "Windows" ]]; then
|
||||
echo "ucm=$ucm_local_bin/unison.exe" >> $GITHUB_ENV
|
||||
echo "transcripts=$ucm_local_bin/transcripts.exe" >> $GITHUB_ENV
|
||||
else
|
||||
echo "ucm=$ucm_local_bin/unison" >> $GITHUB_ENV
|
||||
echo "transcripts=$ucm_local_bin/transcripts" >> $GITHUB_ENV
|
||||
fi
|
||||
|
||||
- name: cache ucm binaries
|
||||
id: cache-ucm-binaries
|
||||
uses: actions/cache@v4
|
||||
with:
|
||||
path: ${{env.ucm_local_bin}}
|
||||
key: ucm-${{env.ucm-binaries-cache-key-version}}_${{ matrix.os }}-${{ hashFiles('**/stack.yaml', '**/package.yaml', '**/*.hs')}}
|
||||
|
||||
- name: cache unison-src test results
|
||||
id: cache-unison-src-test-results
|
||||
uses: actions/cache@v4
|
||||
with:
|
||||
path: ${{env.unison_src_test_results}}
|
||||
key: unison-src-test-results-${{env.unison-src-test-results-cache-key-version}}_${{ matrix.os }}-${{ hashFiles('**/ci.yaml', '**/stack.yaml', '**/package.yaml', '**/*.hs')}}-${{ hashFiles('**/unison-src/**') }}
|
||||
|
||||
# The number towards the beginning of the cache keys allow you to manually avoid using a previous cache.
|
||||
# GitHub will automatically delete caches that haven't been accessed in 7 days, but there is no way to
|
||||
# purge one manually.
|
||||
|
||||
|
||||
- id: stackage-resolver
|
||||
name: record stackage resolver
|
||||
# https://docs.github.com/en/actions/using-workflows/workflow-commands-for-github-actions#environment-files
|
||||
# looks for `resolver: nightly-yyyy-mm-dd` or `resolver: lts-xx.yy` in `stack.yaml` and splits it into
|
||||
# `nightly` or `lts-xx`. the whole resolver string is put into resolver_long as a backup cache key
|
||||
# ${{ steps.stackage-resolver.outputs.resolver_short }}
|
||||
# ${{ steps.stackage-resolver.outputs.resolver_long }}
|
||||
# `nightly` or `lts-xx`. the whole resolver string is put into $resolver as a backup cache key
|
||||
# ${{ env.resolver_short }}
|
||||
# ${{ env.resolver }}
|
||||
run: |
|
||||
grep resolver stack.yaml | awk '{ x="resolver_short="; if (split($2,a,"-") > 2) print x a[1]; else {split($2,b,"."); print x b[1]}}' >> "$GITHUB_OUTPUT"
|
||||
grep resolver stack.yaml | awk '{print "resolver_long="$2}' >> "$GITHUB_OUTPUT"
|
||||
# Cache ~/.stack, keyed by the contents of 'stack.yaml'.
|
||||
- uses: actions/cache@v3
|
||||
name: cache ~/.stack (unix)
|
||||
if: runner.os != 'Windows'
|
||||
grep resolver stack.yaml | awk '{ x="resolver_short="; if (split($2,a,"-") > 2) print x a[1]; else {split($2,b,"."); print x b[1]}}' >> "$GITHUB_ENV"
|
||||
grep resolver stack.yaml | awk '{print "resolver="$2}' >> "$GITHUB_ENV"
|
||||
|
||||
- name: restore ~/.stack (non-Windows)
|
||||
uses: actions/cache/restore@v4
|
||||
id: cache-stack-unix
|
||||
if: runner.os != 'Windows' && steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
with:
|
||||
path: ~/.stack
|
||||
key: stack-1_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_long }}-${{hashFiles('**/stack.yaml')}}-${{github.sha}}
|
||||
# Fall-back to use the most recent cache for the stack.yaml, or failing that the OS
|
||||
restore-keys: |
|
||||
stack-1_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_long }}-${{hashFiles('**/stack.yaml')}}-
|
||||
stack-1_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_long }}-
|
||||
stack-1_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_short }}-
|
||||
stack-1_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_short }}.
|
||||
stack-1_${{matrix.os}}-
|
||||
key: stack-${{env.stack-cache-key-version}}_${{matrix.os}}-${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}
|
||||
# Fall-back to use the most recent cache for this resolver
|
||||
restore-keys: stack-${{env.stack-cache-key-version}}_${{matrix.os}}-${{env.resolver}}-
|
||||
|
||||
# Cache ~/.stack, keyed by the contents of 'stack.yaml'.
|
||||
- uses: actions/cache@v3
|
||||
name: cache ~/.stack (Windows)
|
||||
if: runner.os == 'Windows'
|
||||
- name: restore ~/.stack (Windows)
|
||||
uses: actions/cache/restore@v4
|
||||
id: cache-stack-windows
|
||||
if: runner.os == 'Windows' && steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
with:
|
||||
path: |
|
||||
C:\Users\runneradmin\AppData\Roaming\stack
|
||||
C:\Users\runneradmin\AppData\Local\Programs\stack
|
||||
key: stack-1_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_long }}-${{hashFiles('**/stack.yaml')}}-${{github.sha}}
|
||||
# Fall-back to use the most recent cache for the stack.yaml, or failing that the OS
|
||||
restore-keys: |
|
||||
stack-1_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_long }}-${{hashFiles('**/stack.yaml')}}-
|
||||
stack-1_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_long }}-
|
||||
stack-1_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_short }}-
|
||||
stack-1_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_short }}.
|
||||
stack-1_${{matrix.os}}-
|
||||
key: stack-${{env.stack-cache-key-version}}_${{matrix.os}}-${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}
|
||||
# Fall-back to use the most recent cache for this resolver
|
||||
restore-keys: stack-${{env.stack-cache-key-version}}_${{matrix.os}}-${{env.resolver}}-
|
||||
|
||||
# Cache each local package's ~/.stack-work for fast incremental builds in CI.
|
||||
- uses: actions/cache@v3
|
||||
name: cache .stack-work
|
||||
- name: restore .stack-work
|
||||
uses: actions/cache/restore@v4
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
id: cache-stack-work
|
||||
with:
|
||||
path: |
|
||||
**/.stack-work
|
||||
@ -128,18 +163,16 @@ jobs:
|
||||
# recent branch cache.
|
||||
# Then it will save a new cache at this commit sha, which should be used by
|
||||
# the next build on this branch.
|
||||
key: stack-work-4_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_short }}-${{hashFiles('**/stack.yaml')}}-${{github.sha}}
|
||||
key: stack-work-${{env.stack-work-cache-key-version}}_${{matrix.os}}-${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}-${{hashFiles('**/*.hs')}}
|
||||
restore-keys: |
|
||||
stack-work-4_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_long }}-${{hashFiles('**/stack.yaml')}}-
|
||||
stack-work-4_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_long }}-
|
||||
stack-work-4_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_short }}-
|
||||
stack-work-4_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_short }}.
|
||||
stack-work-4_${{matrix.os}}-
|
||||
stack-work-${{env.stack-work-cache-key-version}}_${{matrix.os}}-${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}-
|
||||
stack-work-${{env.stack-work-cache-key-version}}_${{matrix.os}}-${{env.resolver}}-
|
||||
stack-work-${{env.stack-work-cache-key-version}}_${{matrix.os}}-
|
||||
|
||||
# Install stack by downloading the binary from GitHub.
|
||||
# The installation process differs by OS.
|
||||
- name: install stack (Linux)
|
||||
if: runner.os == 'Linux'
|
||||
if: runner.os == 'Linux' && steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
working-directory: ${{ runner.temp }}
|
||||
run: |
|
||||
mkdir stack && cd stack
|
||||
@ -147,20 +180,26 @@ jobs:
|
||||
echo "$PWD/stack-"* >> $GITHUB_PATH
|
||||
|
||||
- name: install stack (macOS)
|
||||
if: runner.os == 'macOS' && steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
working-directory: ${{ runner.temp }}
|
||||
if: runner.os == 'macOS'
|
||||
run: |
|
||||
mkdir stack && cd stack
|
||||
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.9.1/stack-2.9.1-osx-x86_64.tar.gz | tar -xz
|
||||
echo "$PWD/stack-"* >> $GITHUB_PATH
|
||||
|
||||
- name: install stack (windows)
|
||||
if: runner.os == 'Windows' && steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
working-directory: ${{ runner.temp }}
|
||||
if: runner.os == 'Windows'
|
||||
run: |
|
||||
mkdir stack && cd stack
|
||||
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.9.1/stack-2.9.1-windows-x86_64.tar.gz | tar -xz
|
||||
echo "$PWD/stack-"* >> $GITHUB_PATH
|
||||
# temporarily print what's in the cached system stack dir
|
||||
echo "C:/Users/runneradmin/AppData/Roaming/stack:"
|
||||
ls C:/Users/runneradmin/AppData/Roaming/stack
|
||||
echo ""
|
||||
echo "C:/Users/runneradmin/AppData/Local/Programs/stack:"
|
||||
ls C:/Users/runneradmin/AppData/Local/Programs/stack
|
||||
|
||||
# One of the transcripts fails if the user's git name hasn't been set.
|
||||
- name: set git user info
|
||||
@ -172,22 +211,10 @@ jobs:
|
||||
if: runner.os == 'macOS'
|
||||
run: rm -rf ~/.stack/setup-exe-cache
|
||||
|
||||
- name: install stack-clean-old (to scan or clean up old stackage caches)
|
||||
run: |
|
||||
if ! stack exec -- which stack-clean-old; then
|
||||
stack install stack-clean-old
|
||||
fi
|
||||
|
||||
- name: check initial stackage cache size
|
||||
run: |
|
||||
echo global .stack
|
||||
stack exec -- stack-clean-old list -G || true
|
||||
echo project .stack-work
|
||||
stack exec -- stack-clean-old list -P || true
|
||||
|
||||
# Build deps, then build local code. Splitting it into two steps just allows us to see how much time each step
|
||||
# takes.
|
||||
- name: build dependencies
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
# Run up to 5 times in a row before giving up.
|
||||
# It's very unlikely that our build-dependencies step will fail on most builds,
|
||||
# so if it fails its almost certainly due to a race condition on the Windows
|
||||
@ -202,122 +229,340 @@ jobs:
|
||||
fi
|
||||
|
||||
for (( i = 0; i < $tries; i++ )); do
|
||||
stack --no-terminal build --fast --only-dependencies && break;
|
||||
stack build --fast --only-dependencies && break;
|
||||
done
|
||||
|
||||
- name: build
|
||||
run: stack --no-terminal build --fast --no-run-tests --test
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
run: |
|
||||
stack build \
|
||||
--fast \
|
||||
--test \
|
||||
--no-run-tests \
|
||||
--local-bin-path ${{env.ucm_local_bin}} \
|
||||
--copy-bins
|
||||
|
||||
# Run each test suite (tests and transcripts)
|
||||
- name: check disk space before
|
||||
if: ${{ always() }}
|
||||
run: df -h
|
||||
- name: unison-cli test
|
||||
run: stack --no-terminal build --fast --test unison-cli
|
||||
- name: check disk space after
|
||||
if: ${{ always() }}
|
||||
run: df -h
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
run: stack build --fast --test unison-cli
|
||||
|
||||
- name: unison-core tests
|
||||
run: stack --no-terminal build --fast --test unison-core
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
run: stack build --fast --test unison-core
|
||||
|
||||
- name: unison-parser-typechecker tests
|
||||
run: stack --no-terminal build --fast --test unison-parser-typechecker
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
run: stack build --fast --test unison-parser-typechecker
|
||||
|
||||
- name: unison-sqlite tests
|
||||
run: stack --no-terminal build --fast --test unison-sqlite
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
run: stack build --fast --test unison-sqlite
|
||||
|
||||
- name: unison-syntax tests
|
||||
run: stack --no-terminal build --fast --test unison-syntax
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
run: stack build --fast --test unison-syntax
|
||||
|
||||
- name: unison-util-bytes tests
|
||||
run: stack --no-terminal build --fast --test unison-util-bytes
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
run: stack build --fast --test unison-util-bytes
|
||||
|
||||
- name: unison-util-cache tests
|
||||
run: stack --no-terminal build --fast --test unison-util-cache
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
run: stack build --fast --test unison-util-cache
|
||||
|
||||
- name: unison-util-relation tests
|
||||
run: stack --no-terminal build --fast --test unison-util-relation
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
run: stack build --fast --test unison-util-relation
|
||||
|
||||
- name: round-trip-tests
|
||||
if: steps.cache-unison-src-test-results.outputs.cache-hit != 'true'
|
||||
run: |
|
||||
stack --no-terminal exec unison transcript unison-src/transcripts-round-trip/main.md
|
||||
git add unison-src/transcripts-round-trip/main.output.md
|
||||
${{env.ucm}} transcript unison-src/transcripts-round-trip/main.md
|
||||
${{env.ucm}} transcript unison-src/transcripts-manual/rewrites.md
|
||||
# Fail if any transcripts cause git diffs.
|
||||
git diff --cached --ignore-cr-at-eol --exit-code
|
||||
stack --no-terminal exec unison transcript unison-src/transcripts-manual/rewrites.md
|
||||
git add unison-src/transcripts-manual/rewrites.output.md
|
||||
# Fail if any transcripts cause git diffs.
|
||||
git diff --cached --ignore-cr-at-eol --exit-code
|
||||
git diff --ignore-cr-at-eol --exit-code \
|
||||
unison-src/transcripts-round-trip/main.output.md \
|
||||
unison-src/transcripts-manual/rewrites.output.md
|
||||
|
||||
- name: transcripts
|
||||
if: steps.cache-unison-src-test-results.outputs.cache-hit != 'true'
|
||||
run: |
|
||||
stack --no-terminal exec transcripts
|
||||
# Add all changes to the index for when we diff.
|
||||
git add --all
|
||||
${{env.transcripts}}
|
||||
# Fail if any transcripts cause git diffs.
|
||||
git diff --cached --ignore-cr-at-eol --exit-code
|
||||
git diff --ignore-cr-at-eol --exit-code unison-src/transcripts
|
||||
|
||||
- name: cli-integration-tests
|
||||
run: stack --no-terminal exec cli-integration-tests
|
||||
- name: Cache Racket dependencies
|
||||
uses: actions/cache@v2
|
||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
run: stack exec cli-integration-tests
|
||||
|
||||
- name: verify stack ghci startup
|
||||
if: runner.os == 'macOS' && steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||
run: echo | stack ghci
|
||||
|
||||
- name: cache base codebase
|
||||
id: cache-base-codebase
|
||||
uses: actions/cache@v4
|
||||
with:
|
||||
path: ${{ env.base-codebase }}
|
||||
# key = base transcript contents + sqlite schema version
|
||||
key: base.unison-${{env.base-codebase-cache-key-version}}_${{hashFiles('**/unison-src/builtin-tests/base.md', '**/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs')}}.
|
||||
|
||||
- name: create base.md codebase
|
||||
if: steps.cache-base-codebase.outputs.cache-hit != 'true'
|
||||
run: ${{env.ucm}} transcript.fork -C ${{env.base-codebase}} -S ${{env.base-codebase}} unison-src/builtin-tests/base.md
|
||||
|
||||
- name: interpreter tests
|
||||
# this one should be re-run if the ucm binaries have changed or unison-src/ has changed
|
||||
if: runner.os != 'Windows' && (steps.cache-ucm-binaries.outputs.cache-hit != 'true' || steps.cache-unison-src-test-results.outputs.cache-hit != 'true')
|
||||
run: |
|
||||
${{ env.ucm }} transcript.fork -c ${{env.base-codebase}} unison-src/builtin-tests/interpreter-tests.md
|
||||
cat unison-src/builtin-tests/interpreter-tests.output.md
|
||||
git diff --exit-code unison-src/builtin-tests/interpreter-tests.output.md
|
||||
|
||||
- name: mark transcripts as passing
|
||||
if: steps.cache-unison-src-test-results.outputs.cache-hit != 'true'
|
||||
run: |
|
||||
echo "passing=true" >> "${{env.unison_src_test_results}}"
|
||||
|
||||
- name: save ucm artifact
|
||||
uses: actions/upload-artifact@v4
|
||||
with:
|
||||
name: unison-${{ matrix.os }}
|
||||
path: ${{ env.ucm }}
|
||||
if-no-files-found: error
|
||||
|
||||
- name: save ~/.stack (non-Windows)
|
||||
if: runner.os != 'Windows' && ${{ !cancelled() }} && steps.cache-stack-unix.outputs.cache-hit != 'true'
|
||||
uses: actions/cache/save@v4
|
||||
with:
|
||||
path: ~/.stack
|
||||
key: stack-${{env.stack-cache-key-version}}_${{matrix.os}}-${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}
|
||||
|
||||
- name: save ~/.stack (Windows)
|
||||
if: runner.os == 'Windows' && ${{ !cancelled() }} && steps.cache-stack-windows.outputs.cache-hit != 'true'
|
||||
uses: actions/cache/save@v4
|
||||
with:
|
||||
path: |
|
||||
C:\Users\runneradmin\AppData\Roaming\stack
|
||||
C:\Users\runneradmin\AppData\Local\Programs\stack
|
||||
key: stack-${{env.stack-cache-key-version}}_${{matrix.os}}-${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}
|
||||
|
||||
- name: save .stack-work
|
||||
# can change this to always() if we find this isn't doing the right thing.
|
||||
if: ${{ !cancelled() }} && steps.cache-stack-work.outputs.cache-hit != 'true'
|
||||
uses: actions/cache/save@v4
|
||||
with:
|
||||
path: |
|
||||
**/.stack-work
|
||||
key: stack-work-${{env.stack-work-cache-key-version}}_${{matrix.os}}-${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}-${{hashFiles('**/*.hs')}}
|
||||
|
||||
|
||||
generate-jit-source:
|
||||
if: always() && needs.build-ucm.result == 'success'
|
||||
name: Generate JIT source
|
||||
needs: build-ucm
|
||||
runs-on: ubuntu-20.04
|
||||
steps:
|
||||
- name: set up environment
|
||||
run: |
|
||||
echo "jit_src_scheme=${{ runner.temp }}/${{ env.jit_src_scheme }}" >> $GITHUB_ENV
|
||||
echo "ucm=${{ runner.temp }}/unison" >> $GITHUB_ENV
|
||||
- uses: actions/cache@v4
|
||||
name: cache jit source
|
||||
if: runner.os == 'Linux'
|
||||
with:
|
||||
path: ${{ env.jit_src_scheme }}
|
||||
key: jit_src_scheme-${{env.jit-src-cache-key-version}}.racket_${{env.racket_version}}.jit_${{env.jit_version}}
|
||||
|
||||
- name: check source exists
|
||||
id: jit_src_exists
|
||||
run: |
|
||||
files=(data-info boot-generated simple-wrappers builtin-generated compound-wrappers)
|
||||
all_exist=true
|
||||
|
||||
for file in "${files[@]}"; do
|
||||
if [[ ! -f "${{ env.jit_src_scheme }}/unison/$file.ss" ]]; then
|
||||
echo "$file does not exist."
|
||||
all_exist=false
|
||||
# Uncomment the next line if you want to stop checking after the first missing file
|
||||
# break
|
||||
fi
|
||||
done
|
||||
|
||||
if $all_exist; then
|
||||
echo "files_exists=true" >> $GITHUB_OUTPUT
|
||||
else
|
||||
echo "files_exists=false" >> $GITHUB_OUTPUT
|
||||
fi
|
||||
|
||||
- name: create transcript
|
||||
if: steps.jit_src_exists.outputs.files_exists == 'false'
|
||||
uses: DamianReeves/write-file-action@v1.3
|
||||
with:
|
||||
path: ${{ runner.temp }}/setup-jit.md
|
||||
write-mode: overwrite
|
||||
contents: |
|
||||
```ucm
|
||||
.> project.create-empty jit-setup
|
||||
jit-setup/main> pull ${{ env.jit_version }} lib.jit
|
||||
```
|
||||
```unison
|
||||
go = generateSchemeBoot "${{ env.jit_src_scheme }}"
|
||||
```
|
||||
```ucm
|
||||
jit-setup/main> run go
|
||||
```
|
||||
|
||||
- name: download ucm artifact
|
||||
if: steps.jit_src_exists.outputs.files_exists == 'false'
|
||||
uses: actions/download-artifact@v4
|
||||
with:
|
||||
name: unison-${{ env.jit_generator_os }}
|
||||
path: ${{ runner.temp }}
|
||||
|
||||
- name: set ucm permissions
|
||||
if: steps.jit_src_exists.outputs.files_exists == 'false'
|
||||
run: chmod +x ${{ env.ucm }}
|
||||
|
||||
- name: download scheme-libs
|
||||
if: steps.jit_src_exists.outputs.files_exists == 'false'
|
||||
uses: actions/checkout@v4
|
||||
|
||||
- name: generate source
|
||||
if: steps.jit_src_exists.outputs.files_exists == 'false'
|
||||
run: |
|
||||
mkdir -p ${{ env.jit_src_scheme }}
|
||||
cp -R scheme-libs/racket/* ${{ env.jit_src_scheme }}
|
||||
${{ env.ucm }} transcript ${{ runner.temp }}/setup-jit.md
|
||||
|
||||
- name: save jit source
|
||||
if: ${{ always() }}
|
||||
uses: actions/upload-artifact@v4
|
||||
with:
|
||||
name: jit-source
|
||||
path: ${{ env.jit_src_scheme }}/**
|
||||
if-no-files-found: error
|
||||
|
||||
|
||||
build-jit-binary:
|
||||
if: always() && needs.generate-jit-source.result == 'success'
|
||||
name: Build JIT binary ${{ matrix.os }}
|
||||
needs: generate-jit-source
|
||||
runs-on: ${{ matrix.os }}
|
||||
strategy:
|
||||
# Run each build to completion, regardless of if any have failed
|
||||
fail-fast: false
|
||||
matrix:
|
||||
os:
|
||||
# While iterating on this file, you can disable one or more of these to speed things up
|
||||
- ubuntu-20.04
|
||||
- macOS-12
|
||||
- windows-2019
|
||||
steps:
|
||||
- name: set up environment
|
||||
id: checks
|
||||
run: |
|
||||
jit_src_scheme="${{ runner.temp }}/${{ env.jit_src_scheme }}" # scheme source
|
||||
jit_exe="${jit_src_scheme}/unison-runtime" # initially built jit
|
||||
jit_dist="${{ runner.temp }}/${{ env.jit_dist }}" # jit binary with libraries destination
|
||||
jit_dist_exe="${jit_dist}/bin/unison-runtime" # jit binary itself
|
||||
ucm="${{ runner.temp }}/unison"
|
||||
|
||||
if [[ ${{runner.os}} = "Windows" ]]; then
|
||||
jit_src_scheme="${jit_src_scheme//\\//}"
|
||||
jit_dist="${jit_dist//\\//}"
|
||||
|
||||
jit_exe="${jit_exe//\\//}.exe"
|
||||
jit_dist_exe="${jit_dist//\\//}/unison-runtime.exe"
|
||||
ucm="${ucm//\\//}.exe"
|
||||
fi
|
||||
|
||||
echo "jit_src_scheme=$jit_src_scheme" >> $GITHUB_ENV
|
||||
echo "jit_exe=$jit_exe" >> $GITHUB_ENV
|
||||
echo "jit_dist=$jit_dist" >> $GITHUB_ENV
|
||||
echo "jit_dist_exe=$jit_dist_exe" >> $GITHUB_ENV
|
||||
echo "ucm=$ucm" >> $GITHUB_ENV
|
||||
|
||||
- name: restore jit binaries
|
||||
id: restore-jit-binaries
|
||||
uses: actions/cache@v4
|
||||
with:
|
||||
path: ${{ env.jit_dist }}
|
||||
key: jit_dist-${{env.jit-dist-cache-key-version}}.racket_${{ env.racket_version }}.jit_${{ env.jit_version }}
|
||||
|
||||
- name: Cache Racket dependencies
|
||||
if: steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
||||
uses: actions/cache@v4
|
||||
with:
|
||||
path: |
|
||||
~/.cache/racket
|
||||
~/.local/share/racket
|
||||
key: ${{ runner.os }}-racket-8.7
|
||||
|
||||
- uses: Bogdanp/setup-racket@v1.10
|
||||
if: runner.os == 'Linux'
|
||||
key: ${{ runner.os }}-racket-${{env.racket_version}}
|
||||
- uses: Bogdanp/setup-racket@v1.11
|
||||
if: steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
||||
with:
|
||||
architecture: 'x64'
|
||||
distribution: 'full'
|
||||
variant: 'CS'
|
||||
version: '8.7' # match with cache key above
|
||||
- run: raco pkg install --auto --skip-installed --batch x509-lib
|
||||
if: runner.os == 'Linux'
|
||||
version: ${{env.racket_version}}
|
||||
- uses: awalsh128/cache-apt-pkgs-action@latest
|
||||
if: runner.os == 'Linux' && steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
||||
# read this if a package isn't installing correctly
|
||||
# https://github.com/awalsh128/cache-apt-pkgs-action#caveats
|
||||
if: runner.os == 'Linux'
|
||||
with:
|
||||
packages: libb2-dev
|
||||
version: 1.0 # cache key version afaik
|
||||
|
||||
- uses: actions/cache@v3
|
||||
name: cache base.md codebase (unix)
|
||||
if: runner.os == 'Linux'
|
||||
- name: download jit source
|
||||
if: steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
||||
uses: actions/download-artifact@v4
|
||||
with:
|
||||
path: ~/.cache/unisonlanguage/base.unison
|
||||
key: base.unison_${{hashFiles('**/unison-src/builtin-tests/base.md','**/unison-cli/src/Unison/JitInfo.hs')}}-${{github.sha}}
|
||||
restore-keys: base.unison_${{hashFiles('**/unison-src/builtin-tests/base.md','**/unison-cli/src/Unison/JitInfo.hs')}}-
|
||||
name: jit-source
|
||||
path: ${{ env.jit_src_scheme }}
|
||||
|
||||
- name: set up `base` codebase
|
||||
if: runner.os == 'Linux'
|
||||
run: |
|
||||
./unison-src/builtin-tests/setup-base-codebase.sh
|
||||
- uses: actions/checkout@v4 # checkout scheme-libs from unison repo
|
||||
|
||||
- name: jit tests
|
||||
# if: false # temporarily disabled
|
||||
if: runner.os == 'Linux'
|
||||
- name: build jit binary
|
||||
if: steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
||||
shell: bash
|
||||
run: |
|
||||
./unison-src/builtin-tests/jit-tests.sh
|
||||
cat ./unison-src/builtin-tests/jit-tests.output.md
|
||||
CHANGE=$(git diff unison-src/builtin-tests/jit-tests.output.md)
|
||||
if [ -n "$CHANGE" ]; then
|
||||
echo "The jit-tests output has changed"
|
||||
exit 1
|
||||
fi
|
||||
cp -R scheme-libs/racket/* "$jit_src_scheme"
|
||||
raco pkg install --auto --skip-installed "$jit_src_scheme"/unison
|
||||
raco exe --embed-dlls "$jit_src_scheme"/unison-runtime.rkt
|
||||
raco distribute "$jit_dist" "$jit_exe"
|
||||
|
||||
- name: interpreter tests
|
||||
# if: false # temporarily disabled
|
||||
if: runner.os == 'Linux'
|
||||
run: |
|
||||
./unison-src/builtin-tests/interpreter-tests.sh
|
||||
cat ./unison-src/builtin-tests/interpreter-tests.output.md
|
||||
CHANGE=$(git diff unison-src/builtin-tests/interpreter-tests.output.md)
|
||||
if [ -n "$CHANGE" ]; then
|
||||
echo "The interpreter-tests output has changed"
|
||||
exit 1
|
||||
fi
|
||||
- name: save jit binary
|
||||
uses: actions/upload-artifact@v4
|
||||
with:
|
||||
name: jit-binary-${{ matrix.os }}
|
||||
path: ${{ env.jit_dist }}/**
|
||||
|
||||
- name: verify stack ghci startup
|
||||
if: runner.os == 'macOS'
|
||||
run: echo | stack ghci
|
||||
- name: check final stackage cache size
|
||||
- name: download ucm
|
||||
if: steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
||||
uses: actions/download-artifact@v4
|
||||
with:
|
||||
name: unison-${{ matrix.os }}
|
||||
path: ${{ runner.temp }}
|
||||
|
||||
- name: set ucm permissions
|
||||
if: steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
||||
run: chmod +x ${{ env.ucm }}
|
||||
|
||||
- name: get base codebase
|
||||
if: steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
||||
uses: actions/cache/restore@v4
|
||||
with:
|
||||
path: ${{ env.base-codebase}}
|
||||
key: base.unison-${{env.base-codebase-cache-key-version}}_${{hashFiles('**/unison-src/builtin-tests/base.md', '**/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs')}}.
|
||||
|
||||
- name: jit integration test ${{ matrix.os }}
|
||||
if: runner.os != 'Windows' && steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
||||
run: |
|
||||
echo global .stack
|
||||
stack exec -- stack-clean-old list -G || true
|
||||
echo project .stack-work
|
||||
stack exec -- stack-clean-old list -P || true
|
||||
${{ env.ucm }} transcript.fork --runtime-path ${{ env.jit_dist_exe }} -c ${{env.base-codebase}} unison-src/builtin-tests/jit-tests.md
|
||||
cat unison-src/builtin-tests/jit-tests.output.md
|
||||
git diff --exit-code unison-src/builtin-tests/jit-tests.output.md
|
||||
|
||||
# - name: Setup tmate session
|
||||
# uses: mxschmitt/action-tmate@v3
|
||||
# if: ${{ failure() }}
|
||||
# timeout-minutes: 15
|
||||
|
||||
38
docs/github-actions-help.md
Normal file
38
docs/github-actions-help.md
Normal file
@ -0,0 +1,38 @@
|
||||
## 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't define a `matrix` at the top level, it has to be defined within a `job`'s `strategy`.
|
||||
|
||||
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.<name>.outputs.bar` in yaml strings
|
||||
|
||||
echo "foo=whatever" >> $GITHUB_ENV
|
||||
# access with `env.foo` in yaml strings, or `$foo` in bash
|
||||
|
||||
|
||||
### 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."
|
||||
|
||||
### Composite Actions
|
||||
|
||||
Needs to have `shell:` specified on every `run:`
|
||||
|
||||
### 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
|
||||
@ -18,5 +18,8 @@ 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
|
||||
|
||||
@ -21,6 +21,7 @@ module Unison.Runtime.Interface
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM as STM
|
||||
import Control.Exception (throwIO)
|
||||
import Control.Monad
|
||||
import Data.Binary.Get (runGetOrFail)
|
||||
-- import Data.Bits (shiftL)
|
||||
@ -44,10 +45,23 @@ import Data.Set as Set
|
||||
)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text (isPrefixOf, unpack)
|
||||
import GHC.IO.Exception (IOErrorType (NoSuchThing, OtherError, PermissionDenied), IOException (ioe_description, ioe_type))
|
||||
import GHC.Stack (callStack)
|
||||
import System.Directory
|
||||
( XdgDirectory (XdgCache),
|
||||
createDirectoryIfMissing,
|
||||
getXdgDirectory,
|
||||
)
|
||||
import System.Exit (ExitCode (..))
|
||||
import System.FilePath ((<.>), (</>))
|
||||
import System.Process
|
||||
( CreateProcess (..),
|
||||
( CmdSpec (RawCommand, ShellCommand),
|
||||
CreateProcess (..),
|
||||
StdStream (..),
|
||||
callProcess,
|
||||
proc,
|
||||
readCreateProcessWithExitCode,
|
||||
shell,
|
||||
waitForProcess,
|
||||
withCreateProcess,
|
||||
)
|
||||
@ -433,18 +447,19 @@ decompileCtx crs ctx = decompile ib $ backReferenceTm crs fr ir dt
|
||||
dt = decompTm ctx
|
||||
|
||||
nativeEval ::
|
||||
FilePath ->
|
||||
IORef EvalCtx ->
|
||||
CodeLookup Symbol IO () ->
|
||||
PrettyPrintEnv ->
|
||||
Term Symbol ->
|
||||
IO (Either Error ([Error], Term Symbol))
|
||||
nativeEval ctxVar cl ppe tm = catchInternalErrors $ do
|
||||
nativeEval executable ctxVar cl ppe tm = catchInternalErrors $ do
|
||||
ctx <- readIORef ctxVar
|
||||
(tyrs, tmrs) <- collectDeps cl tm
|
||||
(ctx, codes) <- loadDeps cl ppe ctx tyrs tmrs
|
||||
(ctx, tcodes, base) <- prepareEvaluation ppe tm ctx
|
||||
writeIORef ctxVar ctx
|
||||
nativeEvalInContext ppe ctx (codes ++ tcodes) base
|
||||
nativeEvalInContext executable ppe ctx (codes ++ tcodes) base
|
||||
|
||||
interpEval ::
|
||||
ActiveThreads ->
|
||||
@ -465,19 +480,144 @@ 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 cmd err =
|
||||
ccall >>= \case
|
||||
Nothing -> pure ()
|
||||
Just failure -> dieP $ err (cmdspec cmd) failure
|
||||
where
|
||||
call =
|
||||
readCreateProcessWithExitCode cmd "" >>= \case
|
||||
(ExitSuccess, _stdout, _stderr) -> pure Nothing
|
||||
(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 executable =
|
||||
ensureExists cmd runtimeErrMsg
|
||||
where
|
||||
cmd = proc executable ["--help"]
|
||||
|
||||
ensureRacoExists :: HasCallStack => IO ()
|
||||
ensureRacoExists = ensureExists (shell "raco help") racoErrMsg
|
||||
|
||||
prettyCmdSpec :: CmdSpec -> Pretty ColorText
|
||||
prettyCmdSpec = \case
|
||||
ShellCommand string -> fromString string
|
||||
System.Process.RawCommand filePath args ->
|
||||
P.sep " " (fromString filePath : Prelude.map fromString args)
|
||||
|
||||
prettyCallError :: Either (Int, String, String) IOException -> Pretty ColorText
|
||||
prettyCallError = \case
|
||||
Right ex ->
|
||||
P.lines
|
||||
[ P.wrap . fromString $ "The error type was: '" ++ show (ioe_type ex) ++ "', and the message is:",
|
||||
"",
|
||||
P.indentN 2 (fromString (ioe_description ex))
|
||||
]
|
||||
Left (errCode, stdout, stderr) ->
|
||||
let prettyExitCode = "The exit code was" <> fromString (show errCode)
|
||||
in if null stdout && null stderr
|
||||
then P.wrap $ prettyExitCode <> " but there was no output."
|
||||
else
|
||||
P.lines
|
||||
[ P.wrap $ prettyExitCode <> "and the output was:",
|
||||
"",
|
||||
P.indentN
|
||||
2
|
||||
if null stdout
|
||||
then fromString stderr
|
||||
else
|
||||
if null stderr
|
||||
then fromString stdout
|
||||
else P.lines $ [fromString stdout, "", "---", "", fromString stderr]
|
||||
]
|
||||
|
||||
-- https://hackage.haskell.org/package/process-1.6.18.0/docs/System-Process.html#t:CreateProcess
|
||||
-- https://hackage.haskell.org/package/base-4.19.0.0/docs/GHC-IO-Exception.html#t:IOError
|
||||
-- https://hackage.haskell.org/package/base-4.19.0.0/docs/GHC-IO-Exception.html#t:IOErrorType
|
||||
runtimeErrMsg :: CmdSpec -> Either (Int, String, String) IOException -> Pretty ColorText
|
||||
runtimeErrMsg c error =
|
||||
case error of
|
||||
Right (ioe_type -> NoSuchThing) ->
|
||||
P.lines
|
||||
[ P.wrap "I couldn't find the Unison native runtime. I tried to start it with:",
|
||||
"",
|
||||
P.indentN 2 $ prettyCmdSpec c,
|
||||
"",
|
||||
P.wrap
|
||||
"If that doesn't look right, you can use the `--runtime-path` command line \
|
||||
\argument to specify the correct path for the executable."
|
||||
]
|
||||
Right (ioe_type -> PermissionDenied) ->
|
||||
P.lines
|
||||
[ P.wrap
|
||||
"I got a 'Permission Denied' error when trying to start the \
|
||||
\Unison native runtime with:",
|
||||
"",
|
||||
P.indentN 2 $ prettyCmdSpec c,
|
||||
"",
|
||||
P.wrap
|
||||
"Please check the permisssions (e.g. check that the directory is accessible, \
|
||||
\and that the program is marked executable).",
|
||||
"",
|
||||
P.wrap
|
||||
"If it looks like I'm calling the wrong executable altogether, you can use the \
|
||||
\`--runtime-path` command line argument to specify the correct one."
|
||||
]
|
||||
_ ->
|
||||
P.lines
|
||||
[ P.wrap
|
||||
"I got an error when starting the Unison native runtime using:",
|
||||
"",
|
||||
P.indentN 2 (prettyCmdSpec c),
|
||||
"",
|
||||
prettyCallError error
|
||||
]
|
||||
|
||||
racoErrMsg :: CmdSpec -> Either (Int, String, String) IOException -> Pretty ColorText
|
||||
racoErrMsg c = \case
|
||||
Right (ioe_type -> e@OtherError) ->
|
||||
P.lines
|
||||
[ P.wrap . fromString $
|
||||
"Sorry, I got an error of type '"
|
||||
++ show e
|
||||
++ "' when I ran `raco`, \
|
||||
\and I'm not sure what to do about it.",
|
||||
"",
|
||||
"For debugging purposes, the full command was:",
|
||||
"",
|
||||
P.indentN 2 (prettyCmdSpec c)
|
||||
]
|
||||
error ->
|
||||
P.lines
|
||||
[ P.wrap
|
||||
"I can't seem to call `raco`. Please ensure Racket \
|
||||
\is installed.",
|
||||
"",
|
||||
prettyCallError error,
|
||||
"",
|
||||
"See",
|
||||
"",
|
||||
P.indentN 2 "https://download.racket-lang.org/",
|
||||
"",
|
||||
"for how to install Racket manually."
|
||||
]
|
||||
|
||||
nativeCompile ::
|
||||
Text ->
|
||||
FilePath ->
|
||||
IORef EvalCtx ->
|
||||
CodeLookup Symbol IO () ->
|
||||
PrettyPrintEnv ->
|
||||
Reference ->
|
||||
FilePath ->
|
||||
IO (Maybe Error)
|
||||
nativeCompile _version ctxVar cl ppe base path = tryM $ do
|
||||
nativeCompile executable ctxVar cl ppe base path = tryM $ do
|
||||
ctx <- readIORef ctxVar
|
||||
(tyrs, tmrs) <- collectRefDeps cl base
|
||||
(_, codes) <- loadDeps cl ppe ctx tyrs tmrs
|
||||
nativeCompileCodes codes base path
|
||||
(ctx, codes) <- loadDeps cl ppe ctx tyrs tmrs
|
||||
Just ibase <- pure $ baseToIntermed ctx base
|
||||
nativeCompileCodes executable codes ibase path
|
||||
|
||||
interpCompile ::
|
||||
Text ->
|
||||
@ -647,9 +787,9 @@ backReferenceTm ws frs irs dcm c i = do
|
||||
bs <- Map.lookup r dcm
|
||||
Map.lookup i bs
|
||||
|
||||
schemeProc :: [String] -> CreateProcess
|
||||
schemeProc args =
|
||||
(proc "native-compiler/bin/runner" args)
|
||||
ucrProc :: FilePath -> [String] -> CreateProcess
|
||||
ucrProc executable args =
|
||||
(proc executable args)
|
||||
{ std_in = CreatePipe,
|
||||
std_out = Inherit,
|
||||
std_err = Inherit
|
||||
@ -667,12 +807,14 @@ schemeProc args =
|
||||
-- taken over the input. This could probably be without a side
|
||||
-- channel, but a side channel is probably better.
|
||||
nativeEvalInContext ::
|
||||
FilePath ->
|
||||
PrettyPrintEnv ->
|
||||
EvalCtx ->
|
||||
[(Reference, SuperGroup Symbol)] ->
|
||||
Reference ->
|
||||
IO (Either Error ([Error], Term Symbol))
|
||||
nativeEvalInContext _ ctx codes base = do
|
||||
nativeEvalInContext executable _ ctx codes base = do
|
||||
ensureRuntimeExists executable
|
||||
let cc = ccache ctx
|
||||
crs <- readTVarIO $ combRefs cc
|
||||
let bytes = serializeValue . compileValue base $ codes
|
||||
@ -696,15 +838,24 @@ nativeEvalInContext _ ctx codes base = do
|
||||
-- decodeResult . deserializeValue =<< BS.hGetContents pout
|
||||
callout _ _ _ _ =
|
||||
pure . Left $ "withCreateProcess didn't provide handles"
|
||||
withCreateProcess (schemeProc []) callout
|
||||
p = ucrProc executable []
|
||||
ucrError (e :: IOException) = pure $ Left (runtimeErrMsg (cmdspec p) (Right e))
|
||||
withCreateProcess p callout
|
||||
`UnliftIO.catch` ucrError
|
||||
|
||||
nativeCompileCodes ::
|
||||
FilePath ->
|
||||
[(Reference, SuperGroup Symbol)] ->
|
||||
Reference ->
|
||||
FilePath ->
|
||||
IO ()
|
||||
nativeCompileCodes codes base path = do
|
||||
nativeCompileCodes executable codes base path = do
|
||||
ensureRuntimeExists executable
|
||||
ensureRacoExists
|
||||
genDir <- getXdgDirectory XdgCache "unisonlanguage/racket-tmp"
|
||||
createDirectoryIfMissing True genDir
|
||||
let bytes = serializeValue . compileValue base $ codes
|
||||
srcPath = genDir </> path <.> "rkt"
|
||||
callout (Just pin) _ _ ph = do
|
||||
BS.hPut pin . runPutS . putWord32be . fromIntegral $ BS.length bytes
|
||||
BS.hPut pin bytes
|
||||
@ -712,7 +863,17 @@ nativeCompileCodes codes base path = do
|
||||
waitForProcess ph
|
||||
pure ()
|
||||
callout _ _ _ _ = fail "withCreateProcess didn't provide handles"
|
||||
withCreateProcess (schemeProc ["-o", path]) callout
|
||||
ucrError (e :: IOException) =
|
||||
throwIO $ PE callStack (runtimeErrMsg (cmdspec p) (Right e))
|
||||
racoError (e :: IOException) =
|
||||
throwIO $ PE callStack (racoErrMsg (makeRacoCmd RawCommand) (Right e))
|
||||
p = ucrProc executable ["-G", srcPath]
|
||||
makeRacoCmd :: (FilePath -> [String] -> a) -> a
|
||||
makeRacoCmd f = f "raco" ["exe", "-o", path, srcPath]
|
||||
withCreateProcess p callout
|
||||
`UnliftIO.catch` ucrError
|
||||
makeRacoCmd callProcess
|
||||
`UnliftIO.catch` racoError
|
||||
|
||||
evalInContext ::
|
||||
PrettyPrintEnv ->
|
||||
@ -872,7 +1033,11 @@ icon = "💔💥"
|
||||
catchInternalErrors ::
|
||||
IO (Either Error a) ->
|
||||
IO (Either Error a)
|
||||
catchInternalErrors sub = sub `UnliftIO.catch` \(CE _ e) -> pure $ Left e
|
||||
catchInternalErrors sub = sub `UnliftIO.catch` hCE `UnliftIO.catch` hRE
|
||||
where
|
||||
hCE (CE _ e) = pure $ Left e
|
||||
hRE (PE _ e) = pure $ Left e
|
||||
hRE (BU _ _ _) = pure $ Left "impossible"
|
||||
|
||||
decodeStandalone ::
|
||||
BL.ByteString ->
|
||||
@ -917,14 +1082,14 @@ startRuntime sandboxed runtimeHost version = do
|
||||
ioTestTypes = builtinIOTestTypes External
|
||||
}
|
||||
|
||||
startNativeRuntime :: Text -> IO (Runtime Symbol)
|
||||
startNativeRuntime version = do
|
||||
startNativeRuntime :: Text -> FilePath -> IO (Runtime Symbol)
|
||||
startNativeRuntime _version executable = do
|
||||
ctxVar <- newIORef =<< baseContext False
|
||||
pure $
|
||||
Runtime
|
||||
{ terminate = pure (),
|
||||
evaluate = nativeEval ctxVar,
|
||||
compileTo = nativeCompile version ctxVar,
|
||||
evaluate = nativeEval executable ctxVar,
|
||||
compileTo = nativeCompile executable ctxVar,
|
||||
mainType = builtinMain External,
|
||||
ioTestTypes = builtinIOTestTypes External
|
||||
}
|
||||
@ -934,10 +1099,14 @@ withRuntime sandboxed runtimeHost version action =
|
||||
UnliftIO.bracket (liftIO $ startRuntime sandboxed runtimeHost version) (liftIO . terminate) action
|
||||
|
||||
tryM :: IO () -> IO (Maybe Error)
|
||||
tryM = fmap (either (Just . extract) (const Nothing)) . try
|
||||
tryM =
|
||||
flip UnliftIO.catch hRE
|
||||
. flip UnliftIO.catch hCE
|
||||
. fmap (const Nothing)
|
||||
where
|
||||
extract (PE _ e) = e
|
||||
extract (BU _ _ _) = "impossible"
|
||||
hCE (CE _ e) = pure $ Just e
|
||||
hRE (PE _ e) = pure $ Just e
|
||||
hRE (BU _ _ _) = pure $ Just "impossible"
|
||||
|
||||
runStandalone :: StoredCache -> Word64 -> IO (Either (Pretty ColorText) ())
|
||||
runStandalone sc init =
|
||||
|
||||
@ -1,88 +0,0 @@
|
||||
#!racket/base
|
||||
|
||||
(require
|
||||
(except-in racket false true unit any)
|
||||
compiler/embed
|
||||
unison/boot
|
||||
unison/data
|
||||
unison/data-info
|
||||
unison/chunked-seq
|
||||
unison/primops
|
||||
unison/primops-generated
|
||||
unison/builtin-generated)
|
||||
|
||||
(define (grab-bytes)
|
||||
(let* ([size-bytes (read-bytes 4)]
|
||||
[size (integer-bytes->integer size-bytes #f #t 0 4)])
|
||||
(read-bytes size)))
|
||||
|
||||
(define (decode-input)
|
||||
(let ([bs (grab-bytes)])
|
||||
(match (builtin-Value.deserialize (bytes->chunked-bytes bs))
|
||||
[(unison-data _ t (list q))
|
||||
(= t unison-either-right:tag)
|
||||
(apply
|
||||
values
|
||||
(unison-tuple->list (reify-value (unison-quote-val q))))]
|
||||
[else
|
||||
(raise "unexpected input")])))
|
||||
|
||||
(define (build-main-module main-def)
|
||||
`(module unison-main racket/base
|
||||
(require
|
||||
unison/boot)
|
||||
|
||||
(provide main)
|
||||
|
||||
(define (main)
|
||||
(handle ['ref-4n0fgs00] top-exn-handler
|
||||
(,(termlink->name main-def))))))
|
||||
|
||||
(define (do-evaluate)
|
||||
(let-values ([(code main-ref) (decode-input)])
|
||||
(add-runtime-code 'unison-main code)
|
||||
(handle ['ref-4n0fgs00] top-exn-handler
|
||||
((termlink->proc main-ref))
|
||||
(data 'unit 0))))
|
||||
|
||||
; stub implementation
|
||||
(define (do-compile output) (void))
|
||||
; (let-values ([(code main-ref) (decode-input)])
|
||||
; (create-embedding-executable
|
||||
; output
|
||||
; #:modules '((#f unison-main))
|
||||
; #:literal-expression '(begin (require unison-main) (main)))))
|
||||
|
||||
(define runtime-namespace
|
||||
(let ([ns (variable-reference->namespace (#%variable-reference))])
|
||||
(namespace-require ''#%kernel ns)
|
||||
ns))
|
||||
|
||||
(define (chunked-list->list cl)
|
||||
(vector->list (chunked-list->vector cl)))
|
||||
|
||||
(define (list->chunked-list l)
|
||||
(vector->chunked-list (list->vector l)))
|
||||
|
||||
(define (join ls)
|
||||
(cond
|
||||
[(null? ls) '()]
|
||||
[else (append (car ls) (join (cdr ls)))]))
|
||||
|
||||
(define compile (make-parameter #f))
|
||||
|
||||
(define (handle-command-line)
|
||||
(command-line
|
||||
#:program "runner"
|
||||
#:once-any
|
||||
[("-o" "--output")
|
||||
file
|
||||
"compile to <file>"
|
||||
(compile file)]
|
||||
#:args ()
|
||||
(compile)))
|
||||
|
||||
(let ([out (handle-command-line)])
|
||||
(if out
|
||||
(do-compile out)
|
||||
(do-evaluate)))
|
||||
115
scheme-libs/racket/unison-runtime.rkt
Normal file
115
scheme-libs/racket/unison-runtime.rkt
Normal file
@ -0,0 +1,115 @@
|
||||
#lang racket/base
|
||||
|
||||
; This implements a standalone unison runtime, with options for
|
||||
; generating compilable racket modules.
|
||||
;
|
||||
; For runtime, it relies on the support for unison dynamic code
|
||||
; loading. It expects to be provided with a serialized list of term
|
||||
; links and associated code. It then loads the code in the same manner
|
||||
; as dynamic runtime execution, and evaluates a main definition.
|
||||
;
|
||||
; Since this is intended to be an implementation of evaluation for
|
||||
; e.g. ucm, the input is expected to be complete. No protocol is
|
||||
; implemented for negotiating with a host for additional needed
|
||||
; definitions. The program has all the built in definitions, and
|
||||
; everything else is expected to be provided in the initial input.
|
||||
;
|
||||
; In addition to this mode, it is possible to supply a command line
|
||||
; argument `-G` with a file name. This will instead produce a racket
|
||||
; file with the supplied definitions. This file should be suitable for
|
||||
; compilation and distribution with the `raco` tool, so long as the
|
||||
; supporting unison-on-racket libraries are known to the racket
|
||||
; install.
|
||||
|
||||
(require
|
||||
racket/pretty
|
||||
(except-in racket false true unit any)
|
||||
compiler/embed
|
||||
unison/boot
|
||||
unison/data
|
||||
unison/data-info
|
||||
unison/chunked-seq
|
||||
unison/primops
|
||||
unison/primops-generated
|
||||
unison/builtin-generated)
|
||||
|
||||
; Gets bytes using the expected input format. The format is simple:
|
||||
;
|
||||
; - 4 bytes indicating how many bytes follow
|
||||
; - the actual payload, with size matching the above
|
||||
(define (grab-bytes)
|
||||
(let* ([size-bytes (read-bytes 4)]
|
||||
[size (integer-bytes->integer size-bytes #f #t 0 4)])
|
||||
(read-bytes size)))
|
||||
|
||||
; Reads and decodes the input. First uses `grab-bytes` to read the
|
||||
; payload, then uses unison functions to deserialize the `Value` that
|
||||
; is expected.
|
||||
;
|
||||
; The `Value` is expected to be a pair of loadable code and which
|
||||
; definition should be executed. In unison types, it is:
|
||||
;
|
||||
; ([(Link.Term, Code)], Link.Term)
|
||||
(define (decode-input)
|
||||
(let ([bs (grab-bytes)])
|
||||
(match (builtin-Value.deserialize (bytes->chunked-bytes bs))
|
||||
[(unison-data _ t (list q))
|
||||
(= t unison-either-right:tag)
|
||||
(apply
|
||||
values
|
||||
(unison-tuple->list (reify-value (unison-quote-val q))))]
|
||||
[else
|
||||
(raise "unexpected input")])))
|
||||
|
||||
; Implements the evaluation mode of operation. First decodes the
|
||||
; input. Then uses the dynamic loading machinery to add the code to
|
||||
; the runtime. Finally executes a specified main reference.
|
||||
(define (do-evaluate)
|
||||
(let-values ([(code main-ref) (decode-input)])
|
||||
(add-runtime-code 'unison-main code)
|
||||
(handle ['ref-4n0fgs00] top-exn-handler
|
||||
((termlink->proc main-ref))
|
||||
(data 'unit 0))))
|
||||
|
||||
; 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)
|
||||
(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)])
|
||||
(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-values (icode main-ref) (decode-input))
|
||||
(write-module srcf main-ref icode))
|
||||
|
||||
(define generate-to (make-parameter #f))
|
||||
(define show-version (make-parameter #f))
|
||||
|
||||
(define (handle-command-line)
|
||||
(command-line
|
||||
#:program "unison-runtime"
|
||||
#:once-any
|
||||
["--version"
|
||||
"display version"
|
||||
(show-version #t)]
|
||||
[("-G" "--generate-file")
|
||||
file
|
||||
"generate code to <file>"
|
||||
(generate-to file)]))
|
||||
|
||||
(begin
|
||||
(handle-command-line)
|
||||
(cond
|
||||
[(show-version) (displayln "unison-runtime version 0.0.11")]
|
||||
[(generate-to) (do-generate (generate-to))]
|
||||
[else (do-evaluate)]))
|
||||
@ -21,23 +21,22 @@
|
||||
Int.signum
|
||||
)))
|
||||
|
||||
(require racket)
|
||||
(require racket/fixnum)
|
||||
(require racket/flonum)
|
||||
(require racket/performance-hint)
|
||||
(require unison/boot)
|
||||
(require racket
|
||||
racket/fixnum
|
||||
racket/flonum
|
||||
racket/performance-hint
|
||||
unison/boot)
|
||||
|
||||
(begin-encourage-inline
|
||||
(define-unison (Nat.+ m n) (+ m n))
|
||||
(define-unison (Nat.+ m n) (clamp-natural (+ m n)))
|
||||
(define-unison (Nat.drop m n) (max 0 (- m n)))
|
||||
|
||||
|
||||
(define-unison (Nat.increment n) (add1 n))
|
||||
(define-unison (Int.increment i) (add1 i))
|
||||
(define-unison (Int.negate i) (- i))
|
||||
(define-unison (Int.+ i j) (+ i j))
|
||||
(define-unison (Int.- i j) (- i j))
|
||||
(define-unison (Int./ i j) (quotient i j))
|
||||
(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))
|
||||
|
||||
|
||||
@ -20,6 +20,13 @@
|
||||
data
|
||||
data-case
|
||||
|
||||
clamp-integer
|
||||
clamp-natural
|
||||
wrap-natural
|
||||
bit64
|
||||
bit63
|
||||
nbit63
|
||||
|
||||
expand-sandbox
|
||||
check-sandbox
|
||||
set-sandbox
|
||||
@ -72,6 +79,7 @@
|
||||
; (for (only (racket base) quasisyntax/loc) expand)
|
||||
; (for-syntax (only-in unison/core syntax->list))
|
||||
(only-in racket/control prompt0-at control0-at)
|
||||
racket/performance-hint
|
||||
unison/core
|
||||
unison/data
|
||||
unison/sandbox
|
||||
@ -591,3 +599,31 @@
|
||||
(control 'ref-4n0fgs00 k
|
||||
(let ([disp (describe-value f)])
|
||||
(raise (make-exn:bug "builtin.bug" disp))))]]))
|
||||
|
||||
(begin-encourage-inline
|
||||
(define mask64 #xffffffffffffffff)
|
||||
(define mask63 #x7fffffffffffffff)
|
||||
(define bit63 #x8000000000000000)
|
||||
(define bit64 #x10000000000000000)
|
||||
(define nbit63 (- #x8000000000000000))
|
||||
|
||||
; Operation to maintain Int values to within a range from
|
||||
; -2^63 to 2^63-1.
|
||||
(define (clamp-integer i)
|
||||
(if (fixnum? i) i
|
||||
(let ([j (bitwise-and mask64 i)])
|
||||
(if (< j bit63) j
|
||||
(- j bit64)))))
|
||||
|
||||
; modular arithmetic appropriate for when a Nat operation can only
|
||||
; overflow (be too large a positive number).
|
||||
(define (clamp-natural n)
|
||||
(if (fixnum? n) n
|
||||
(modulo n bit64)))
|
||||
|
||||
; module arithmetic appropriate for when a Nat operation my either
|
||||
; have too large or a negative result.
|
||||
(define (wrap-natural n)
|
||||
(if (and (fixnum? n) (exact-nonnegative-integer? n)) n
|
||||
(modulo n bit64))))
|
||||
|
||||
|
||||
@ -504,7 +504,7 @@
|
||||
new-len
|
||||
(λ (chunk)
|
||||
(chunk-copy! chunk 0 first-c 1)
|
||||
(chunk-copy! chunk first-len last-c 0)))))]
|
||||
(chunk-copy! chunk (sub1 first-len) last-c 0)))))]
|
||||
[(= first-len 1)
|
||||
(define-values [vt* first-c*] (vector-trie-pop-first vt))
|
||||
(struct-copy
|
||||
@ -516,7 +516,7 @@
|
||||
(struct-copy
|
||||
chunks cs
|
||||
[length (sub1 len)]
|
||||
[first-chunk (chunk-drop-first last-c)])])
|
||||
[first-chunk (chunk-drop-first first-c)])])
|
||||
(chunk-first first-c))]))
|
||||
|
||||
(define (chunked-seq-pop-last cs)
|
||||
@ -573,13 +573,13 @@
|
||||
[{(single-chunk chunk-a) (single-chunk chunk-b)}
|
||||
(define len (+ (chunk-length chunk-a) (chunk-length chunk-b)))
|
||||
;; see Note [chunks-length invariant]
|
||||
(if (< len CHUNK-CAPACITY)
|
||||
(if (<= len CHUNK-CAPACITY)
|
||||
(single-chunk (chunk-append chunk-a chunk-b))
|
||||
(chunks len chunk-a empty-vector-trie chunk-b))]
|
||||
|
||||
[{(single-chunk chunk) (chunks len first-c vt _)}
|
||||
(cond
|
||||
[(< (+ (chunk-length chunk) (chunk-length first-c)) CHUNK-CAPACITY)
|
||||
[(<= (+ (chunk-length chunk) (chunk-length first-c)) CHUNK-CAPACITY)
|
||||
(struct-copy
|
||||
chunks cs-b
|
||||
[length (+ (chunk-length chunk) len)]
|
||||
@ -594,7 +594,7 @@
|
||||
|
||||
[{(chunks len _ vt last-c) (single-chunk chunk)}
|
||||
(cond
|
||||
[(< (+ (chunk-length last-c) (chunk-length chunk)) CHUNK-CAPACITY)
|
||||
[(<= (+ (chunk-length last-c) (chunk-length chunk)) CHUNK-CAPACITY)
|
||||
(struct-copy
|
||||
chunks cs-a
|
||||
[length (+ len (chunk-length chunk))]
|
||||
@ -688,9 +688,10 @@
|
||||
;; If `first-a` contains too many elements to fit in the next
|
||||
;; partially-constructed chunk, we need to split it as well.
|
||||
[(> first-a-len insert-i)
|
||||
(chunk-copy! new-chunk 0 first-a split-i)
|
||||
(define copy-len (- first-a-len insert-i))
|
||||
(chunk-copy! new-chunk 0 first-a copy-len)
|
||||
(transfer-chunk! #:done? #t)
|
||||
(chunk-slice first-a 0 split-i)]
|
||||
(chunk-slice first-a 0 copy-len)]
|
||||
|
||||
;; Otherwise, we can move the elements from the partially-
|
||||
;; constructed chunk into the new first chunk.
|
||||
|
||||
@ -18,6 +18,7 @@
|
||||
(import (rnrs)
|
||||
(rnrs records syntactic)
|
||||
(unison data)
|
||||
(unison data-info)
|
||||
(unison core)
|
||||
(unison chunked-seq)
|
||||
(rename
|
||||
@ -110,7 +111,9 @@
|
||||
(with-handlers
|
||||
([exn:break?
|
||||
(lambda (e) (exception "ThreadKilledFailure" (string->chunked-string "thread killed") ()))]
|
||||
[exn:io? (lambda (e) (exception "IOFailure" (exception->string e) ()))]
|
||||
[exn:io?
|
||||
(lambda (e)
|
||||
(exception unison-iofailure:link (exception->string e) ()))]
|
||||
[exn:arith? (lambda (e) (exception "ArithmeticFailure" (exception->string e) ()))]
|
||||
[exn:bug? (lambda (e) (exn:bug->exception e))]
|
||||
[exn:fail? (lambda (e) (exception "RuntimeFailure" (exception->string e) ()))]
|
||||
|
||||
@ -270,6 +270,8 @@
|
||||
(cond
|
||||
[(equal? l r) '=]
|
||||
[(and (number? l) (number? r)) (if (< l r) '< '>)]
|
||||
[(and (char? l) (char? r)) (if (char<? l r) '< '>)]
|
||||
[(and (boolean? l) (boolean? r)) (if r '< '>)]
|
||||
[(and (chunked-list? l) (chunked-list? r)) (chunked-list-compare/recur l r universal-compare)]
|
||||
[(and (chunked-string? l) (chunked-string? r))
|
||||
(chunked-string-compare/recur l r (lambda (a b) (if (char<? a b) '< '>)))]
|
||||
|
||||
12
scheme-libs/racket/unison/info.rkt
Normal file
12
scheme-libs/racket/unison/info.rkt
Normal file
@ -0,0 +1,12 @@
|
||||
#lang info
|
||||
|
||||
(define collection "unison")
|
||||
|
||||
(define deps
|
||||
(list
|
||||
"x509-lib"
|
||||
"r6rs-lib"
|
||||
"rackunit-lib"
|
||||
"math-lib"
|
||||
"srfi-lib"
|
||||
))
|
||||
@ -44,12 +44,16 @@
|
||||
|
||||
(define (getFileSize.impl.v3 path)
|
||||
(with-handlers
|
||||
[[exn:fail:filesystem? (lambda (e) (exception "IOFailure" (exception->string e) '()))]]
|
||||
[[exn:fail:filesystem?
|
||||
(lambda (e)
|
||||
(exception unison-iofailure:link (exception->string e) '()))]]
|
||||
(right (file-size (chunked-string->string path)))))
|
||||
|
||||
(define (getFileTimestamp.impl.v3 path)
|
||||
(with-handlers
|
||||
[[exn:fail:filesystem? (lambda (e) (exception "IOFailure" (exception->string e) '()))]]
|
||||
[[exn:fail:filesystem?
|
||||
(lambda (e)
|
||||
(exception unison-iofailure:link (exception->string e) '()))]]
|
||||
(right (file-or-directory-modify-seconds (chunked-string->string path)))))
|
||||
|
||||
; in haskell, it's not just file but also directory
|
||||
|
||||
@ -1,8 +1,14 @@
|
||||
#lang racket/base
|
||||
|
||||
(require math/base
|
||||
rnrs/arithmetic/fixnums-6
|
||||
(only-in unison/boot data-case define-unison))
|
||||
racket/performance-hint
|
||||
rnrs/arithmetic/bitwise-6
|
||||
(only-in unison/boot
|
||||
clamp-integer
|
||||
clamp-natural
|
||||
data-case
|
||||
define-unison
|
||||
nbit63))
|
||||
|
||||
(provide
|
||||
builtin-Float.exp
|
||||
@ -73,8 +79,8 @@
|
||||
(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) (* n m))
|
||||
(define-unison (builtin-Int.pow n m) (expt n m))
|
||||
(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))
|
||||
@ -85,19 +91,19 @@
|
||||
(define ACOS acos)
|
||||
(define ACSH acosh)
|
||||
(define ADDF +)
|
||||
(define ADDI +)
|
||||
(define (ADDI i j) (clamp-integer (+ i j)))
|
||||
(define SUBF -)
|
||||
(define SUBI -)
|
||||
(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 *)
|
||||
(define NEGI -)
|
||||
(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 expt)
|
||||
(define POWN 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)
|
||||
@ -106,7 +112,10 @@
|
||||
(define CEIL ceiling)
|
||||
(define FLOR floor)
|
||||
(define COSF cos)
|
||||
(define TRNF truncate)
|
||||
(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)
|
||||
@ -115,19 +124,17 @@
|
||||
(define SINH sinh)
|
||||
(define COSH cosh)
|
||||
(define DIVF /)
|
||||
(define DIVI /)
|
||||
(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)
|
||||
(if (< n 0)
|
||||
(+ 65 (fxbit-count n))
|
||||
(fxbit-count n)))
|
||||
(modulo (bitwise-bit-count n) 65))
|
||||
|
||||
(define (TZRO n)
|
||||
(let ([bit (fxfirst-bit-set n)])
|
||||
(let ([bit (bitwise-first-bit-set n)])
|
||||
(if (eq? -1 bit)
|
||||
64
|
||||
bit)))
|
||||
|
||||
@ -41,6 +41,7 @@
|
||||
[replicate (-> pattern? exact-nonnegative-integer? exact-nonnegative-integer? pattern?)]
|
||||
;; Only valid pattern? in the functions below is p:char
|
||||
[char-class-and (-> pattern? pattern? pattern?)]
|
||||
[char-class-or (-> pattern? pattern? pattern?)]
|
||||
[char-class-not (-> pattern? pattern?)]))
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
@ -269,7 +270,7 @@
|
||||
(define-values [cstr* captures*]
|
||||
(for/fold ([cstr cstr]
|
||||
[captures captures]
|
||||
#:result (ok cstr captures))
|
||||
#:result (values cstr captures))
|
||||
([i (in-range min-count)])
|
||||
#:break (not cstr)
|
||||
(pat-m cstr captures)))
|
||||
@ -285,12 +286,11 @@
|
||||
;; -----------------------------------------------------------------------------
|
||||
|
||||
(define (char-class-and cc1 cc2)
|
||||
(make-pattern
|
||||
(p:char
|
||||
(λ (c) (match (cons (pattern-pat cc1) (pattern-pat cc2))
|
||||
[(cons (p:char 'any) (p:char p)) (p c)]
|
||||
[(cons (p:char p) (p:char 'any)) (p c)]
|
||||
[(cons (p:char p1) (p:char p2)) (and (p1 c) (p2 c))])))))
|
||||
(match* ((pattern-pat cc1) (pattern-pat cc2))
|
||||
[((p:char 'any) _) cc2]
|
||||
[(_ (p:char 'any)) cc1]
|
||||
[((p:char p) (p:char q))
|
||||
(make-pattern (p:char (λ (c) (and (p c) (q c)))))]))
|
||||
|
||||
(define (char-class-not cc)
|
||||
(make-pattern
|
||||
@ -298,3 +298,10 @@
|
||||
(λ (c) (match (pattern-pat cc)
|
||||
[(p:char 'any) #f]
|
||||
[(p:char p) (not (p c))])))))
|
||||
|
||||
(define (char-class-or cc1 cc2)
|
||||
(match* ((pattern-pat cc1) (pattern-pat cc2))
|
||||
[((p:char 'any) _) cc1]
|
||||
[(_ (p:char 'any)) cc2]
|
||||
[((p:char p) (p:char q))
|
||||
(make-pattern (p:char (λ (c) (or (p c) (q c)))))]))
|
||||
|
||||
@ -49,6 +49,7 @@
|
||||
termlink->name
|
||||
|
||||
add-runtime-code
|
||||
build-intermediate-module
|
||||
build-runtime-module
|
||||
termlink->proc)
|
||||
|
||||
@ -558,6 +559,32 @@
|
||||
(parameterize ([current-namespace runtime-namespace])
|
||||
(dynamic-require `(quote ,mname) sym)))]))
|
||||
|
||||
; Straight-line module builder given intermediate definitions.
|
||||
; 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 (gen-typelinks 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)
|
||||
|
||||
,@tylinks
|
||||
|
||||
,@sdefs
|
||||
|
||||
(handle ['ref-4n0fgs00] top-exn-handler
|
||||
(,pname #f)))))
|
||||
|
||||
(define (build-runtime-module mname tylinks tmlinks defs)
|
||||
(let ([names (map termlink->name tmlinks)])
|
||||
`(module ,mname racket/base
|
||||
|
||||
@ -139,6 +139,9 @@
|
||||
builtin-IO.randomBytes
|
||||
builtin-IO.randomBytes:termlink
|
||||
|
||||
builtin-Scope.bytearrayOf
|
||||
builtin-Scope.bytearrayOf:termlink
|
||||
|
||||
builtin-Universal.==
|
||||
builtin-Universal.==:termlink
|
||||
builtin-Universal.>
|
||||
@ -573,25 +576,41 @@
|
||||
(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!)
|
||||
bytes-copy!
|
||||
sub1
|
||||
add1)
|
||||
(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)
|
||||
termlink->referent
|
||||
clamp-integer
|
||||
clamp-natural
|
||||
wrap-natural
|
||||
bit64
|
||||
bit63
|
||||
nbit63)
|
||||
(unison data)
|
||||
(unison data-info)
|
||||
(unison math)
|
||||
@ -713,6 +732,7 @@
|
||||
(define-builtin-link Pattern.captureAs)
|
||||
(define-builtin-link Pattern.isMatch)
|
||||
(define-builtin-link Char.Class.is)
|
||||
(define-builtin-link Scope.bytearrayOf)
|
||||
|
||||
(begin-encourage-inline
|
||||
(define-unison (builtin-Value.toBuiltin v) (unison-quote v))
|
||||
@ -788,6 +808,9 @@
|
||||
(case (universal-compare x y)
|
||||
[(>) 1] [(<) -1] [else 0]))
|
||||
|
||||
(define-unison (builtin-Scope.bytearrayOf i n)
|
||||
(make-bytevector n i))
|
||||
|
||||
(define (hash-string hs)
|
||||
(string-append "#" (bytevector->base32-string b32h hs)))
|
||||
|
||||
@ -834,11 +857,11 @@
|
||||
(chunked-bytes-length bs)
|
||||
(lambda (i) (chunked-bytes-ref bs i))))
|
||||
|
||||
(define unison-POp-ADDI +)
|
||||
(define unison-POp-MULI *)
|
||||
(define unison-POp-MODI mod)
|
||||
(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 expt)
|
||||
(define (unison-POp-POWN m n) (clamp-natural (expt m n)))
|
||||
(define unison-POp-LOGF log)
|
||||
|
||||
(define (reify-exn thunk)
|
||||
@ -848,7 +871,7 @@
|
||||
(thunk)))
|
||||
|
||||
; Core implemented primops, upon which primops-in-unison can be built.
|
||||
(define (unison-POp-ADDN m n) (fx+ m n))
|
||||
(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
|
||||
@ -857,17 +880,17 @@
|
||||
(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) (fxnot n))
|
||||
(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) (fx1- n))
|
||||
(define (unison-POp-INCI n) (fx+ n 1))
|
||||
(define (unison-POp-DECN n) (- n 1))
|
||||
(define (unison-POp-INCN n) (+ n 1))
|
||||
(define (unison-POp-DIVN m n) (fxdiv m n))
|
||||
(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 (fx=? m 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-string<? s t)))
|
||||
(define (unison-POp-EQLU x y) (bool (universal=? x y)))
|
||||
@ -877,20 +900,27 @@
|
||||
(put-string p ": ")
|
||||
(display (describe-value x) p)
|
||||
(raise (make-exn:bug fnm x))))
|
||||
(define (unison-POp-FTOT f) (string->chunked-string (number->string f)))
|
||||
(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) (fxior m 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 (fxlength m)))
|
||||
(define (unison-POp-MULN m n) (* m n))
|
||||
(define (unison-POp-MODN m n) (fxmod 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
|
||||
@ -900,16 +930,18 @@
|
||||
(build-chunked-string
|
||||
(chunked-list-length l)
|
||||
(lambda (i) (chunked-list-ref l i))))
|
||||
(define (unison-POp-SHLI i k) (fxarithmetic-shift-left i k))
|
||||
(define (unison-POp-SHLN n k) (fxarithmetic-shift-left n k))
|
||||
(define (unison-POp-SHRI i k) (fxarithmetic-shift-right i k))
|
||||
(define (unison-POp-SHRN n k) (fxarithmetic-shift-right n k))
|
||||
(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) (fx- m n))
|
||||
(define (unison-POp-SUBI m n) (- m n))
|
||||
(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))
|
||||
@ -946,10 +978,14 @@
|
||||
(newline))
|
||||
(define (unison-POp-TTON s)
|
||||
(let ([mn (string->number (chunked-string->string s))])
|
||||
(if (and (fixnum? mn) (>= mn 0)) (some mn) none)))
|
||||
(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 (fixnum? mn) (some mn) none)))
|
||||
(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)))
|
||||
@ -994,7 +1030,7 @@
|
||||
;; 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) (fxxor m n))
|
||||
(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)
|
||||
@ -1063,7 +1099,14 @@
|
||||
(define (unison-FOp-Text.fromUtf8.impl.v3 b)
|
||||
(with-handlers
|
||||
([exn:fail:contract? ; TODO proper typeLink
|
||||
(lambda (e) (exception "MiscFailure" (exception->string e) ()))])
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-iofailure:link
|
||||
(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?
|
||||
@ -1145,7 +1188,7 @@
|
||||
(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) (unison-FOp-Pattern.or p1 p2))
|
||||
(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))
|
||||
@ -1394,5 +1437,6 @@
|
||||
(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)
|
||||
)
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
racket/match
|
||||
racket/tcp
|
||||
unison/data
|
||||
unison/data-info
|
||||
unison/chunked-seq
|
||||
unison/core)
|
||||
|
||||
@ -26,7 +27,9 @@
|
||||
|
||||
(define (handle-errors fn)
|
||||
(with-handlers
|
||||
[[exn:fail:network? (lambda (e) (exception "IOFailure" (exception->string e) '()))]
|
||||
[[exn:fail:network?
|
||||
(lambda (e)
|
||||
(exception unison-iofailure:link (exception->string e) '()))]
|
||||
[exn:fail:contract? (lambda (e) (exception "InvalidArguments" (exception->string e) '()))]
|
||||
[(lambda _ #t) (lambda (e) (exception "MiscFailure" (chunked-string->string (format "Unknown exception ~a" (exn->string e))) e))] ]
|
||||
(fn)))
|
||||
@ -82,7 +85,9 @@
|
||||
(chunked-string->string port))])])
|
||||
|
||||
(with-handlers
|
||||
[[exn:fail:network? (lambda (e) (exception "IOFailure" (exception->string e) '()))]
|
||||
[[exn:fail:network?
|
||||
(lambda (e)
|
||||
(exception unison-iofailure:link (exception->string e) '()))]
|
||||
[exn:fail:contract? (lambda (e) (exception "InvalidArguments" (exception->string e) '()))]
|
||||
[(lambda _ #t) (lambda (e) (exception "MiscFailure" (string->chunked-string "Unknown exception") e))] ]
|
||||
(let ([listener (tcp-listen (string->number port ) 4 #f (if (equal? 0 hostname) #f hostname))])
|
||||
|
||||
@ -6,6 +6,7 @@
|
||||
(only-in racket empty?)
|
||||
compatibility/mlist
|
||||
unison/data
|
||||
unison/data-info
|
||||
unison/chunked-seq
|
||||
unison/core
|
||||
unison/tcp
|
||||
@ -111,15 +112,25 @@
|
||||
|
||||
(define (handle-errors fn)
|
||||
(with-handlers
|
||||
[[exn:fail:network? (lambda (e) (exception "IOFailure" (exception->string e) '()))]
|
||||
[[exn:fail:network?
|
||||
(lambda (e)
|
||||
(exception unison-iofailure:link (exception->string e) '()))]
|
||||
[exn:fail:contract?
|
||||
(lambda (e) (exception "InvalidArguments" (exception->string e) '()))]
|
||||
[(lambda err
|
||||
(string-contains? (exn->string err) "not valid for hostname"))
|
||||
(lambda (e) (exception "IOFailure" (string->chunked-string "NameMismatch") '()))]
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-iofailure:link
|
||||
(string->chunked-string "NameMismatch")
|
||||
'()))]
|
||||
[(lambda err
|
||||
(string-contains? (exn->string err) "certificate verify failed"))
|
||||
(lambda (e) (exception "IOFailure" (string->chunked-string "certificate verify failed") '()))]
|
||||
(lambda (e)
|
||||
(exception
|
||||
unison-iofailure:link
|
||||
(string->chunked-string "certificate verify failed")
|
||||
'()))]
|
||||
[(lambda _ #t) (lambda (e) (exception "MiscFailure" (string->chunked-string (format "Unknown exception ~a" (exn->string e))) e))]]
|
||||
(fn)))
|
||||
|
||||
|
||||
@ -719,7 +719,7 @@
|
||||
(next-leaf!)
|
||||
(vector-copy! new-leaf leaf-split-i leaf 0 leaf-split-i))]
|
||||
[else
|
||||
(vector-copy! new-leaf leaf-i leaf first-leaf-start leaf-split-i)])))]
|
||||
(vector-copy! new-leaf leaf-i leaf first-leaf-start leaf-insert-i)])))]
|
||||
[else
|
||||
(make-node
|
||||
(λ (new-node)
|
||||
|
||||
@ -1,15 +1,11 @@
|
||||
{-# HLINT ignore "Use tuple-section" #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
module Unison.Codebase.Editor.HandleInput
|
||||
( loop,
|
||||
)
|
||||
where
|
||||
module Unison.Codebase.Editor.HandleInput (loop) where
|
||||
|
||||
-- TODO: Don't import backend
|
||||
|
||||
import Control.Error.Util qualified as ErrorUtil
|
||||
import Control.Exception (catch)
|
||||
import Control.Lens hiding (from)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.State (StateT)
|
||||
@ -20,7 +16,6 @@ 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.Sequence qualified as Seq
|
||||
import Data.Set qualified as Set
|
||||
import Data.Set.NonEmpty (NESet)
|
||||
import Data.Set.NonEmpty qualified as NESet
|
||||
@ -28,10 +23,6 @@ import Data.Text qualified as Text
|
||||
import Data.These (These (..))
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Tuple.Extra (uncurry3)
|
||||
import System.Directory (XdgDirectory (..), createDirectoryIfMissing, doesFileExist, getXdgDirectory)
|
||||
import System.Exit (ExitCode (..))
|
||||
import System.FilePath ((</>))
|
||||
import System.Process (callProcess, readCreateProcessWithExitCode, shell)
|
||||
import Text.Megaparsec qualified as Megaparsec
|
||||
import U.Codebase.Branch.Diff qualified as V2Branch.Diff
|
||||
import U.Codebase.Causal qualified as V2Causal
|
||||
@ -50,7 +41,6 @@ import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.NamesUtils qualified as Cli
|
||||
import Unison.Cli.PrettyPrintUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.TypeCheck (typecheckTerm)
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch (..), Branch0 (..))
|
||||
@ -92,7 +82,7 @@ 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.TermResolution (resolveCon, resolveMainRef, resolveTermRef)
|
||||
import Unison.Codebase.Editor.HandleInput.TermResolution (resolveMainRef)
|
||||
import Unison.Codebase.Editor.HandleInput.Tests qualified as Tests
|
||||
import Unison.Codebase.Editor.HandleInput.UI (openUI)
|
||||
import Unison.Codebase.Editor.HandleInput.Update (doSlurpAdds, handleUpdate)
|
||||
@ -103,7 +93,6 @@ 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
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..))
|
||||
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||
import Unison.Codebase.Editor.Slurp qualified as Slurp
|
||||
import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult
|
||||
@ -119,13 +108,11 @@ import Unison.Codebase.Path.Parse qualified as Path
|
||||
import Unison.Codebase.Runtime qualified as Runtime
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
|
||||
import Unison.Codebase.SyncMode qualified as SyncMode
|
||||
import Unison.Codebase.TermEdit (TermEdit (..))
|
||||
import Unison.Codebase.TermEdit qualified as TermEdit
|
||||
import Unison.Codebase.TermEdit.Typing qualified as TermEdit
|
||||
import Unison.Codebase.TypeEdit (TypeEdit)
|
||||
import Unison.Codebase.TypeEdit qualified as TypeEdit
|
||||
import Unison.Codebase.Verbosity qualified as Verbosity
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
|
||||
import Unison.CommandLine.Completion qualified as Completion
|
||||
import Unison.CommandLine.DisplayValues qualified as DisplayValues
|
||||
@ -138,7 +125,6 @@ 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.JitInfo qualified as JitInfo
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
import Unison.LabeledDependency qualified as LD
|
||||
import Unison.LabeledDependency qualified as LabeledDependency
|
||||
@ -158,13 +144,12 @@ 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 (..), ProjectBranchNameOrLatestRelease (..))
|
||||
import Unison.Project (ProjectAndBranch (..))
|
||||
import Unison.Project.Util (projectContextFromPath)
|
||||
import Unison.Reference (Reference, TermReference)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Result qualified as Result
|
||||
import Unison.Runtime.IOSource qualified as IOSource
|
||||
import Unison.Server.Backend (ShallowListEntry (..))
|
||||
import Unison.Server.Backend qualified as Backend
|
||||
@ -179,19 +164,17 @@ 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 (parseText, parseTextWith, toText, unsafeParseText)
|
||||
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.Name qualified as Name (toText, toVar, unsafeParseVar)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
|
||||
import Unison.Syntax.Parser qualified as Parser
|
||||
import Unison.Syntax.TermPrinter qualified as TP
|
||||
import Unison.Term (Term)
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Type (Type)
|
||||
import Unison.Type qualified as Type
|
||||
import Unison.Type.Names qualified as Type
|
||||
import Unison.Typechecker qualified as Typechecker
|
||||
import Unison.UnisonFile (TypecheckedUnisonFile)
|
||||
import Unison.UnisonFile qualified as UF
|
||||
import Unison.UnisonFile.Names qualified as UF
|
||||
@ -209,7 +192,6 @@ import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
import Unison.WatchKind qualified as WK
|
||||
import UnliftIO.Directory qualified as Directory
|
||||
import Witch (unsafeFrom)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Main loop
|
||||
@ -976,12 +958,9 @@ loop e = do
|
||||
when (not updated) (Cli.respond $ NothingToPatch patchPath scopePath')
|
||||
ExecuteI main args -> handleRun False main args
|
||||
MakeStandaloneI output main -> doCompile False output main
|
||||
CompileSchemeI output main -> doCompileScheme output main
|
||||
ExecuteSchemeI main args -> doRunAsScheme main args
|
||||
GenSchemeLibsI mdir ->
|
||||
doGenerateSchemeBoot True Nothing mdir
|
||||
FetchSchemeCompilerI name branch ->
|
||||
doFetchCompiler name branch
|
||||
CompileSchemeI output main ->
|
||||
doCompile True (Text.unpack output) main
|
||||
ExecuteSchemeI main args -> handleRun True main args
|
||||
IOTestI main -> Tests.handleIOTest main
|
||||
IOTestAllI -> Tests.handleAllIOTests
|
||||
-- UpdateBuiltinsI -> do
|
||||
@ -1332,11 +1311,6 @@ inputDescription input =
|
||||
ExecuteSchemeI nm args ->
|
||||
pure $ "run.native " <> Text.unwords (nm : fmap Text.pack args)
|
||||
CompileSchemeI fi nm -> pure ("compile.native " <> HQ.toText nm <> " " <> fi)
|
||||
GenSchemeLibsI mdir ->
|
||||
pure $
|
||||
"compile.native.genlibs" <> Text.pack (maybe "" (" " ++) mdir)
|
||||
FetchSchemeCompilerI name branch ->
|
||||
pure ("compile.native.fetch" <> Text.pack name <> " " <> Text.pack branch)
|
||||
CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name)
|
||||
RemoveTermReplacementI src p0 -> do
|
||||
p <- opatch p0
|
||||
@ -1918,167 +1892,6 @@ searchBranchScored names0 score queries =
|
||||
pair qn =
|
||||
(\score -> (Just score, result)) <$> score qn (Name.toText name)
|
||||
|
||||
compilerPath :: Path.Path'
|
||||
compilerPath = Path.Path' {Path.unPath' = Left abs}
|
||||
where
|
||||
segs = ["unison", "internal"]
|
||||
rootPath = Path.Path {Path.toSeq = Seq.fromList segs}
|
||||
abs = Path.Absolute {Path.unabsolute = rootPath}
|
||||
|
||||
doFetchCompiler :: String -> String -> Cli ()
|
||||
doFetchCompiler username branch =
|
||||
doPullRemoteBranch sourceTarget SyncMode.Complete Input.PullWithoutHistory Verbosity.Silent
|
||||
where
|
||||
-- fetching info
|
||||
prj =
|
||||
These
|
||||
(unsafeFrom @Text $ "@" <> Text.pack username <> "/internal")
|
||||
(ProjectBranchNameOrLatestRelease'Name . unsafeFrom @Text $ Text.pack branch)
|
||||
|
||||
sourceTarget =
|
||||
PullSourceTarget2
|
||||
(ReadShare'ProjectBranch prj)
|
||||
(This compilerPath)
|
||||
|
||||
ensureCompilerExists :: Cli ()
|
||||
ensureCompilerExists =
|
||||
Cli.branchExistsAtPath' compilerPath
|
||||
>>= flip unless (doFetchCompiler "unison" JitInfo.currentRelease)
|
||||
|
||||
getCacheDir :: Cli String
|
||||
getCacheDir = liftIO $ getXdgDirectory XdgCache "unisonlanguage"
|
||||
|
||||
getSchemeGenLibDir :: Cli String
|
||||
getSchemeGenLibDir =
|
||||
Cli.getConfig "SchemeLibs.Generated" >>= \case
|
||||
Just dir -> pure dir
|
||||
Nothing -> (</> "scheme-libs") <$> getCacheDir
|
||||
|
||||
getSchemeStaticLibDir :: Cli String
|
||||
getSchemeStaticLibDir =
|
||||
Cli.getConfig "SchemeLibs.Static" >>= \case
|
||||
Just dir -> pure dir
|
||||
Nothing ->
|
||||
liftIO $
|
||||
getXdgDirectory XdgData ("unisonlanguage" </> "scheme-libs")
|
||||
|
||||
doGenerateSchemeBoot ::
|
||||
Bool -> Maybe PPE.PrettyPrintEnv -> Maybe String -> Cli ()
|
||||
doGenerateSchemeBoot force mppe mdir = do
|
||||
ppe <- maybe (PPED.suffixifiedPPE <$> Cli.currentPrettyPrintEnvDecl) pure mppe
|
||||
dir <- maybe getSchemeGenLibDir pure mdir
|
||||
let bootf = dir </> "unison" </> "boot-generated.ss"
|
||||
swrapf = dir </> "unison" </> "simple-wrappers.ss"
|
||||
binf = dir </> "unison" </> "builtin-generated.ss"
|
||||
cwrapf = dir </> "unison" </> "compound-wrappers.ss"
|
||||
dinfof = dir </> "unison" </> "data-info.ss"
|
||||
dirTm = Term.text a (Text.pack dir)
|
||||
liftIO $ createDirectoryIfMissing True dir
|
||||
saveData <- Term.ref a <$> resolveTermRef sdName
|
||||
saveBase <- Term.ref a <$> resolveTermRef sbName
|
||||
saveWrap <- Term.ref a <$> resolveTermRef swName
|
||||
gen ppe saveData dinfof dirTm dinfoName
|
||||
gen ppe saveBase bootf dirTm bootName
|
||||
gen ppe saveWrap swrapf dirTm simpleWrapName
|
||||
gen ppe saveBase binf dirTm builtinName
|
||||
gen ppe saveWrap cwrapf dirTm compoundWrapName
|
||||
where
|
||||
a = External
|
||||
|
||||
sbName = HQ.unsafeParseText ".unison.internal.compiler.scheme.saveBaseFile"
|
||||
swName = HQ.unsafeParseText ".unison.internal.compiler.scheme.saveWrapperFile"
|
||||
sdName = HQ.unsafeParseText ".unison.internal.compiler.scheme.saveDataInfoFile"
|
||||
dinfoName = HQ.unsafeParseText ".unison.internal.compiler.scheme.dataInfos"
|
||||
bootName = HQ.unsafeParseText ".unison.internal.compiler.scheme.bootSpec"
|
||||
builtinName = HQ.unsafeParseText ".unison.internal.compiler.scheme.builtinSpec"
|
||||
simpleWrapName =
|
||||
HQ.unsafeParseText ".unison.internal.compiler.scheme.simpleWrapperSpec"
|
||||
compoundWrapName =
|
||||
HQ.unsafeParseText ".unison.internal.compiler.scheme.compoundWrapperSpec"
|
||||
|
||||
gen ppe save file dir nm =
|
||||
liftIO (doesFileExist file) >>= \b -> when (not b || force) do
|
||||
spec <- Term.ref a <$> resolveTermRef nm
|
||||
let make = Term.apps' save [dir, spec]
|
||||
typecheckAndEval ppe make
|
||||
|
||||
typecheckAndEval :: PPE.PrettyPrintEnv -> Term Symbol Ann -> Cli ()
|
||||
typecheckAndEval ppe tm = do
|
||||
Cli.Env {codebase, runtime} <- ask
|
||||
let mty = Runtime.mainType runtime
|
||||
Cli.runTransaction (typecheckTerm codebase (Term.delay a tm)) >>= \case
|
||||
-- Type checking succeeded
|
||||
Result.Result _ (Just ty)
|
||||
| Typechecker.fitsScheme ty mty ->
|
||||
() <$ RuntimeUtils.evalUnisonTerm False ppe False tm
|
||||
| otherwise ->
|
||||
Cli.returnEarly $ BadMainFunction "run" rendered ty ppe [mty]
|
||||
Result.Result notes Nothing -> do
|
||||
currentPath <- Cli.getCurrentPath
|
||||
let tes = [err | Result.TypeError err <- toList notes]
|
||||
Cli.returnEarly (TypeErrors currentPath rendered ppe tes)
|
||||
where
|
||||
a = External
|
||||
rendered = Text.pack (P.toPlainUnbroken $ TP.pretty ppe tm)
|
||||
|
||||
ensureSchemeExists :: Cli ()
|
||||
ensureSchemeExists =
|
||||
liftIO callScheme >>= \case
|
||||
True -> pure ()
|
||||
False -> Cli.returnEarly (PrintMessage msg)
|
||||
where
|
||||
msg =
|
||||
P.lines
|
||||
[ "I can't seem to call racket. See",
|
||||
"",
|
||||
P.indentN
|
||||
2
|
||||
"https://download.racket-lang.org/",
|
||||
"",
|
||||
"for how to install Racket."
|
||||
]
|
||||
cmd = "racket -l- raco help"
|
||||
callScheme =
|
||||
readCreateProcessWithExitCode (shell cmd) "" >>= \case
|
||||
(ExitSuccess, _, _) -> pure True
|
||||
(ExitFailure _, _, _) -> pure False
|
||||
|
||||
racketOpts :: FilePath -> FilePath -> [String] -> [String]
|
||||
racketOpts gendir statdir args = "-y" : libs ++ args
|
||||
where
|
||||
includes = [gendir, statdir </> "racket"]
|
||||
libs = concatMap (\dir -> ["-S", dir]) includes
|
||||
|
||||
runScheme :: String -> [String] -> Cli ()
|
||||
runScheme file args = do
|
||||
ensureSchemeExists
|
||||
gendir <- getSchemeGenLibDir
|
||||
statdir <- getSchemeStaticLibDir
|
||||
let cmd = "racket"
|
||||
opts = racketOpts gendir statdir (file : args)
|
||||
success <-
|
||||
liftIO $
|
||||
(True <$ callProcess cmd opts)
|
||||
`catch` \(_ :: IOException) -> pure False
|
||||
unless success $
|
||||
Cli.returnEarly (PrintMessage "Scheme evaluation failed.")
|
||||
|
||||
buildScheme :: Text -> String -> Cli ()
|
||||
buildScheme main file = do
|
||||
ensureSchemeExists
|
||||
statDir <- getSchemeStaticLibDir
|
||||
genDir <- getSchemeGenLibDir
|
||||
buildRacket genDir statDir main file
|
||||
|
||||
buildRacket :: String -> String -> Text -> String -> Cli ()
|
||||
buildRacket genDir statDir main file =
|
||||
let args = ["-l", "raco", "--", "exe", "-o", Text.unpack main, file]
|
||||
opts = racketOpts genDir statDir args
|
||||
in void . liftIO $
|
||||
catch
|
||||
(True <$ callProcess "racket" opts)
|
||||
(\(_ :: IOException) -> pure False)
|
||||
|
||||
doCompile :: Bool -> String -> HQ.HashQualified Name -> Cli ()
|
||||
doCompile native output main = do
|
||||
Cli.Env {codebase, runtime, nativeRuntime} <- ask
|
||||
@ -2096,43 +1909,6 @@ doCompile native output main = do
|
||||
)
|
||||
(Cli.returnEarly . EvaluationFailure)
|
||||
|
||||
doRunAsScheme :: Text -> [String] -> Cli ()
|
||||
doRunAsScheme main0 args = case HQ.parseText main0 of
|
||||
Just main -> do
|
||||
fullpath <- generateSchemeFile True main0 main
|
||||
runScheme fullpath args
|
||||
Nothing -> Cli.respond $ BadName main0
|
||||
|
||||
doCompileScheme :: Text -> HQ.HashQualified Name -> Cli ()
|
||||
doCompileScheme out main =
|
||||
generateSchemeFile True out main >>= buildScheme out
|
||||
|
||||
generateSchemeFile :: Bool -> Text -> HQ.HashQualified Name -> Cli String
|
||||
generateSchemeFile exec out main = do
|
||||
(comp, ppe) <- resolveMainRef main
|
||||
ensureCompilerExists
|
||||
doGenerateSchemeBoot False (Just ppe) Nothing
|
||||
cacheDir <- getCacheDir
|
||||
liftIO $ createDirectoryIfMissing True (cacheDir </> "scheme-tmp")
|
||||
let scratch = Text.unpack out ++ ".scm"
|
||||
fullpath = cacheDir </> "scheme-tmp" </> scratch
|
||||
output = Text.pack fullpath
|
||||
sscm <- Term.ref a <$> resolveTermRef saveNm
|
||||
fprf <- resolveCon filePathNm
|
||||
let toCmp = Term.termLink a (Referent.Ref comp)
|
||||
outTm = Term.text a output
|
||||
fpc = Term.constructor a fprf
|
||||
fp = Term.app a fpc outTm
|
||||
tm :: Term Symbol Ann
|
||||
tm = Term.apps' sscm [Term.boolean a exec, toCmp, fp]
|
||||
typecheckAndEval ppe tm
|
||||
pure fullpath
|
||||
where
|
||||
a = External
|
||||
|
||||
saveNm = HQ.unsafeParseText ".unison.internal.compiler.saveScheme"
|
||||
filePathNm = HQ.unsafeParseText "FilePath.FilePath"
|
||||
|
||||
delete ::
|
||||
Input ->
|
||||
DeleteOutput ->
|
||||
|
||||
@ -185,10 +185,6 @@ data Input
|
||||
ExecuteSchemeI Text [String]
|
||||
| -- compile to a scheme file
|
||||
CompileSchemeI Text (HQ.HashQualified Name)
|
||||
| -- generate scheme libraries, optional target directory
|
||||
GenSchemeLibsI (Maybe String)
|
||||
| -- fetch scheme compiler from a given username and branch
|
||||
FetchSchemeCompilerI String String
|
||||
| TestI TestInput
|
||||
| CreateAuthorI NameSegment {- identifier -} Text {- name -}
|
||||
| -- Display provided definitions.
|
||||
|
||||
@ -196,11 +196,12 @@ withTranscriptRunner ::
|
||||
(UnliftIO.MonadUnliftIO m) =>
|
||||
Verbosity ->
|
||||
UCMVersion ->
|
||||
FilePath ->
|
||||
Maybe FilePath ->
|
||||
(TranscriptRunner -> m r) ->
|
||||
m r
|
||||
withTranscriptRunner verbosity ucmVersion configFile action = do
|
||||
withRuntimes \runtime sbRuntime nRuntime -> withConfig \config -> do
|
||||
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
|
||||
@ -209,12 +210,12 @@ withTranscriptRunner verbosity ucmVersion configFile action = do
|
||||
pure $ join @(Either TranscriptError) result
|
||||
where
|
||||
withRuntimes ::
|
||||
(Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> m a) -> m a
|
||||
withRuntimes action =
|
||||
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)
|
||||
=<< liftIO (RTI.startNativeRuntime ucmVersion nrtp)
|
||||
withConfig :: forall a. ((Maybe Config -> m a) -> m a)
|
||||
withConfig action = do
|
||||
case configFile of
|
||||
|
||||
@ -52,7 +52,6 @@ import Unison.CommandLine.FZFResolvers qualified as Resolvers
|
||||
import Unison.CommandLine.InputPattern (ArgumentType (..), InputPattern (InputPattern), IsOptional (..), unionSuggestions)
|
||||
import Unison.CommandLine.InputPattern qualified as I
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.JitInfo qualified as JitInfo
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
@ -2540,73 +2539,6 @@ compileScheme =
|
||||
Input.CompileSchemeI (Text.pack file) <$> parseHashQualifiedName main
|
||||
_ -> Left $ showPatternHelp compileScheme
|
||||
|
||||
schemeLibgen :: InputPattern
|
||||
schemeLibgen =
|
||||
InputPattern
|
||||
"compile.native.genlibs"
|
||||
[]
|
||||
I.Visible
|
||||
[("target directory", Optional, filePathArg)]
|
||||
( P.wrapColumn2
|
||||
[ ( makeExample schemeLibgen ["[targetDir]"],
|
||||
"Generates libraries necessary for scheme compilation.\n\n\
|
||||
\There is no need to run this before"
|
||||
<> P.group (makeExample compileScheme [])
|
||||
<> "as\
|
||||
\ the latter will check if the libraries are missing and\
|
||||
\ auto-generate them. However, this will generate the\
|
||||
\ libraries even if their files already exist, so if the\
|
||||
\ compiler has been upgraded, this can be used to ensure\
|
||||
\ the generated libraries are up to date."
|
||||
)
|
||||
]
|
||||
)
|
||||
\case
|
||||
[] -> pure $ Input.GenSchemeLibsI Nothing
|
||||
[dir] -> pure . Input.GenSchemeLibsI $ Just dir
|
||||
_ -> Left $ showPatternHelp schemeLibgen
|
||||
|
||||
fetchScheme :: InputPattern
|
||||
fetchScheme =
|
||||
InputPattern
|
||||
"compile.native.fetch"
|
||||
[]
|
||||
I.Visible
|
||||
[("name", Optional, noCompletionsArg), ("branch", Optional, noCompletionsArg)]
|
||||
( P.wrapColumn2
|
||||
[ ( makeExample fetchScheme [],
|
||||
P.lines . fmap P.wrap $
|
||||
[ "Fetches the unison library for compiling to scheme.",
|
||||
"This is done automatically when"
|
||||
<> P.group (makeExample compileScheme [])
|
||||
<> "is run if the library is not already in the\
|
||||
\ standard location (unison.internal). However,\
|
||||
\ this command will force a pull even if the\
|
||||
\ library already exists.",
|
||||
"You can also specify a user and branch name to pull\
|
||||
\ from in order to use an alternate version of the\
|
||||
\ unison compiler (for development purposes, for\
|
||||
\ example).",
|
||||
"The default user is `unison`. The default branch\
|
||||
\ for the `unison` user is a specified latest\
|
||||
\ version of the compiler for stability. The\
|
||||
\ default branch for other uses is `main`. The\
|
||||
\ command fetches code from a project:",
|
||||
P.indentN 2 ("@user/internal/branch")
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
\case
|
||||
[] -> pure (Input.FetchSchemeCompilerI "unison" JitInfo.currentRelease)
|
||||
[name] -> pure (Input.FetchSchemeCompilerI name branch)
|
||||
where
|
||||
branch
|
||||
| name == "unison" = JitInfo.currentRelease
|
||||
| otherwise = "main"
|
||||
[name, branch] -> pure (Input.FetchSchemeCompilerI name branch)
|
||||
_ -> Left $ showPatternHelp fetchScheme
|
||||
|
||||
createAuthor :: InputPattern
|
||||
createAuthor =
|
||||
InputPattern
|
||||
@ -3049,7 +2981,6 @@ validInputs =
|
||||
edit,
|
||||
editNamespace,
|
||||
execute,
|
||||
fetchScheme,
|
||||
find,
|
||||
findAll,
|
||||
findGlobal,
|
||||
@ -3104,7 +3035,6 @@ validInputs =
|
||||
resetRoot,
|
||||
runScheme,
|
||||
saveExecuteResult,
|
||||
schemeLibgen,
|
||||
squashMerge,
|
||||
test,
|
||||
testAll,
|
||||
|
||||
@ -1,4 +0,0 @@
|
||||
module Unison.JitInfo (currentRelease) where
|
||||
|
||||
currentRelease :: String
|
||||
currentRelease = "releases/0.0.10"
|
||||
@ -66,7 +66,7 @@ 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" configFile $ \runner -> do
|
||||
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
|
||||
@ -78,6 +78,9 @@ runTranscript (Codebase codebasePath fmt) transcript = do
|
||||
Right x -> pure x
|
||||
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"
|
||||
|
||||
lowLevel :: Codebase -> (Codebase.Codebase IO Symbol Ann -> IO a) -> IO a
|
||||
lowLevel (Codebase root fmt) action = do
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
|
||||
|
||||
{- This module kicks off the Transcript Tests.
|
||||
It doesn't do the transcript parsing itself.
|
||||
@ -10,12 +10,13 @@ import Data.Text qualified as Text
|
||||
import Data.Text.IO qualified as Text
|
||||
import EasyTest
|
||||
import System.Directory
|
||||
import System.Environment (getArgs)
|
||||
import System.Environment (getArgs, getExecutablePath)
|
||||
import System.FilePath
|
||||
( replaceExtension,
|
||||
splitFileName,
|
||||
takeExtensions,
|
||||
(</>),
|
||||
(<.>),
|
||||
)
|
||||
import System.IO.CodePage (withCP65001)
|
||||
import System.IO.Silently (silence)
|
||||
@ -27,17 +28,24 @@ import Unison.Prelude
|
||||
import UnliftIO.STM qualified as STM
|
||||
|
||||
data TestConfig = TestConfig
|
||||
{ matchPrefix :: Maybe String
|
||||
{ matchPrefix :: Maybe String,
|
||||
runtimePath :: FilePath
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type TestBuilder = FilePath -> [String] -> String -> Test ()
|
||||
type TestBuilder = FilePath -> FilePath -> [String] -> String -> Test ()
|
||||
|
||||
testBuilder ::
|
||||
Bool -> ((FilePath, Text) -> IO ()) -> FilePath -> [String] -> String -> Test ()
|
||||
testBuilder expectFailure recordFailure dir prelude transcript = scope transcript $ do
|
||||
Bool ->
|
||||
((FilePath, Text) -> IO ()) ->
|
||||
FilePath ->
|
||||
FilePath ->
|
||||
[String] ->
|
||||
String ->
|
||||
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" Nothing \runTranscript -> 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)
|
||||
@ -73,7 +81,7 @@ outputFileForTranscript filePath =
|
||||
replaceExtension filePath ".output.md"
|
||||
|
||||
buildTests :: TestConfig -> TestBuilder -> FilePath -> Test ()
|
||||
buildTests config testBuilder dir = do
|
||||
buildTests TestConfig{ .. } testBuilder dir = do
|
||||
io
|
||||
. putStrLn
|
||||
. unlines
|
||||
@ -88,7 +96,7 @@ buildTests config testBuilder dir = do
|
||||
& filter (\f -> takeExtensions f == ".md")
|
||||
& 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 config)))
|
||||
& second (filter (\f -> maybe True (`isPrefixOf` f) matchPrefix))
|
||||
|
||||
case length transcripts of
|
||||
0 -> pure ()
|
||||
@ -96,7 +104,7 @@ buildTests config 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 dir prelude <$> transcripts)
|
||||
_ -> tests (testBuilder runtimePath dir prelude <$> transcripts)
|
||||
|
||||
-- Transcripts that exit successfully get cleaned-up by the transcript parser.
|
||||
-- Any remaining folders matching "transcript-.*" are output directories
|
||||
@ -139,14 +147,21 @@ test config = do
|
||||
Text.putStrLn msg
|
||||
cleanup
|
||||
|
||||
handleArgs :: [String] -> TestConfig
|
||||
handleArgs args =
|
||||
let matchPrefix = case args of
|
||||
[prefix] -> Just prefix
|
||||
_ -> Nothing
|
||||
in TestConfig matchPrefix
|
||||
handleArgs :: TestConfig -> [String] -> TestConfig
|
||||
handleArgs acc ("--runtime-path":p:rest) =
|
||||
handleArgs (acc { runtimePath = p }) rest
|
||||
handleArgs acc [prefix] = acc { matchPrefix = Just prefix }
|
||||
handleArgs acc _ = acc
|
||||
|
||||
defaultConfig :: IO TestConfig
|
||||
defaultConfig = TestConfig Nothing <$> defaultRTP
|
||||
where
|
||||
defaultRTP = do
|
||||
ucm <- getExecutablePath
|
||||
pure (ucm </> "runtime" </> "unison-runtime" <.> exeExtension)
|
||||
|
||||
main :: IO ()
|
||||
main = withCP65001 do
|
||||
testConfig <- handleArgs <$> getArgs
|
||||
dcfg <- defaultConfig
|
||||
testConfig <- handleArgs dcfg <$> getArgs
|
||||
run (test testConfig)
|
||||
|
||||
@ -107,7 +107,6 @@ library
|
||||
Unison.CommandLine.OutputMessages
|
||||
Unison.CommandLine.Types
|
||||
Unison.CommandLine.Welcome
|
||||
Unison.JitInfo
|
||||
Unison.LSP
|
||||
Unison.LSP.CancelRequest
|
||||
Unison.LSP.CodeAction
|
||||
|
||||
@ -114,6 +114,7 @@ data Command
|
||||
data GlobalOptions = GlobalOptions
|
||||
{ codebasePathOption :: Maybe CodebasePathOption,
|
||||
exitOption :: ShouldExit,
|
||||
nativeRuntimePath :: Maybe FilePath,
|
||||
lspFormattingConfig :: LspFormattingConfig
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
@ -256,10 +257,11 @@ globalOptionsParser = do
|
||||
-- ApplicativeDo
|
||||
codebasePathOption <- codebasePathParser <|> codebaseCreateParser
|
||||
exitOption <- exitParser
|
||||
nativeRuntimePath <- nativeRuntimePathFlag
|
||||
lspFormattingConfig <- lspFormattingParser
|
||||
|
||||
pure
|
||||
GlobalOptions {codebasePathOption, exitOption, lspFormattingConfig}
|
||||
GlobalOptions {codebasePathOption, exitOption, nativeRuntimePath, lspFormattingConfig}
|
||||
|
||||
codebasePathParser :: Parser (Maybe CodebasePathOption)
|
||||
codebasePathParser = do
|
||||
@ -446,6 +448,14 @@ readAbsolutePath = do
|
||||
<> show rel
|
||||
<> " was relative. Try adding a `.` prefix, e.g. `.path.to.project`"
|
||||
|
||||
nativeRuntimePathFlag :: Parser (Maybe FilePath)
|
||||
nativeRuntimePathFlag =
|
||||
optional . strOption $
|
||||
long "runtime-path"
|
||||
<> metavar "DIR"
|
||||
<> help "Path to native runtime files"
|
||||
<> noGlobal
|
||||
|
||||
readPath' :: ReadM Path.Path'
|
||||
readPath' = do
|
||||
strPath <- OptParse.str
|
||||
|
||||
@ -40,8 +40,13 @@ import Ki qualified
|
||||
import Network.HTTP.Client qualified as HTTP
|
||||
import Network.HTTP.Client.TLS qualified as HTTP
|
||||
import Stats (recordRtsStats)
|
||||
import System.Directory (canonicalizePath, getCurrentDirectory, removeDirectoryRecursive)
|
||||
import System.Environment (getProgName, withArgs)
|
||||
import System.Directory
|
||||
( canonicalizePath,
|
||||
getCurrentDirectory,
|
||||
removeDirectoryRecursive,
|
||||
exeExtension
|
||||
)
|
||||
import System.Environment (getExecutablePath, getProgName, withArgs)
|
||||
import System.Exit qualified as Exit
|
||||
import System.FilePath qualified as FP
|
||||
import System.IO (stderr)
|
||||
@ -85,6 +90,12 @@ import Version qualified
|
||||
type Runtimes =
|
||||
(RTI.Runtime Symbol, RTI.Runtime Symbol, RTI.Runtime Symbol)
|
||||
|
||||
fixNativeRuntimePath :: Maybe FilePath -> IO FilePath
|
||||
fixNativeRuntimePath override = do
|
||||
ucm <- getExecutablePath
|
||||
let ucr = ucm FP.</> "runtime" FP.</> "unison-runtime" FP.<.> exeExtension
|
||||
pure $ maybe ucr id override
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
-- Replace the default exception handler with one complains loudly, because we shouldn't have any uncaught exceptions.
|
||||
@ -118,6 +129,7 @@ main = do
|
||||
progName <- getProgName
|
||||
-- hSetBuffering stdout NoBuffering -- cool
|
||||
(renderUsageInfo, globalOptions, command) <- parseCLIArgs progName (Text.unpack Version.gitDescribeWithDate)
|
||||
nrtp <- fixNativeRuntimePath (nativeRuntimePath globalOptions)
|
||||
let GlobalOptions {codebasePathOption = mCodePathOption, exitOption, lspFormattingConfig} = globalOptions
|
||||
withConfig mCodePathOption \config -> do
|
||||
currentDir <- getCurrentDirectory
|
||||
@ -150,7 +162,7 @@ main = do
|
||||
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 RTI.OneOff \(rt, sbrt, nrt) -> do
|
||||
withRuntimes nrtp RTI.OneOff \(rt, sbrt, nrt) -> do
|
||||
let fileEvent = Input.UnisonFileChanged (Text.pack file) contents
|
||||
let noOpRootNotifier _ = pure ()
|
||||
let noOpPathNotifier _ = pure ()
|
||||
@ -176,7 +188,7 @@ main = do
|
||||
Left _ -> exitError "I had trouble reading this input."
|
||||
Right contents -> do
|
||||
getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do
|
||||
withRuntimes RTI.OneOff \(rt, sbrt, nrt) -> do
|
||||
withRuntimes nrtp RTI.OneOff \(rt, sbrt, nrt) -> do
|
||||
let fileEvent = Input.UnisonFileChanged (Text.pack "<standard input>") contents
|
||||
let noOpRootNotifier _ = pure ()
|
||||
let noOpPathNotifier _ = pure ()
|
||||
@ -261,13 +273,13 @@ main = do
|
||||
\that matches your version of Unison."
|
||||
]
|
||||
Transcript shouldFork shouldSaveCodebase mrtsStatsFp transcriptFiles -> do
|
||||
let action = runTranscripts Verbosity.Verbose renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles
|
||||
let action = runTranscripts 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 RTI.Persistent \(runtime, sbRuntime, nRuntime) -> 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
|
||||
@ -332,12 +344,13 @@ main = do
|
||||
Exit -> do Exit.exitSuccess
|
||||
where
|
||||
-- (runtime, sandboxed runtime)
|
||||
withRuntimes :: RTI.RuntimeHost -> (Runtimes -> IO a) -> IO a
|
||||
withRuntimes mode action =
|
||||
withRuntimes :: FilePath -> RTI.RuntimeHost -> (Runtimes -> IO a) -> IO a
|
||||
withRuntimes nrtp mode action =
|
||||
RTI.withRuntime False mode Version.gitDescribeWithDate \runtime -> do
|
||||
RTI.withRuntime True mode Version.gitDescribeWithDate \sbRuntime ->
|
||||
action . (runtime,sbRuntime,)
|
||||
=<< RTI.startNativeRuntime Version.gitDescribeWithDate
|
||||
-- startNativeRuntime saves the path to `unison-runtime`
|
||||
=<< RTI.startNativeRuntime Version.gitDescribeWithDate nrtp
|
||||
withConfig :: Maybe CodebasePathOption -> (Config -> IO a) -> IO a
|
||||
withConfig mCodePathOption action = do
|
||||
UnliftIO.bracket
|
||||
@ -389,14 +402,15 @@ runTranscripts' ::
|
||||
String ->
|
||||
Maybe FilePath ->
|
||||
FilePath ->
|
||||
FilePath ->
|
||||
NonEmpty MarkdownFile ->
|
||||
IO Bool
|
||||
runTranscripts' progName mcodepath transcriptDir markdownFiles = do
|
||||
runTranscripts' progName mcodepath 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 (Just configFilePath) $ \runTranscript -> do
|
||||
TR.withTranscriptRunner Verbosity.Verbose Version.gitDescribeWithDate nativeRtp (Just configFilePath) $ \runTranscript -> do
|
||||
for markdownFiles $ \(MarkdownFile fileName) -> do
|
||||
transcriptSrc <- readUtf8 fileName
|
||||
result <- runTranscript fileName transcriptSrc (codebasePath, theCodebase)
|
||||
@ -444,9 +458,10 @@ runTranscripts ::
|
||||
ShouldForkCodebase ->
|
||||
ShouldSaveCodebase ->
|
||||
Maybe CodebasePathOption ->
|
||||
FilePath ->
|
||||
NonEmpty String ->
|
||||
IO ()
|
||||
runTranscripts verbosity renderUsageInfo shouldFork shouldSaveTempCodebase mCodePathOption args = do
|
||||
runTranscripts verbosity renderUsageInfo shouldFork shouldSaveTempCodebase mCodePathOption nativeRtp args = do
|
||||
markdownFiles <- case traverse (first (pure @[]) . markdownFile) args of
|
||||
Failure invalidArgs -> do
|
||||
PT.putPrettyLn $
|
||||
@ -464,7 +479,7 @@ runTranscripts verbosity renderUsageInfo shouldFork shouldSaveTempCodebase mCode
|
||||
progName <- getProgName
|
||||
transcriptDir <- prepareTranscriptDir verbosity shouldFork mCodePathOption shouldSaveTempCodebase
|
||||
completed <-
|
||||
runTranscripts' progName (Just transcriptDir) transcriptDir markdownFiles
|
||||
runTranscripts' progName (Just transcriptDir) nativeRtp transcriptDir markdownFiles
|
||||
case shouldSaveTempCodebase of
|
||||
DontSaveCodebase -> removeDirectoryRecursive transcriptDir
|
||||
SaveCodebase _ ->
|
||||
|
||||
@ -6,5 +6,6 @@ Thus, make sure the contents of this file define the contents of the cache
|
||||
|
||||
```ucm
|
||||
.> pull @unison/base/releases/2.5.0 .base
|
||||
.> compile.native.fetch
|
||||
.> builtins.mergeio
|
||||
.> undo
|
||||
```
|
||||
|
||||
@ -1,23 +0,0 @@
|
||||
When this file is modified, CI will create a new codebase and re-run this;
|
||||
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
|
||||
|
||||
Merging...
|
||||
|
||||
😶
|
||||
|
||||
.base was already up-to-date with @unison/base/releases/2.5.0.
|
||||
|
||||
.> compile.native.fetch
|
||||
|
||||
😶
|
||||
|
||||
.unison.internal was already up-to-date with
|
||||
@unison/internal/releases/0.0.3.
|
||||
|
||||
```
|
||||
@ -2,8 +2,6 @@
|
||||
Note: This should be forked off of the codebase created by base.md
|
||||
|
||||
```ucm:hide
|
||||
.> compile.native.fetch
|
||||
.> compile.native.genlibs
|
||||
.> load unison-src/builtin-tests/testlib.u
|
||||
.> add
|
||||
```
|
||||
|
||||
@ -8,8 +8,12 @@ to `Tests.check` and `Tests.checkEqual`).
|
||||
```ucm
|
||||
.> run.native tests
|
||||
|
||||
()
|
||||
|
||||
```
|
||||
```ucm
|
||||
.> run.native tests.jit.only
|
||||
|
||||
()
|
||||
|
||||
```
|
||||
|
||||
38
unison-src/transcripts-manual/gen-racket-libs.md
Normal file
38
unison-src/transcripts-manual/gen-racket-libs.md
Normal file
@ -0,0 +1,38 @@
|
||||
|
||||
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
|
||||
jit-setup/main> pull @unison/internal/releases/0.0.11 lib.jit
|
||||
```
|
||||
|
||||
```unison
|
||||
go = generateSchemeBoot "scheme-libs/racket"
|
||||
```
|
||||
|
||||
```ucm
|
||||
jit-setup/main> run go
|
||||
```
|
||||
|
||||
After executing this, `scheme-libs/racket` will contain the full
|
||||
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.
|
||||
|
||||
raco pkg install -t dir unison
|
||||
|
||||
in the directory where the `unison` directory is located. Then the
|
||||
runtime executable can be built with
|
||||
|
||||
raco exe scheme-libs/racket/unison-runtime.rkt
|
||||
|
||||
and a distributable directory can be produced with:
|
||||
|
||||
raco distribute <output-dir> scheme-libs/racket/unison-runtime
|
||||
|
||||
At that point, <output-dir> should contain the executable and all
|
||||
dependencies necessary to run it.
|
||||
74
unison-src/transcripts-manual/gen-racket-libs.output.md
Normal file
74
unison-src/transcripts-manual/gen-racket-libs.output.md
Normal file
@ -0,0 +1,74 @@
|
||||
|
||||
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.11 lib.jit
|
||||
|
||||
Downloaded 13900 entities.
|
||||
|
||||
✅
|
||||
|
||||
Successfully pulled into lib.jit, which was empty.
|
||||
|
||||
```
|
||||
```unison
|
||||
go = generateSchemeBoot "scheme-libs/racket"
|
||||
```
|
||||
|
||||
```ucm
|
||||
|
||||
Loading changes detected in scratch.u.
|
||||
|
||||
I found and typechecked these definitions in scratch.u. If you
|
||||
do an `add` or `update`, here's how your codebase would
|
||||
change:
|
||||
|
||||
⍟ These new definitions are ok to `add`:
|
||||
|
||||
go : '{IO, Exception} ()
|
||||
|
||||
```
|
||||
```ucm
|
||||
jit-setup/main> run go
|
||||
|
||||
()
|
||||
|
||||
```
|
||||
After executing this, `scheme-libs/racket` will contain the full
|
||||
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.
|
||||
|
||||
raco pkg install -t dir unison
|
||||
|
||||
in the directory where the `unison directory is located. Then the
|
||||
runtime executable can be built with
|
||||
|
||||
raco exe scheme-libs/racket/unison-runtime.rkt
|
||||
|
||||
and a distributable directory can be produced with:
|
||||
|
||||
raco distribute <output-dir> scheme-libs/racket/unison-runtime
|
||||
|
||||
At that point, <output-dir> should contain the executable and all
|
||||
dependencies necessary to run it.
|
||||
Loading…
Reference in New Issue
Block a user