mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-26 11:07:48 +03:00
⅄ trunk → topic/merge4
This commit is contained in:
commit
2ff7d77820
@ -1,42 +0,0 @@
|
|||||||
# Reference:
|
|
||||||
# https://docs.github.com/en/actions/creating-actions/creating-a-composite-action
|
|
||||||
|
|
||||||
name: "Install Stack"
|
|
||||||
description: "Install stack for Linux, macOS, and Windows"
|
|
||||||
|
|
||||||
inputs:
|
|
||||||
stack-version:
|
|
||||||
description: "The version of stack to install, e.g. 2.9.1"
|
|
||||||
required: true
|
|
||||||
default: "2.9.1"
|
|
||||||
|
|
||||||
runs:
|
|
||||||
using: "composite"
|
|
||||||
steps:
|
|
||||||
- name: install stack
|
|
||||||
shell: bash
|
|
||||||
working-directory: ${{ runner.temp }}
|
|
||||||
run: |
|
|
||||||
if [[ ${{runner.os}} = 'Windows' ]]; then
|
|
||||||
stack_os="windows"
|
|
||||||
elif [[ ${{runner.os}} = 'macOS' ]]; then
|
|
||||||
stack_os="osx"
|
|
||||||
elif [[ ${{runner.os}} = 'Linux' ]]; then
|
|
||||||
stack_os="linux"
|
|
||||||
else
|
|
||||||
echo "Unsupported OS: ${{runner.os}}"
|
|
||||||
exit 1
|
|
||||||
fi
|
|
||||||
if [[ ${{runner.arch}} = 'X64' ]]; then
|
|
||||||
stack_arch="x86_64"
|
|
||||||
elif [[ ${{runner.arch}} = 'ARM64' ]]; then
|
|
||||||
stack_arch="aarch64"
|
|
||||||
else
|
|
||||||
echo "Unsupported architecture: ${{runner.arch}}"
|
|
||||||
exit 1
|
|
||||||
fi
|
|
||||||
|
|
||||||
mkdir stack && cd stack
|
|
||||||
curl -L https://github.com/commercialhaskell/stack/releases/download/v${{inputs.stack-version}}/stack-${{inputs.stack-version}}-${stack_os}-${stack_arch}.tar.gz | tar -xz
|
|
||||||
echo "$PWD/stack-"* >> $GITHUB_PATH
|
|
||||||
echo "stack_path=$PWD/stack-"* >> $GITHUB_ENV
|
|
@ -1,100 +0,0 @@
|
|||||||
name: restore stack cache
|
|
||||||
description: restore ~/.stack and .stack-work caches on Linux, macOS, and Windows
|
|
||||||
|
|
||||||
inputs:
|
|
||||||
cache-prefix:
|
|
||||||
description: The cache prefix to use for `~/.stack`, e.g. "release" or "ci"
|
|
||||||
required: true
|
|
||||||
work-cache-prefix:
|
|
||||||
description: The cache prefix to use for `**/.stack-work`, defaults to the same as `cache-prefix`
|
|
||||||
required: false
|
|
||||||
stack-yaml-dir:
|
|
||||||
description: The directory to search for `stack.yaml`
|
|
||||||
required: false
|
|
||||||
default: '.'
|
|
||||||
lookup-only:
|
|
||||||
description: If true, only checks if cache entry exists and skips download.
|
|
||||||
required: false
|
|
||||||
default: 'false'
|
|
||||||
|
|
||||||
outputs:
|
|
||||||
cache-hit:
|
|
||||||
description: Whether the .stack cache was restored with an exact match
|
|
||||||
value: ${{ steps.cache-stack-unix.outputs.cache-hit || steps.cache-stack-windows.outputs.cache-hit }}
|
|
||||||
work-cache-hit:
|
|
||||||
description: Whether the .stack-work cache was restored with an exact match
|
|
||||||
value: ${{ steps.cache-stack-work.outputs.cache-hit }}
|
|
||||||
|
|
||||||
runs:
|
|
||||||
using: composite
|
|
||||||
steps:
|
|
||||||
- name: set default work cache prefix
|
|
||||||
shell: bash
|
|
||||||
run: |
|
|
||||||
if [ -z "${{inputs.work-cache-prefix}}" ]; then
|
|
||||||
echo "work-cache-prefix=${{inputs.cache-prefix}}" >> "$GITHUB_ENV"
|
|
||||||
else
|
|
||||||
echo "work-cache-prefix=${{inputs.work-cache-prefix}}" >> "$GITHUB_ENV"
|
|
||||||
fi
|
|
||||||
|
|
||||||
# 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
|
|
||||||
shell: bash
|
|
||||||
# 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 as a backup cache key
|
|
||||||
# ${{ env.resolver_short }}
|
|
||||||
# ${{ env.resolver }}
|
|
||||||
run: |
|
|
||||||
grep resolver ${{inputs.stack-yaml-dir}}/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 ${{inputs.stack-yaml-dir}}/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'
|
|
||||||
with:
|
|
||||||
lookup-only: ${{inputs.lookup-only}}
|
|
||||||
path: ~/.stack
|
|
||||||
key:
|
|
||||||
${{inputs.cache-prefix}}-stack-${{runner.os}}_${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}
|
|
||||||
restore-keys:
|
|
||||||
${{inputs.cache-prefix}}-stack-${{runner.os}}_${{env.resolver}}-
|
|
||||||
|
|
||||||
- name: restore ~/.stack (Windows)
|
|
||||||
uses: actions/cache/restore@v4
|
|
||||||
id: cache-stack-windows
|
|
||||||
if: runner.os == 'Windows'
|
|
||||||
with:
|
|
||||||
lookup-only: ${{inputs.lookup-only}}
|
|
||||||
path: |
|
|
||||||
C:\Users\runneradmin\AppData\Roaming\stack
|
|
||||||
C:\Users\runneradmin\AppData\Local\Programs\stack
|
|
||||||
key:
|
|
||||||
${{inputs.cache-prefix}}-stack-${{runner.os}}_${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}
|
|
||||||
restore-keys:
|
|
||||||
${{inputs.cache-prefix}}-stack-${{runner.os}}_${{env.resolver}}-
|
|
||||||
|
|
||||||
- name: restore .stack-work
|
|
||||||
uses: actions/cache/restore@v4
|
|
||||||
id: cache-stack-work
|
|
||||||
with:
|
|
||||||
lookup-only: ${{inputs.lookup-only}}
|
|
||||||
path: |
|
|
||||||
**/.stack-work
|
|
||||||
key:
|
|
||||||
${{env.work-cache-prefix}}-stack-work-${{runner.os}}_${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}-${{hashFiles('**/*.hs')}}
|
|
||||||
restore-keys: |
|
|
||||||
${{env.work-cache-prefix}}-stack-work-${{runner.os}}_${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}-
|
|
||||||
${{env.work-cache-prefix}}-stack-work-${{runner.os}}_${{env.resolver}}-
|
|
||||||
${{env.work-cache-prefix}}-stack-work-${{runner.os}}_
|
|
||||||
|
|
||||||
# we added this step out of necessity, don't exactly remember why.
|
|
||||||
# hope to remove it someday.
|
|
||||||
- name: remove ~/.stack/setup-exe-cache on macOS
|
|
||||||
if: runner.os == 'macOS'
|
|
||||||
shell: bash
|
|
||||||
run: rm -rf ~/.stack/setup-exe-cache
|
|
@ -1,73 +0,0 @@
|
|||||||
name: save stack cache
|
|
||||||
description: save ~/.stack and .stack-work caches on Linux, macOS, and Windows
|
|
||||||
|
|
||||||
inputs:
|
|
||||||
cache-prefix:
|
|
||||||
description: The cache prefix to use for `~/.stack`, e.g. "release" or "ci"
|
|
||||||
required: true
|
|
||||||
work-cache-prefix:
|
|
||||||
description: The cache prefix to use for `**/.stack-work`, defaults to the same as `cache-prefix`
|
|
||||||
required: false
|
|
||||||
stack-yaml-dir:
|
|
||||||
description: The directory to search for `stack.yaml`
|
|
||||||
required: false
|
|
||||||
default: '.'
|
|
||||||
|
|
||||||
runs:
|
|
||||||
using: composite
|
|
||||||
steps:
|
|
||||||
- name: set default work cache prefix
|
|
||||||
shell: bash
|
|
||||||
run: |
|
|
||||||
if [ -z "${{inputs.work-cache-prefix}}" ]; then
|
|
||||||
echo "work-cache-prefix=${{inputs.cache-prefix}}" >> "$GITHUB_ENV"
|
|
||||||
else
|
|
||||||
echo "work-cache-prefix=${{inputs.work-cache-prefix}}" >> "$GITHUB_ENV"
|
|
||||||
fi
|
|
||||||
|
|
||||||
- name: check stack caches
|
|
||||||
id: check-stack
|
|
||||||
uses: ./.github/workflows/actions/restore-stack-cache
|
|
||||||
with:
|
|
||||||
cache-prefix: ${{inputs.cache-prefix}}
|
|
||||||
work-cache-prefix: ${{env.work-cache-prefix}}
|
|
||||||
stack-yaml-dir: ${{inputs.stack-yaml-dir}}
|
|
||||||
lookup-only: true
|
|
||||||
|
|
||||||
# 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.
|
|
||||||
- name: record stackage resolver
|
|
||||||
shell: bash
|
|
||||||
# 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 as a backup cache key
|
|
||||||
# ${{ env.resolver_short }}
|
|
||||||
# ${{ env.resolver }}
|
|
||||||
run: |
|
|
||||||
grep resolver ${{inputs.stack-yaml-dir}}/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 ${{inputs.stack-yaml-dir}}/stack.yaml | awk '{print "resolver="$2}' >> "$GITHUB_ENV"
|
|
||||||
|
|
||||||
- name: save ~/.stack (non-Windows)
|
|
||||||
if: runner.os != 'Windows' && steps.check-stack.outputs.cache-hit != 'true'
|
|
||||||
uses: actions/cache/save@v4
|
|
||||||
with:
|
|
||||||
path: ~/.stack
|
|
||||||
key: ${{inputs.cache-prefix}}-stack-${{runner.os}}_${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}
|
|
||||||
|
|
||||||
- name: save ~/.stack (Windows)
|
|
||||||
if: runner.os == 'Windows' && steps.check-stack.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: ${{inputs.cache-prefix}}-stack-${{runner.os}}_${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}
|
|
||||||
|
|
||||||
- name: save .stack-work
|
|
||||||
if: steps.check-stack.outputs.work-cache-hit != 'true'
|
|
||||||
uses: actions/cache/save@v4
|
|
||||||
with:
|
|
||||||
path: |
|
|
||||||
**/.stack-work
|
|
||||||
key: ${{env.work-cache-prefix}}-stack-work-${{runner.os}}_${{env.resolver}}-${{hashFiles('**/stack.yaml', '**/package.yaml')}}-${{hashFiles('**/*.hs')}}
|
|
95
.github/workflows/build-optimized-ucm.yaml
vendored
95
.github/workflows/build-optimized-ucm.yaml
vendored
@ -1,95 +0,0 @@
|
|||||||
on:
|
|
||||||
workflow_call:
|
|
||||||
inputs:
|
|
||||||
ref:
|
|
||||||
description: Git ref to check out for this build, e.g. `trunk` or `release/0.5.19`
|
|
||||||
type: string
|
|
||||||
required: true
|
|
||||||
stack-cache-prefix:
|
|
||||||
description: The Stack cache prefix to use for builds
|
|
||||||
type: string
|
|
||||||
default: release
|
|
||||||
|
|
||||||
defaults:
|
|
||||||
run:
|
|
||||||
shell: bash
|
|
||||||
|
|
||||||
jobs:
|
|
||||||
build-ucm:
|
|
||||||
name: bundle ucm+ui ${{matrix.os}}
|
|
||||||
runs-on: ${{matrix.os}}
|
|
||||||
strategy:
|
|
||||||
fail-fast: false
|
|
||||||
matrix:
|
|
||||||
os: [ubuntu-20.04, macos-12, windows-2019]
|
|
||||||
steps:
|
|
||||||
- uses: actions/checkout@v4
|
|
||||||
with:
|
|
||||||
ref: ${{inputs.ref}}
|
|
||||||
|
|
||||||
- name: restore stack caches
|
|
||||||
uses: ./.github/workflows/actions/restore-stack-cache
|
|
||||||
with:
|
|
||||||
cache-prefix: release
|
|
||||||
|
|
||||||
- name: install stack
|
|
||||||
uses: ./.github/workflows/actions/install-stack
|
|
||||||
|
|
||||||
- name: build
|
|
||||||
run: |
|
|
||||||
# unison-cli embeds version numbers using TH
|
|
||||||
# so it needs to be forced to rebuild to ensure those are updated.
|
|
||||||
stack clean unison-cli
|
|
||||||
|
|
||||||
# Windows will crash on build intermittently because the filesystem
|
|
||||||
# sucks at managing concurrent file access;
|
|
||||||
# Just keep retrying on these failures.
|
|
||||||
tries=5
|
|
||||||
for (( i = 0; i < $tries; i++ )); do
|
|
||||||
stack --no-terminal build --flag unison-parser-typechecker:optimized && break;
|
|
||||||
done
|
|
||||||
|
|
||||||
- name: save stack caches
|
|
||||||
uses: ./.github/workflows/actions/save-stack-cache
|
|
||||||
with:
|
|
||||||
cache-prefix: release
|
|
||||||
|
|
||||||
- name: set up environment
|
|
||||||
run: |
|
|
||||||
if [[ ${{runner.os}} = 'Windows' ]]; then
|
|
||||||
artifact_os="windows"
|
|
||||||
elif [[ ${{runner.os}} = 'macOS' ]]; then
|
|
||||||
artifact_os="osx"
|
|
||||||
elif [[ ${{runner.os}} = 'Linux' ]]; then
|
|
||||||
artifact_os="linux"
|
|
||||||
else
|
|
||||||
echo "Unexpected OS: ${{runner.os}}"
|
|
||||||
exit 1
|
|
||||||
fi
|
|
||||||
echo "artifact_os=$artifact_os" >> $GITHUB_ENV
|
|
||||||
|
|
||||||
- name: fetch latest Unison Local UI and package with ucm
|
|
||||||
run: |
|
|
||||||
mkdir /tmp/ucm
|
|
||||||
cp -v $(stack exec -- which unison) /tmp/ucm/ucm
|
|
||||||
|
|
||||||
curl -L -o /tmp/unisonLocal.zip \
|
|
||||||
https://github.com/unisonweb/unison-local-ui/releases/download/latest/unisonLocal.zip
|
|
||||||
mkdir /tmp/ucm/ui
|
|
||||||
unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip
|
|
||||||
|
|
||||||
if [[ ${{runner.os}} = 'Windows' ]]; then
|
|
||||||
artifact_archive=ucm-${{env.artifact_os}}.zip
|
|
||||||
7z a -r -tzip ${artifact_archive} /tmp/ucm/*
|
|
||||||
else
|
|
||||||
artifact_archive=ucm-${{env.artifact_os}}.tar.gz
|
|
||||||
tar -c -z -f ${artifact_archive} -C /tmp/ucm .
|
|
||||||
fi
|
|
||||||
echo "artifact_archive=${artifact_archive}" >> $GITHUB_ENV
|
|
||||||
|
|
||||||
- name: upload artifact
|
|
||||||
uses: actions/upload-artifact@v2
|
|
||||||
with:
|
|
||||||
if-no-files-found: error
|
|
||||||
name: build-${{env.artifact_os}}
|
|
||||||
path: ${{env.artifact_archive}}
|
|
261
.github/workflows/bundle-ucm.yaml
vendored
Normal file
261
.github/workflows/bundle-ucm.yaml
vendored
Normal file
@ -0,0 +1,261 @@
|
|||||||
|
name: bundle ucm
|
||||||
|
|
||||||
|
# build optimized ucm
|
||||||
|
# package racket lib
|
||||||
|
# build/dist unison-runtime
|
||||||
|
|
||||||
|
on:
|
||||||
|
workflow_call:
|
||||||
|
inputs:
|
||||||
|
ref:
|
||||||
|
description: Git ref to check out for this build, e.g. `trunk` or `release/0.5.19`
|
||||||
|
type: string
|
||||||
|
required: true
|
||||||
|
|
||||||
|
env:
|
||||||
|
racket_version: "8.7"
|
||||||
|
|
||||||
|
defaults:
|
||||||
|
run:
|
||||||
|
shell: bash
|
||||||
|
|
||||||
|
jobs:
|
||||||
|
build-ucm:
|
||||||
|
name: build ucm
|
||||||
|
strategy:
|
||||||
|
fail-fast: false
|
||||||
|
matrix:
|
||||||
|
os: [ubuntu-20.04, macos-12, windows-2019]
|
||||||
|
runs-on: ${{matrix.os}}
|
||||||
|
steps:
|
||||||
|
- uses: actions/checkout@v4
|
||||||
|
with:
|
||||||
|
ref: ${{inputs.ref}}
|
||||||
|
|
||||||
|
- name: restore stack caches
|
||||||
|
uses: unisonweb/actions/stack/cache/restore@main
|
||||||
|
with:
|
||||||
|
cache-prefix: release
|
||||||
|
|
||||||
|
- name: install stack
|
||||||
|
uses: unisonweb/actions/stack/install@main
|
||||||
|
|
||||||
|
- name: build
|
||||||
|
run: |
|
||||||
|
# unison-cli-main embeds version numbers using TH
|
||||||
|
# so it needs to be forced to rebuild to ensure those are updated.
|
||||||
|
stack clean unison-cli-main
|
||||||
|
|
||||||
|
mkdir ucm-bin
|
||||||
|
|
||||||
|
# Windows will crash on build intermittently because the filesystem
|
||||||
|
# sucks at managing concurrent file access;
|
||||||
|
# Just keep retrying on these failures.
|
||||||
|
tries=5
|
||||||
|
for (( i = 0; i < $tries; i++ )); do
|
||||||
|
stack build :unison \
|
||||||
|
--flag unison-parser-typechecker:optimized \
|
||||||
|
--local-bin-path ucm-bin \
|
||||||
|
--copy-bins \
|
||||||
|
&& break;
|
||||||
|
done
|
||||||
|
|
||||||
|
if [[ ${{runner.os}} = 'Windows' ]]; then
|
||||||
|
ucm=$(stack exec where unison)
|
||||||
|
else
|
||||||
|
ucm=$(stack exec which unison)
|
||||||
|
fi
|
||||||
|
echo ucm="$ucm" >> $GITHUB_ENV
|
||||||
|
ls -l $ucm
|
||||||
|
|
||||||
|
- name: save stack caches
|
||||||
|
uses: unisonweb/actions/stack/cache/save@main
|
||||||
|
with:
|
||||||
|
cache-prefix: release
|
||||||
|
|
||||||
|
- name: upload ucm
|
||||||
|
uses: actions/upload-artifact@v4
|
||||||
|
with:
|
||||||
|
name: unison-${{matrix.os}}
|
||||||
|
path: ${{ env.ucm }}
|
||||||
|
if-no-files-found: error
|
||||||
|
|
||||||
|
package-racket-lib:
|
||||||
|
strategy:
|
||||||
|
matrix:
|
||||||
|
os: [ubuntu-20.04]
|
||||||
|
needs: build-ucm
|
||||||
|
name: package racket lib
|
||||||
|
runs-on: ${{matrix.os}}
|
||||||
|
steps:
|
||||||
|
- name: set up environment
|
||||||
|
run: echo "ucm=${{ runner.temp }}/unison" >> $GITHUB_ENV
|
||||||
|
- name: download racket `unison` source
|
||||||
|
uses: actions/checkout@v4
|
||||||
|
with:
|
||||||
|
ref: ${{inputs.ref}}
|
||||||
|
- name: download ucm artifact
|
||||||
|
uses: actions/download-artifact@v4
|
||||||
|
with:
|
||||||
|
name: unison-${{matrix.os}}
|
||||||
|
path: ${{ runner.temp }}
|
||||||
|
- name: generate source
|
||||||
|
run: |
|
||||||
|
chmod +x ${{ env.ucm }}
|
||||||
|
${{ env.ucm }} transcript unison-src/transcripts-manual/gen-racket-libs.md
|
||||||
|
- uses: Bogdanp/setup-racket@v1.11
|
||||||
|
with:
|
||||||
|
architecture: "x64"
|
||||||
|
distribution: "full"
|
||||||
|
variant: "CS"
|
||||||
|
version: ${{env.racket_version}}
|
||||||
|
- name: create racket lib
|
||||||
|
run: |
|
||||||
|
raco pkg create scheme-libs/racket/unison
|
||||||
|
ls -l scheme-libs/racket/unison.zip{,.CHECKSUM}
|
||||||
|
- name: upload racket lib
|
||||||
|
uses: actions/upload-artifact@v4
|
||||||
|
with:
|
||||||
|
name: racket-lib
|
||||||
|
path: |
|
||||||
|
scheme-libs/racket/unison.zip
|
||||||
|
scheme-libs/racket/unison.zip.CHECKSUM
|
||||||
|
if-no-files-found: error
|
||||||
|
|
||||||
|
build-dist-unison-runtime:
|
||||||
|
needs: package-racket-lib
|
||||||
|
name: build unison-runtime
|
||||||
|
strategy:
|
||||||
|
fail-fast: false
|
||||||
|
matrix:
|
||||||
|
os:
|
||||||
|
- ubuntu-20.04
|
||||||
|
- macos-12
|
||||||
|
- windows-2019
|
||||||
|
runs-on: ${{matrix.os}}
|
||||||
|
steps:
|
||||||
|
- uses: actions/checkout@v4
|
||||||
|
with:
|
||||||
|
ref: ${{inputs.ref}}
|
||||||
|
- name: download racket lib
|
||||||
|
uses: actions/download-artifact@v4
|
||||||
|
with:
|
||||||
|
name: racket-lib
|
||||||
|
path: scheme-libs/racket/
|
||||||
|
- name: Cache Racket dependencies
|
||||||
|
id: cache-racket-deps
|
||||||
|
uses: actions/cache@v4
|
||||||
|
with:
|
||||||
|
path: |
|
||||||
|
~/.cache/racket
|
||||||
|
~/.local/share/racket
|
||||||
|
~/Library/Racket/${{env.racket_version}}
|
||||||
|
# This isn't right because unison.zip is going to include different dates each time.
|
||||||
|
# Maybe we can unpack it and hash the contents.
|
||||||
|
key: ${{ runner.os }}-racket-${{env.racket_version}}-${{hashFiles('scheme-libs/racket/unison.zip')}}
|
||||||
|
- uses: Bogdanp/setup-racket@v1.11
|
||||||
|
with:
|
||||||
|
architecture: "x64"
|
||||||
|
distribution: "full"
|
||||||
|
variant: "CS"
|
||||||
|
version: ${{env.racket_version}}
|
||||||
|
- uses: awalsh128/cache-apt-pkgs-action@latest
|
||||||
|
if: runner.os == 'Linux'
|
||||||
|
with:
|
||||||
|
packages: libb2-dev
|
||||||
|
version: 1.0 # cache key version afaik
|
||||||
|
- name: install unison racket lib
|
||||||
|
if: steps.cache-racket-deps.outputs.cache-hit != 'true'
|
||||||
|
run: raco pkg install --auto scheme-libs/racket/unison.zip
|
||||||
|
- name: build unison-runtime
|
||||||
|
run: |
|
||||||
|
raco exe --embed-dlls --orig-exe scheme-libs/racket/unison-runtime.rkt
|
||||||
|
mkdir runtime
|
||||||
|
if [[ ${{runner.os}} = 'Windows' ]]; then exe=".exe"; else exe=""; fi
|
||||||
|
raco distribute runtime scheme-libs/racket/unison-runtime$exe
|
||||||
|
ls -l runtime/
|
||||||
|
- name: upload unison-runtime
|
||||||
|
uses: actions/upload-artifact@v4
|
||||||
|
with:
|
||||||
|
name: unison-runtime-${{matrix.os}}
|
||||||
|
path: runtime/
|
||||||
|
if-no-files-found: error
|
||||||
|
|
||||||
|
bundle:
|
||||||
|
name: bundle ucm, jit, and ui
|
||||||
|
needs: [build-ucm, package-racket-lib, build-dist-unison-runtime]
|
||||||
|
runs-on: ${{matrix.os}}
|
||||||
|
strategy:
|
||||||
|
fail-fast: false
|
||||||
|
matrix:
|
||||||
|
os: [ubuntu-20.04, macos-12, windows-2019]
|
||||||
|
steps:
|
||||||
|
- name: set up environment
|
||||||
|
run: |
|
||||||
|
staging_dir="${RUNNER_TEMP//\\//}/ucm-staging"
|
||||||
|
artifact_os="$(echo $RUNNER_OS | tr '[:upper:]' '[:lower:]')"
|
||||||
|
echo "staging_dir=$staging_dir" >> $GITHUB_ENV
|
||||||
|
echo "artifact_os=$artifact_os" >> $GITHUB_ENV
|
||||||
|
- name: download ucm
|
||||||
|
uses: actions/download-artifact@v4
|
||||||
|
with:
|
||||||
|
name: unison-${{matrix.os}}
|
||||||
|
path: ${{env.staging_dir}}/unison/
|
||||||
|
- name: restore permissions on ucm
|
||||||
|
run: chmod +x ${{env.staging_dir}}/unison/unison
|
||||||
|
- name: download racket lib
|
||||||
|
uses: actions/download-artifact@v4
|
||||||
|
with:
|
||||||
|
name: racket-lib
|
||||||
|
path: ${{env.staging_dir}}/racket/
|
||||||
|
- name: download unison-runtime
|
||||||
|
uses: actions/download-artifact@v4
|
||||||
|
with:
|
||||||
|
name: unison-runtime-${{matrix.os}}
|
||||||
|
path: ${{env.staging_dir}}/runtime
|
||||||
|
- name: restore permissions on unison-runtime
|
||||||
|
# here we have the `if:` not because of the missing .exe on Windows,
|
||||||
|
# nor the lack of need to chmod, but because /runtime/bin/ probably doesn't exist
|
||||||
|
# due to differences in `raco distribute` on Windows vs macOS and Linux.
|
||||||
|
if: runner.os != 'Windows'
|
||||||
|
run: chmod +x ${{env.staging_dir}}/runtime/bin/unison-runtime
|
||||||
|
- name: download latest unison-local-ui
|
||||||
|
run: |
|
||||||
|
curl -L -o /tmp/unisonLocal.zip \
|
||||||
|
https://github.com/unisonweb/unison-local-ui/releases/download/latest/unisonLocal.zip
|
||||||
|
unzip -d ${{env.staging_dir}}/ui /tmp/unisonLocal.zip
|
||||||
|
- name: create startup script (non-Windows)
|
||||||
|
if: runner.os != 'Windows'
|
||||||
|
uses: 1arp/create-a-file-action@0.4.4
|
||||||
|
with:
|
||||||
|
path: ${{env.staging_dir}}
|
||||||
|
file: ucm
|
||||||
|
content: |
|
||||||
|
#!/bin/bash
|
||||||
|
$(dirname "$0")/unison/unison --runtime-path $(dirname "$0")/runtime/bin/unison-runtime "$@"
|
||||||
|
- name: create startup script (Windows)
|
||||||
|
if: runner.os == 'Windows'
|
||||||
|
uses: 1arp/create-a-file-action@0.4.4
|
||||||
|
with:
|
||||||
|
path: ${{env.staging_dir}}
|
||||||
|
file: ucm.cmd
|
||||||
|
content: |
|
||||||
|
@echo off
|
||||||
|
"%~dp0unison\unison.exe" --runtime-path "%~dp0runtime\unison-runtime.exe" %*
|
||||||
|
- name: package everything together
|
||||||
|
run: |
|
||||||
|
if [[ ${{runner.os}} = 'Windows' ]]; then
|
||||||
|
artifact_archive=ucm-${{env.artifact_os}}.zip
|
||||||
|
7z a -r -tzip ${artifact_archive} ${{env.staging_dir}}/*
|
||||||
|
else
|
||||||
|
chmod +x ${{env.staging_dir}}/ucm
|
||||||
|
artifact_archive=ucm-${{env.artifact_os}}.tar.gz
|
||||||
|
tar -c -z -f ${artifact_archive} -C ${{env.staging_dir}} .
|
||||||
|
fi
|
||||||
|
echo "artifact_archive=${artifact_archive}" >> $GITHUB_ENV
|
||||||
|
- name: upload artifact
|
||||||
|
uses: actions/upload-artifact@v4
|
||||||
|
with:
|
||||||
|
name: bundle-${{env.artifact_os}}
|
||||||
|
path: ${{env.artifact_archive}}
|
||||||
|
if-no-files-found: error
|
9
.github/workflows/ci.md
vendored
9
.github/workflows/ci.md
vendored
@ -24,15 +24,6 @@ Some cached directories:
|
|||||||
`jit_generator_os: ubuntu-20.04`
|
`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.
|
- 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:
|
### 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.
|
One reason for this change is to reduce the CI time for commits that only change docs, or yaml or other uninteresting things.
|
||||||
|
37
.github/workflows/ci.yaml
vendored
37
.github/workflows/ci.yaml
vendored
@ -21,7 +21,7 @@ env:
|
|||||||
ormolu_version: "0.5.2.0"
|
ormolu_version: "0.5.2.0"
|
||||||
racket_version: "8.7"
|
racket_version: "8.7"
|
||||||
ucm_local_bin: "ucm-local-bin"
|
ucm_local_bin: "ucm-local-bin"
|
||||||
jit_version: "@unison/internal/releases/0.0.12"
|
jit_version: "@unison/internal/releases/0.0.13"
|
||||||
jit_src_scheme: "unison-jit-src/scheme-libs/racket"
|
jit_src_scheme: "unison-jit-src/scheme-libs/racket"
|
||||||
jit_dist: "unison-jit-dist"
|
jit_dist: "unison-jit-dist"
|
||||||
jit_generator_os: ubuntu-20.04
|
jit_generator_os: ubuntu-20.04
|
||||||
@ -30,15 +30,6 @@ env:
|
|||||||
# refers to all tests that depend on **/unison-src/**
|
# refers to all tests that depend on **/unison-src/**
|
||||||
unison_src_test_results: "unison-src-test-results"
|
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: 1
|
|
||||||
base-codebase-cache-key-version: 1
|
|
||||||
jit-src-cache-key-version: 1
|
|
||||||
jit-dist-cache-key-version: 1
|
|
||||||
|
|
||||||
jobs:
|
jobs:
|
||||||
ormolu:
|
ormolu:
|
||||||
runs-on: ubuntu-20.04
|
runs-on: ubuntu-20.04
|
||||||
@ -59,7 +50,7 @@ jobs:
|
|||||||
mode: inplace
|
mode: inplace
|
||||||
pattern: ${{ steps.changed-files.outputs.all_changed_files }}
|
pattern: ${{ steps.changed-files.outputs.all_changed_files }}
|
||||||
- name: apply formatting changes
|
- name: apply formatting changes
|
||||||
uses: stefanzweifel/git-auto-commit-action@v4
|
uses: stefanzweifel/git-auto-commit-action@v5
|
||||||
# Only try to commit formatting changes if we're running within the repo containing the PR,
|
# Only try to commit formatting changes if we're running within the repo containing the PR,
|
||||||
# and not on a protected branch.
|
# and not on a protected branch.
|
||||||
# The job doesn't have permission to push back to contributor forks on contributor PRs.
|
# The job doesn't have permission to push back to contributor forks on contributor PRs.
|
||||||
@ -105,25 +96,25 @@ jobs:
|
|||||||
uses: actions/cache@v4
|
uses: actions/cache@v4
|
||||||
with:
|
with:
|
||||||
path: ${{env.ucm_local_bin}}
|
path: ${{env.ucm_local_bin}}
|
||||||
key: ucm-${{env.ucm-binaries-cache-key-version}}_${{ matrix.os }}-${{ hashFiles('**/stack.yaml', '**/package.yaml', '**/*.hs')}}
|
key: ucm-${{ matrix.os }}-${{ hashFiles('**/stack.yaml', '**/package.yaml', '**/*.hs')}}
|
||||||
|
|
||||||
- name: cache unison-src test results
|
- name: cache unison-src test results
|
||||||
id: cache-unison-src-test-results
|
id: cache-unison-src-test-results
|
||||||
uses: actions/cache@v4
|
uses: actions/cache@v4
|
||||||
with:
|
with:
|
||||||
path: ${{env.unison_src_test_results}}
|
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/**') }}
|
key: unison-src-test-results-${{ matrix.os }}-${{ hashFiles('**/ci.yaml', '**/stack.yaml', '**/package.yaml', '**/*.hs')}}-${{ hashFiles('**/unison-src/**') }}
|
||||||
|
|
||||||
- name: restore stack caches
|
- name: restore stack caches
|
||||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||||
id: restore-stack-caches
|
id: restore-stack-caches
|
||||||
uses: ./.github/workflows/actions/restore-stack-cache
|
uses: unisonweb/actions/stack/cache/restore@main
|
||||||
with:
|
with:
|
||||||
cache-prefix: ci${{env.stack-cache-key-version}}
|
cache-prefix: ci
|
||||||
|
|
||||||
- name: install stack
|
- name: install stack
|
||||||
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
if: steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||||
uses: ./.github/workflows/actions/install-stack
|
uses: unisonweb/actions/stack/install@main
|
||||||
|
|
||||||
# One of the transcripts fails if the user's git name hasn't been set.
|
# One of the transcripts fails if the user's git name hasn't been set.
|
||||||
## (Which transcript? -AI)
|
## (Which transcript? -AI)
|
||||||
@ -227,7 +218,7 @@ jobs:
|
|||||||
with:
|
with:
|
||||||
path: ${{ env.base-codebase }}
|
path: ${{ env.base-codebase }}
|
||||||
# key = base transcript contents + sqlite schema version
|
# 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')}}.
|
key: base.unison-${{hashFiles('**/unison-src/builtin-tests/base.md', '**/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs')}}.
|
||||||
|
|
||||||
- name: create base.md codebase
|
- name: create base.md codebase
|
||||||
if: steps.cache-base-codebase.outputs.cache-hit != 'true'
|
if: steps.cache-base-codebase.outputs.cache-hit != 'true'
|
||||||
@ -261,9 +252,9 @@ jobs:
|
|||||||
!cancelled()
|
!cancelled()
|
||||||
&& steps.restore-stack-caches.outputs.cache-hit != 'true'
|
&& steps.restore-stack-caches.outputs.cache-hit != 'true'
|
||||||
&& steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
&& steps.cache-ucm-binaries.outputs.cache-hit != 'true'
|
||||||
uses: ./.github/workflows/actions/save-stack-cache
|
uses: unisonweb/actions/stack/cache/save@main
|
||||||
with:
|
with:
|
||||||
cache-prefix: ci${{env.stack-cache-key-version}}
|
cache-prefix: ci
|
||||||
|
|
||||||
generate-jit-source:
|
generate-jit-source:
|
||||||
if: always() && needs.build-ucm.result == 'success'
|
if: always() && needs.build-ucm.result == 'success'
|
||||||
@ -277,13 +268,13 @@ jobs:
|
|||||||
echo "ucm=${{ runner.temp }}/unison" >> $GITHUB_ENV
|
echo "ucm=${{ runner.temp }}/unison" >> $GITHUB_ENV
|
||||||
- uses: actions/cache@v4
|
- uses: actions/cache@v4
|
||||||
name: cache jit source
|
name: cache jit source
|
||||||
if: runner.os == 'Linux'
|
|
||||||
with:
|
with:
|
||||||
path: ${{ env.jit_src_scheme }}
|
path: ${{ env.jit_src_scheme }}
|
||||||
key: jit_src_scheme-${{env.jit-src-cache-key-version}}.racket_${{env.racket_version}}.jit_${{env.jit_version}}
|
key: jit_src_scheme-racket_${{env.racket_version}}.jit_${{env.jit_version}}-${{hashFiles('**/scheme-libs/**')}}
|
||||||
|
|
||||||
- name: check source exists
|
- name: check source exists
|
||||||
id: jit_src_exists
|
id: jit_src_exists
|
||||||
|
if: steps.cache-jit-source.outputs.cache-hit != 'true'
|
||||||
run: |
|
run: |
|
||||||
files=(data-info boot-generated simple-wrappers builtin-generated compound-wrappers)
|
files=(data-info boot-generated simple-wrappers builtin-generated compound-wrappers)
|
||||||
all_exist=true
|
all_exist=true
|
||||||
@ -396,7 +387,7 @@ jobs:
|
|||||||
uses: actions/cache@v4
|
uses: actions/cache@v4
|
||||||
with:
|
with:
|
||||||
path: ${{ env.jit_dist }}
|
path: ${{ env.jit_dist }}
|
||||||
key: jit_dist-${{env.jit-dist-cache-key-version}}.racket_${{ env.racket_version }}.jit_${{ env.jit_version }}
|
key: jit_dist-racket_${{ env.racket_version }}.jit_${{ env.jit_version }}
|
||||||
|
|
||||||
- name: Cache Racket dependencies
|
- name: Cache Racket dependencies
|
||||||
if: steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
if: steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
||||||
@ -460,7 +451,7 @@ jobs:
|
|||||||
uses: actions/cache/restore@v4
|
uses: actions/cache/restore@v4
|
||||||
with:
|
with:
|
||||||
path: ${{ env.base-codebase}}
|
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')}}.
|
key: base.unison-${{hashFiles('**/unison-src/builtin-tests/base.md', '**/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs')}}.
|
||||||
|
|
||||||
- name: jit integration test ${{ matrix.os }}
|
- name: jit integration test ${{ matrix.os }}
|
||||||
if: runner.os != 'Windows' && steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
if: runner.os != 'Windows' && steps.restore-jit-binaries.outputs.cache-hit != 'true'
|
||||||
|
19
.github/workflows/haddocks.yaml
vendored
19
.github/workflows/haddocks.yaml
vendored
@ -20,20 +20,20 @@ jobs:
|
|||||||
path: unison
|
path: unison
|
||||||
|
|
||||||
- name: restore stack caches
|
- name: restore stack caches
|
||||||
uses: ./unison/.github/workflows/actions/restore-stack-cache
|
uses: unisonweb/actions/stack/cache/restore@main
|
||||||
with:
|
with:
|
||||||
cache-prefix: haddocks
|
cache-prefix: haddocks
|
||||||
stack-yaml-dir: unison
|
stack-yaml-dir: unison
|
||||||
|
|
||||||
- name: install stack
|
- name: install stack
|
||||||
uses: ./unison/.github/workflows/actions/install-stack
|
uses: unisonweb/actions/stack/install@main
|
||||||
|
|
||||||
- name: build with haddocks
|
- name: build with haddocks
|
||||||
working-directory: unison
|
working-directory: unison
|
||||||
run: stack build --fast --haddock
|
run: stack build --fast --haddock
|
||||||
|
|
||||||
- name: save stack caches
|
- name: save stack caches
|
||||||
uses: ./unison/.github/workflows/actions/save-stack-cache
|
uses: unisonweb/actions/stack/cache/save@main
|
||||||
with:
|
with:
|
||||||
cache-prefix: haddocks
|
cache-prefix: haddocks
|
||||||
stack-yaml-dir: unison
|
stack-yaml-dir: unison
|
||||||
@ -42,11 +42,18 @@ jobs:
|
|||||||
- name: Checkout haddocks branch
|
- name: Checkout haddocks branch
|
||||||
uses: actions/checkout@v4
|
uses: actions/checkout@v4
|
||||||
with:
|
with:
|
||||||
ref: 'haddocks'
|
ref: haddocks
|
||||||
path: 'haddocks'
|
path: haddocks
|
||||||
|
|
||||||
|
# Needed for `git commit` below
|
||||||
|
- name: set git user info
|
||||||
|
working-directory: unison
|
||||||
|
run: |
|
||||||
|
git config --global user.name "GitHub Actions"
|
||||||
|
git config --global user.email "actions@github.com"
|
||||||
|
|
||||||
- name: Copy haddocks
|
- name: Copy haddocks
|
||||||
working-directory: 'unison'
|
working-directory: unison
|
||||||
run: |
|
run: |
|
||||||
docs_root="$(stack path --local-doc-root)"
|
docs_root="$(stack path --local-doc-root)"
|
||||||
# Erase any stale files
|
# Erase any stale files
|
||||||
|
30
.github/workflows/pre-release.yaml
vendored
30
.github/workflows/pre-release.yaml
vendored
@ -1,18 +1,25 @@
|
|||||||
name: "pre-release"
|
name: pre-release
|
||||||
|
run-name: pre-release ${{github.ref_name}}
|
||||||
|
|
||||||
defaults:
|
defaults:
|
||||||
run:
|
run:
|
||||||
shell: bash
|
shell: bash
|
||||||
|
|
||||||
on:
|
on:
|
||||||
|
# run on each merge to `trunk`
|
||||||
workflow_run:
|
workflow_run:
|
||||||
workflows: ["CI"]
|
workflows: ["CI"]
|
||||||
branches: [ trunk ]
|
branches: [trunk]
|
||||||
types:
|
types:
|
||||||
- completed
|
- completed
|
||||||
|
|
||||||
|
# run manually
|
||||||
|
workflow_dispatch:
|
||||||
|
|
||||||
jobs:
|
jobs:
|
||||||
build-ucm:
|
bundle-ucm:
|
||||||
uses: ./.github/workflows/build-optimized-ucm.yaml
|
name: build and bundle ucm
|
||||||
|
uses: ./.github/workflows/bundle-ucm.yaml
|
||||||
with:
|
with:
|
||||||
ref: ${{ github.ref }}
|
ref: ${{ github.ref }}
|
||||||
|
|
||||||
@ -20,23 +27,26 @@ jobs:
|
|||||||
name: create release
|
name: create release
|
||||||
runs-on: ubuntu-20.04
|
runs-on: ubuntu-20.04
|
||||||
needs:
|
needs:
|
||||||
- build-ucm
|
- bundle-ucm
|
||||||
|
|
||||||
steps:
|
steps:
|
||||||
- name: make download dir
|
- name: make download dir
|
||||||
run: mkdir /tmp/ucm
|
run: mkdir /tmp/ucm
|
||||||
|
|
||||||
- name: "download artifacts"
|
- name: "download artifacts"
|
||||||
uses: actions/download-artifact@v2
|
uses: actions/download-artifact@v4
|
||||||
with:
|
with:
|
||||||
path: /tmp/ucm
|
path: /tmp/ucm
|
||||||
|
|
||||||
|
- name: derive release tag
|
||||||
|
run: echo "ref_name=$(echo ${{ github.ref_name }} | awk -F'/' '{print $NF}')" >> $GITHUB_ENV
|
||||||
|
|
||||||
- uses: "marvinpinto/action-automatic-releases@latest"
|
- uses: "marvinpinto/action-automatic-releases@latest"
|
||||||
with:
|
with:
|
||||||
repo_token: "${{ secrets.GITHUB_TOKEN }}"
|
repo_token: "${{ secrets.GITHUB_TOKEN }}"
|
||||||
automatic_release_tag: "trunk-build"
|
automatic_release_tag: ${{ env.ref_name }}-build
|
||||||
prerelease: true
|
prerelease: true
|
||||||
title: "Development Build"
|
title: Development Build (${{ env.ref_name }})
|
||||||
files: |
|
files: |
|
||||||
/tmp/ucm/**/*.tar.gz
|
/tmp/ucm/**/ucm-*.tar.gz
|
||||||
/tmp/ucm/**/*.zip
|
/tmp/ucm/**/ucm-*.zip
|
||||||
|
31
.github/workflows/release.yaml
vendored
31
.github/workflows/release.yaml
vendored
@ -1,6 +1,6 @@
|
|||||||
name: "release"
|
name: release
|
||||||
|
|
||||||
run-name: "release ${{inputs.version}}"
|
run-name: release ${{inputs.version}}
|
||||||
|
|
||||||
defaults:
|
defaults:
|
||||||
run:
|
run:
|
||||||
@ -13,30 +13,26 @@ on:
|
|||||||
description: Release version; e.g. `0.5.19`. We'll create tag `release/${version}`.
|
description: Release version; e.g. `0.5.19`. We'll create tag `release/${version}`.
|
||||||
required: true
|
required: true
|
||||||
type: string
|
type: string
|
||||||
target:
|
|
||||||
description: Git ref to use for this release; defaults to `trunk`.
|
|
||||||
required: true
|
|
||||||
default: trunk
|
|
||||||
type: string
|
|
||||||
|
|
||||||
jobs:
|
jobs:
|
||||||
build-ucm:
|
bundle-ucm:
|
||||||
uses: ./.github/workflows/build-optimized-ucm.yaml
|
name: build and bundle ucm
|
||||||
|
uses: ./.github/workflows/bundle-ucm.yaml
|
||||||
with:
|
with:
|
||||||
ref: release/${{inputs.version}}
|
ref: ${{github.ref}}
|
||||||
|
|
||||||
release:
|
release:
|
||||||
name: create release
|
name: create release
|
||||||
runs-on: ubuntu-20.04
|
runs-on: ubuntu-20.04
|
||||||
needs:
|
needs:
|
||||||
- build-ucm
|
- bundle-ucm
|
||||||
|
|
||||||
steps:
|
steps:
|
||||||
- name: make download dir
|
- name: make download dir
|
||||||
run: mkdir /tmp/ucm
|
run: mkdir /tmp/ucm
|
||||||
|
|
||||||
- name: "download artifacts"
|
- name: "download artifacts"
|
||||||
uses: actions/download-artifact@v2
|
uses: actions/download-artifact@v4
|
||||||
with:
|
with:
|
||||||
path: /tmp/ucm
|
path: /tmp/ucm
|
||||||
|
|
||||||
@ -44,8 +40,6 @@ jobs:
|
|||||||
env:
|
env:
|
||||||
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
|
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
|
||||||
run: |
|
run: |
|
||||||
version="${{inputs.version}}"
|
|
||||||
target="${{inputs.target}}"
|
|
||||||
prev_tag="$( \
|
prev_tag="$( \
|
||||||
gh release view \
|
gh release view \
|
||||||
--repo unisonweb/unison \
|
--repo unisonweb/unison \
|
||||||
@ -54,13 +48,12 @@ jobs:
|
|||||||
if [ -z "$prev_tag" ]; then echo "No previous release found"; exit 1; fi
|
if [ -z "$prev_tag" ]; then echo "No previous release found"; exit 1; fi
|
||||||
|
|
||||||
echo "Creating a release from these artifacts:"
|
echo "Creating a release from these artifacts:"
|
||||||
ls -R /tmp/ucm
|
ls -R /tmp/ucm/**/ucm-*.{zip,tar.gz}
|
||||||
|
|
||||||
|
gh release create "release/${{inputs.version}}" \
|
||||||
gh release create "release/${version}" \
|
|
||||||
--repo unisonweb/unison \
|
--repo unisonweb/unison \
|
||||||
--target "${target}" \
|
--target "${{github.ref}}" \
|
||||||
--generate-notes \
|
--generate-notes \
|
||||||
--notes-start-tag "${prev_tag}" \
|
--notes-start-tag "${prev_tag}" \
|
||||||
\
|
\
|
||||||
/tmp/ucm/**/*.{zip,tar.gz}
|
/tmp/ucm/**/ucm-*.{zip,tar.gz}
|
||||||
|
58
.github/workflows/update-transcripts.yaml
vendored
58
.github/workflows/update-transcripts.yaml
vendored
@ -15,53 +15,13 @@ jobs:
|
|||||||
- macOS-12
|
- macOS-12
|
||||||
steps:
|
steps:
|
||||||
- uses: actions/checkout@v4
|
- uses: actions/checkout@v4
|
||||||
- id: stackage-resolver
|
- uses: unisonweb/actions/stack/cache/restore@main
|
||||||
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 }}
|
|
||||||
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'
|
|
||||||
with:
|
with:
|
||||||
path: ~/.stack
|
# take cache from the ci job, read-only
|
||||||
key: stack-1_${{matrix.os}}-${{ steps.stackage-resolver.outputs.resolver_long }}-${{hashFiles('**/stack.yaml')}}-${{github.sha}}
|
cache-prefix: ci
|
||||||
# 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}}-
|
|
||||||
|
|
||||||
# Cache each local package's ~/.stack-work for fast incremental builds in CI.
|
|
||||||
- uses: actions/cache@v3
|
|
||||||
name: cache .stack-work
|
|
||||||
with:
|
|
||||||
path: |
|
|
||||||
**/.stack-work
|
|
||||||
# Main cache key: commit hash. This should always result in a cache miss...
|
|
||||||
# So when loading a cache we'll always fall back to the restore-keys,
|
|
||||||
# which should load the most recent cache via a prefix search on the most
|
|
||||||
# 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}}
|
|
||||||
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}}-
|
|
||||||
|
|
||||||
- name: install stack
|
- name: install stack
|
||||||
uses: ./.github/workflows/actions/install-stack
|
uses: unisonweb/actions/stack/install@main
|
||||||
|
|
||||||
# One of the transcripts fails if the user's git name hasn't been set.
|
# One of the transcripts fails if the user's git name hasn't been set.
|
||||||
- name: set git user info
|
- name: set git user info
|
||||||
@ -69,14 +29,14 @@ jobs:
|
|||||||
git config --global user.name "GitHub Actions"
|
git config --global user.name "GitHub Actions"
|
||||||
git config --global user.email "actions@github.com"
|
git config --global user.email "actions@github.com"
|
||||||
- name: build
|
- name: build
|
||||||
run: stack --no-terminal build --fast --no-run-tests --test
|
run: stack build --fast --no-run-tests --test
|
||||||
- name: round-trip-tests
|
- name: round-trip-tests
|
||||||
run: |
|
run: |
|
||||||
stack --no-terminal exec unison transcript unison-src/transcripts-round-trip/main.md
|
stack exec unison transcript unison-src/transcripts-round-trip/main.md
|
||||||
stack --no-terminal exec unison transcript unison-src/transcripts-manual/rewrites.md
|
stack exec unison transcript unison-src/transcripts-manual/rewrites.md
|
||||||
- name: transcripts
|
- name: transcripts
|
||||||
run: stack --no-terminal exec transcripts
|
run: stack exec transcripts
|
||||||
- name: save transcript changes
|
- name: save transcript changes
|
||||||
uses: stefanzweifel/git-auto-commit-action@v4
|
uses: stefanzweifel/git-auto-commit-action@v5
|
||||||
with:
|
with:
|
||||||
commit_message: rerun transcripts (reminder to rerun CI!)
|
commit_message: rerun transcripts (reminder to rerun CI!)
|
||||||
|
@ -1,9 +1,15 @@
|
|||||||
## Some things I wish I'd known about Github Actions
|
## 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 have an `env:` key defined in terms of another `env` key, but you can use `$GITHUB_ENV` to get around this.
|
||||||
|
|
||||||
You can't define a `matrix` at the top level, it has to be defined within a `job`'s `strategy`.
|
You can't define a `matrix` at the top level, it has to be defined within a `job`'s `strategy`.
|
||||||
|
|
||||||
|
`runs-on:` doesn't allow `env` for some reason.
|
||||||
|
|
||||||
|
Strings don't need quotes, unless you need to force something to be a string.
|
||||||
|
|
||||||
|
A `@ref` is always needed on a remote action.
|
||||||
|
|
||||||
Windows doesn't seem to honor the `default: run: shell:` setting, so you need to set the `shell:` on `run:` manually?
|
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.
|
Don't hesitate to do a lot with `run:` blocks aka bash scripts — at least bash is mature and well documented.
|
||||||
@ -20,6 +26,20 @@ e.g.
|
|||||||
It's not clear to me when to use `$GITHUB_OUTPUT` vs `$GITHUB_ENV`, but I have been favoring `$GITHUB_ENV` because it requires fewer characters to access.
|
It's not clear to me when to use `$GITHUB_OUTPUT` vs `$GITHUB_ENV`, but I have been favoring `$GITHUB_ENV` because it requires fewer characters to access.
|
||||||
However, it seems a little wrong.
|
However, it seems a little wrong.
|
||||||
|
|
||||||
|
### `if:`
|
||||||
|
|
||||||
|
Although the type rules don't totally make sense in Github Actions, `if:` takes a Boolean.
|
||||||
|
|
||||||
|
Therefore, I think the String interpolation in `if: ${{runner.os}} != 'Windows'` causes the whole expression to become a String, which is coerced to `true`, when you definitely didn't mean `if: true`. So don't use `${{}}` here.
|
||||||
|
|
||||||
|
### Job names
|
||||||
|
|
||||||
|
Job names will automatically get `(${{matrix.os}})` if you don't use `${{matrix.os}}` somewhere in the name.
|
||||||
|
|
||||||
|
### Windows
|
||||||
|
|
||||||
|
The whole thing with `.exe` is a mess. Unix commands typically drop and add `.exe` correctly as needed, but Github Actions (e.g. `actions/upload-artifact`?) don't.
|
||||||
|
|
||||||
### Cache
|
### 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 using the `cache` action, getting a cache hit on the primary key means you won't update the cache with any changes.
|
||||||
|
|
||||||
@ -29,6 +49,15 @@ Similarly, `save-always: true` only if a key hit means there will be nothing new
|
|||||||
|
|
||||||
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."
|
Backup restore keys: "Is there a prior run that would be worth starting out from? With the caveat that any irrelevant garbage it includes will be saved into this run too."
|
||||||
|
|
||||||
|
### Upload Artifact
|
||||||
|
|
||||||
|
I suspect on Windows it can't support paths that select a drive in a Unix-y way,
|
||||||
|
like `/c/asdf` or `/d/asdf`. It's got to be `C:/asdf` or `C:\asdf` etc.
|
||||||
|
|
||||||
|
Upload will complain if any
|
||||||
|
|
||||||
|
Upload and Download plugin versions have to match.
|
||||||
|
|
||||||
### Reusability
|
### Reusability
|
||||||
|
|
||||||
Github supports splitting off "reusable workflows" (`jobs` that can be imported into another workflow), and "composite actions" (multi-step `steps` that can be imported into another `job`).
|
Github supports splitting off "reusable workflows" (`jobs` that can be imported into another workflow), and "composite actions" (multi-step `steps` that can be imported into another `job`).
|
||||||
@ -37,6 +66,10 @@ Github supports splitting off "reusable workflows" (`jobs` that can be imported
|
|||||||
|
|
||||||
Needs to have `shell:` specified on every `run:`
|
Needs to have `shell:` specified on every `run:`
|
||||||
|
|
||||||
|
#### Reusable workflows
|
||||||
|
|
||||||
|
These have to be in `.github/workflows`, you can't organize them deeper, or elsewhere.
|
||||||
|
|
||||||
### Reference
|
### Reference
|
||||||
|
|
||||||
Default Environment Variables:
|
Default Environment Variables:
|
||||||
|
48
hie.yaml
48
hie.yaml
@ -21,18 +21,24 @@ cradle:
|
|||||||
- path: "codebase2/util-term/./"
|
- path: "codebase2/util-term/./"
|
||||||
component: "unison-util-term:lib"
|
component: "unison-util-term:lib"
|
||||||
|
|
||||||
|
- path: "lib/orphans/network-uri-orphans-sqlite/src"
|
||||||
|
component: "network-uri-orphans-sqlite:lib"
|
||||||
|
|
||||||
- path: "lib/orphans/unison-core-orphans-sqlite/src"
|
- path: "lib/orphans/unison-core-orphans-sqlite/src"
|
||||||
component: "unison-core-orphans-sqlite:lib"
|
component: "unison-core-orphans-sqlite:lib"
|
||||||
|
|
||||||
- path: "lib/unison-hash/src"
|
|
||||||
component: "unison-hash:lib"
|
|
||||||
|
|
||||||
- path: "lib/orphans/unison-hash-orphans-aeson/src"
|
- path: "lib/orphans/unison-hash-orphans-aeson/src"
|
||||||
component: "unison-hash-orphans-aeson:lib"
|
component: "unison-hash-orphans-aeson:lib"
|
||||||
|
|
||||||
- path: "lib/orphans/unison-hash-orphans-sqlite/src"
|
- path: "lib/orphans/unison-hash-orphans-sqlite/src"
|
||||||
component: "unison-hash-orphans-sqlite:lib"
|
component: "unison-hash-orphans-sqlite:lib"
|
||||||
|
|
||||||
|
- path: "lib/orphans/uuid-orphans-sqlite/src"
|
||||||
|
component: "uuid-orphans-sqlite:lib"
|
||||||
|
|
||||||
|
- path: "lib/unison-hash/src"
|
||||||
|
component: "unison-hash:lib"
|
||||||
|
|
||||||
- path: "lib/unison-hashing/src"
|
- path: "lib/unison-hashing/src"
|
||||||
component: "unison-hashing:lib"
|
component: "unison-hashing:lib"
|
||||||
|
|
||||||
@ -87,42 +93,36 @@ cradle:
|
|||||||
- path: "lib/unison-util-rope/src"
|
- path: "lib/unison-util-rope/src"
|
||||||
component: "unison-util-rope:lib"
|
component: "unison-util-rope:lib"
|
||||||
|
|
||||||
- path: "lib/orphans/uuid-orphans-sqlite/src"
|
|
||||||
component: "uuid-orphans-sqlite:lib"
|
|
||||||
|
|
||||||
- path: "parser-typechecker/src"
|
- path: "parser-typechecker/src"
|
||||||
component: "unison-parser-typechecker:lib"
|
component: "unison-parser-typechecker:lib"
|
||||||
|
|
||||||
- path: "parser-typechecker/tests"
|
- path: "parser-typechecker/tests"
|
||||||
component: "unison-parser-typechecker:test:parser-typechecker-tests"
|
component: "unison-parser-typechecker:test:parser-typechecker-tests"
|
||||||
|
|
||||||
- path: "unison-cli/src"
|
- path: "unison-cli/unison"
|
||||||
component: "unison-cli:lib"
|
component: "unison-cli:lib"
|
||||||
|
|
||||||
- path: "unison-cli/integration-tests/Suite.hs"
|
- path: "unison-cli/src"
|
||||||
component: "unison-cli:exe:cli-integration-tests"
|
component: "unison-cli:lib:unison-cli-lib"
|
||||||
|
|
||||||
- path: "unison-cli/integration-tests/IntegrationTests/ArgumentParsing.hs"
|
|
||||||
component: "unison-cli:exe:cli-integration-tests"
|
|
||||||
|
|
||||||
- path: "unison-cli/transcripts/Transcripts.hs"
|
- path: "unison-cli/transcripts/Transcripts.hs"
|
||||||
component: "unison-cli:exe:transcripts"
|
component: "unison-cli:exe:transcripts"
|
||||||
|
|
||||||
- path: "unison-cli/unison/Main.hs"
|
|
||||||
component: "unison-cli:exe:unison"
|
|
||||||
|
|
||||||
- path: "unison-cli/unison/ArgParse.hs"
|
|
||||||
component: "unison-cli:exe:unison"
|
|
||||||
|
|
||||||
- path: "unison-cli/unison/System/Path.hs"
|
|
||||||
component: "unison-cli:exe:unison"
|
|
||||||
|
|
||||||
- path: "unison-cli/unison/Version.hs"
|
|
||||||
component: "unison-cli:exe:unison"
|
|
||||||
|
|
||||||
- path: "unison-cli/tests"
|
- path: "unison-cli/tests"
|
||||||
component: "unison-cli:test:cli-tests"
|
component: "unison-cli:test:cli-tests"
|
||||||
|
|
||||||
|
- path: "unison-cli-integration/integration-tests/Suite.hs"
|
||||||
|
component: "unison-cli-integration:exe:cli-integration-tests"
|
||||||
|
|
||||||
|
- path: "unison-cli-integration/integration-tests/IntegrationTests/ArgumentParsing.hs"
|
||||||
|
component: "unison-cli-integration:exe:cli-integration-tests"
|
||||||
|
|
||||||
|
- path: "unison-cli-main/unison/Main.hs"
|
||||||
|
component: "unison-cli-main:exe:unison"
|
||||||
|
|
||||||
|
- path: "unison-cli-main/unison/Version.hs"
|
||||||
|
component: "unison-cli-main:exe:unison"
|
||||||
|
|
||||||
- path: "unison-core/src"
|
- path: "unison-core/src"
|
||||||
component: "unison-core1:lib"
|
component: "unison-core1:lib"
|
||||||
|
|
||||||
|
@ -506,6 +506,7 @@ builtinsSrc =
|
|||||||
B "Text.patterns.notCharIn" $ list char --> pat text,
|
B "Text.patterns.notCharIn" $ list char --> pat text,
|
||||||
-- Pattern.many : Pattern a -> Pattern a
|
-- Pattern.many : Pattern a -> Pattern a
|
||||||
B "Pattern.many" $ forall1 "a" (\a -> pat a --> pat a),
|
B "Pattern.many" $ forall1 "a" (\a -> pat a --> pat a),
|
||||||
|
B "Pattern.many.corrected" $ forall1 "a" (\a -> pat a --> pat a),
|
||||||
B "Pattern.replicate" $ forall1 "a" (\a -> nat --> nat --> pat a --> pat a),
|
B "Pattern.replicate" $ forall1 "a" (\a -> nat --> nat --> pat a --> pat a),
|
||||||
B "Pattern.capture" $ forall1 "a" (\a -> pat a --> pat a),
|
B "Pattern.capture" $ forall1 "a" (\a -> pat a --> pat a),
|
||||||
B "Pattern.captureAs" $ forall1 "a" (\a -> a --> pat a --> pat a),
|
B "Pattern.captureAs" $ forall1 "a" (\a -> a --> pat a --> pat a),
|
||||||
|
@ -8,7 +8,7 @@
|
|||||||
-- decl to discover constraints on the decl vars. These constraints
|
-- decl to discover constraints on the decl vars. These constraints
|
||||||
-- are then given to a constraint solver that determines a unique kind
|
-- are then given to a constraint solver that determines a unique kind
|
||||||
-- for each type variable. Unconstrained variables are defaulted to
|
-- for each type variable. Unconstrained variables are defaulted to
|
||||||
-- kind * (just like Haskell 98). This is done by 'inferDecls'.
|
-- kind Type (just like Haskell 98). This is done by 'inferDecls'.
|
||||||
--
|
--
|
||||||
-- Afterwards, the 'SolveState' holds the kinds of all decls and we
|
-- Afterwards, the 'SolveState' holds the kinds of all decls and we
|
||||||
-- can check that type annotations in terms that may mention the
|
-- can check that type annotations in terms that may mention the
|
||||||
|
@ -8,15 +8,15 @@ where
|
|||||||
import Control.Lens (Traversal, Traversal')
|
import Control.Lens (Traversal, Traversal')
|
||||||
import Unison.KindInference.Constraint.Provenance (Provenance)
|
import Unison.KindInference.Constraint.Provenance (Provenance)
|
||||||
import Unison.KindInference.Constraint.Provenance qualified as Provenance
|
import Unison.KindInference.Constraint.Provenance qualified as Provenance
|
||||||
import Unison.KindInference.Constraint.StarProvenance (StarProvenance)
|
import Unison.KindInference.Constraint.TypeProvenance (TypeProvenance)
|
||||||
import Unison.KindInference.Constraint.StarProvenance qualified as SP
|
import Unison.KindInference.Constraint.TypeProvenance qualified as TP
|
||||||
|
|
||||||
-- | Solved constraints
|
-- | Solved constraints
|
||||||
--
|
--
|
||||||
-- These constraints are associated with unification variables during
|
-- These constraints are associated with unification variables during
|
||||||
-- kind inference.
|
-- kind inference.
|
||||||
data Constraint uv v loc
|
data Constraint uv v loc
|
||||||
= IsType (StarProvenance v loc)
|
= IsType (TypeProvenance v loc)
|
||||||
| IsAbility (Provenance v loc)
|
| IsAbility (Provenance v loc)
|
||||||
| IsArr (Provenance v loc) uv uv
|
| IsArr (Provenance v loc) uv uv
|
||||||
deriving stock (Show, Eq, Ord)
|
deriving stock (Show, Eq, Ord)
|
||||||
@ -28,7 +28,7 @@ prov ::
|
|||||||
(Provenance v loc)
|
(Provenance v loc)
|
||||||
(Provenance v loc')
|
(Provenance v loc')
|
||||||
prov f = \case
|
prov f = \case
|
||||||
IsType x -> IsType <$> SP.prov f x
|
IsType x -> IsType <$> TP.prov f x
|
||||||
IsAbility x -> IsAbility <$> f x
|
IsAbility x -> IsAbility <$> f x
|
||||||
IsArr l a b -> (\x -> IsArr x a b) <$> f l
|
IsArr l a b -> (\x -> IsArr x a b) <$> f l
|
||||||
{-# INLINE prov #-}
|
{-# INLINE prov #-}
|
||||||
|
@ -1,5 +1,5 @@
|
|||||||
module Unison.KindInference.Constraint.StarProvenance
|
module Unison.KindInference.Constraint.TypeProvenance
|
||||||
( StarProvenance (..),
|
( TypeProvenance (..),
|
||||||
prov,
|
prov,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
@ -11,15 +11,15 @@ import Unison.KindInference.Constraint.Provenance (Provenance)
|
|||||||
-- in constraint generation (in which case it will have a
|
-- in constraint generation (in which case it will have a
|
||||||
-- @Provenance@) and also in the solver through kind-defaulting on
|
-- @Provenance@) and also in the solver through kind-defaulting on
|
||||||
-- unconstrained unification variables.
|
-- unconstrained unification variables.
|
||||||
data StarProvenance v loc
|
data TypeProvenance v loc
|
||||||
= NotDefault (Provenance v loc)
|
= NotDefault (Provenance v loc)
|
||||||
| Default
|
| Default
|
||||||
deriving stock (Show, Eq, Ord)
|
deriving stock (Show, Eq, Ord)
|
||||||
|
|
||||||
prov ::
|
prov ::
|
||||||
Traversal
|
Traversal
|
||||||
(StarProvenance v loc)
|
(TypeProvenance v loc)
|
||||||
(StarProvenance v loc')
|
(TypeProvenance v loc')
|
||||||
(Provenance v loc)
|
(Provenance v loc)
|
||||||
(Provenance v loc')
|
(Provenance v loc')
|
||||||
prov f = \case
|
prov f = \case
|
@ -1,6 +1,6 @@
|
|||||||
module Unison.KindInference.Constraint.Unsolved
|
module Unison.KindInference.Constraint.Unsolved
|
||||||
( Constraint (..),
|
( Constraint (..),
|
||||||
starProv,
|
typeProv,
|
||||||
prov,
|
prov,
|
||||||
loc,
|
loc,
|
||||||
)
|
)
|
||||||
@ -14,29 +14,29 @@ import Unison.KindInference.Constraint.Provenance qualified as Provenance
|
|||||||
--
|
--
|
||||||
-- These are produced during constraint generation and given as input
|
-- These are produced during constraint generation and given as input
|
||||||
-- to the constraint solver.
|
-- to the constraint solver.
|
||||||
data Constraint uv v loc starProv
|
data Constraint uv v loc typeProv
|
||||||
= -- | An IsType constraint may arise from generation or from the
|
= -- | An IsType constraint may arise from generation or from the
|
||||||
-- solver. During generation the provenance is always a real
|
-- solver. During generation the provenance is always a real
|
||||||
-- source code location, but the solver defaults unconstrained
|
-- source code location, but the solver defaults unconstrained
|
||||||
-- kind vars to Star.
|
-- kind vars to Star.
|
||||||
IsType uv (starProv v loc)
|
IsType uv (typeProv v loc)
|
||||||
| IsArr uv (Provenance v loc) uv uv
|
| IsArr uv (Provenance v loc) uv uv
|
||||||
| IsAbility uv (Provenance v loc)
|
| IsAbility uv (Provenance v loc)
|
||||||
| Unify (Provenance v loc) uv uv
|
| Unify (Provenance v loc) uv uv
|
||||||
deriving stock (Show, Eq, Ord)
|
deriving stock (Show, Eq, Ord)
|
||||||
|
|
||||||
starProv ::
|
typeProv ::
|
||||||
Traversal
|
Traversal
|
||||||
(Constraint uv v loc prov)
|
(Constraint uv v loc prov)
|
||||||
(Constraint uv v loc prov')
|
(Constraint uv v loc prov')
|
||||||
(prov v loc)
|
(prov v loc)
|
||||||
(prov' v loc)
|
(prov' v loc)
|
||||||
starProv f = \case
|
typeProv f = \case
|
||||||
IsType x l -> IsType x <$> f l
|
IsType x l -> IsType x <$> f l
|
||||||
IsAbility x l -> pure (IsAbility x l)
|
IsAbility x l -> pure (IsAbility x l)
|
||||||
IsArr s l a b -> pure (IsArr s l a b)
|
IsArr s l a b -> pure (IsArr s l a b)
|
||||||
Unify l a b -> pure (Unify l a b)
|
Unify l a b -> pure (Unify l a b)
|
||||||
{-# INLINE starProv #-}
|
{-# INLINE typeProv #-}
|
||||||
|
|
||||||
prov ::
|
prov ::
|
||||||
Lens
|
Lens
|
||||||
|
@ -1,3 +1,5 @@
|
|||||||
|
-- | Handles generating kind constraints to be fed to the kind
|
||||||
|
-- constraint solver (found in "Unison.KindInference.Solve").
|
||||||
module Unison.KindInference.Generate
|
module Unison.KindInference.Generate
|
||||||
( typeConstraints,
|
( typeConstraints,
|
||||||
termConstraints,
|
termConstraints,
|
||||||
@ -28,40 +30,16 @@ import Unison.Term qualified as Term
|
|||||||
import Unison.Type qualified as Type
|
import Unison.Type qualified as Type
|
||||||
import Unison.Var (Type (User), Var (typed), freshIn)
|
import Unison.Var (Type (User), Var (typed), freshIn)
|
||||||
|
|
||||||
data ConstraintTree v loc
|
|
||||||
= Node [ConstraintTree v loc]
|
|
||||||
| Constraint (GeneratedConstraint v loc) (ConstraintTree v loc)
|
|
||||||
| ParentConstraint (GeneratedConstraint v loc) (ConstraintTree v loc)
|
|
||||||
| StrictOrder (ConstraintTree v loc) (ConstraintTree v loc)
|
|
||||||
|
|
||||||
newtype TreeWalk = TreeWalk (forall a. ([a] -> [a]) -> [([a] -> [a], [a] -> [a])] -> [a] -> [a])
|
--------------------------------------------------------------------------------
|
||||||
|
-- Constraints arising from Types
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
bottomUp :: TreeWalk
|
-- | Generate kind constraints arising from a given type. The given
|
||||||
bottomUp = TreeWalk \down pairs0 -> foldr (\(d, u) b -> d . u . b) id pairs0 . down
|
-- @UVar@ is constrained to have the kind of the given type.
|
||||||
|
typeConstraints :: (Var v, Ord loc) => UVar v loc -> Type.Type v loc -> Gen v loc [GeneratedConstraint v loc]
|
||||||
flatten :: TreeWalk -> ConstraintTree v loc -> [GeneratedConstraint v loc]
|
typeConstraints resultVar typ =
|
||||||
flatten (TreeWalk f) = ($ []) . flattenTop
|
flatten bottomUp <$> typeConstraintTree resultVar typ
|
||||||
where
|
|
||||||
flattenTop :: ConstraintTree v loc -> [GeneratedConstraint v loc] -> [GeneratedConstraint v loc]
|
|
||||||
flattenTop t0 =
|
|
||||||
f id [flattenRec id t0]
|
|
||||||
|
|
||||||
flattenRec ::
|
|
||||||
([GeneratedConstraint v loc] -> [GeneratedConstraint v loc]) ->
|
|
||||||
ConstraintTree v loc ->
|
|
||||||
([GeneratedConstraint v loc] -> [GeneratedConstraint v loc], [GeneratedConstraint v loc] -> [GeneratedConstraint v loc])
|
|
||||||
flattenRec down = \case
|
|
||||||
Node cts ->
|
|
||||||
let pairs = map (flattenRec id) cts
|
|
||||||
in (f down pairs, id)
|
|
||||||
Constraint c ct -> flattenRec (down . (c :)) ct
|
|
||||||
ParentConstraint c ct ->
|
|
||||||
let (down', up) = flattenRec down ct
|
|
||||||
in (down', up . (c :))
|
|
||||||
StrictOrder a b ->
|
|
||||||
let as = flattenTop a
|
|
||||||
bs = flattenTop b
|
|
||||||
in (f down [(as . bs, id)], id)
|
|
||||||
|
|
||||||
typeConstraintTree :: (Var v, Ord loc) => UVar v loc -> Type.Type v loc -> Gen v loc (ConstraintTree v loc)
|
typeConstraintTree :: (Var v, Ord loc) => UVar v loc -> Type.Type v loc -> Gen v loc (ConstraintTree v loc)
|
||||||
typeConstraintTree resultVar term@ABT.Term {annotation, out} = do
|
typeConstraintTree resultVar term@ABT.Term {annotation, out} = do
|
||||||
@ -130,11 +108,6 @@ typeConstraintTree resultVar term@ABT.Term {annotation, out} = do
|
|||||||
effConstraints <- typeConstraintTree effKind eff
|
effConstraints <- typeConstraintTree effKind eff
|
||||||
pure $ ParentConstraint (IsAbility effKind (Provenance EffectsList $ ABT.annotation eff)) effConstraints
|
pure $ ParentConstraint (IsAbility effKind (Provenance EffectsList $ ABT.annotation eff)) effConstraints
|
||||||
|
|
||||||
-- | Generate kind constraints arising from a given type. The given
|
|
||||||
-- @UVar@ is constrained to have the kind of the given type.
|
|
||||||
typeConstraints :: (Var v, Ord loc) => UVar v loc -> Type.Type v loc -> Gen v loc [GeneratedConstraint v loc]
|
|
||||||
typeConstraints resultVar typ =
|
|
||||||
flatten bottomUp <$> typeConstraintTree resultVar typ
|
|
||||||
|
|
||||||
handleIntroOuter :: Var v => v -> loc -> (GeneratedConstraint v loc -> Gen v loc r) -> Gen v loc r
|
handleIntroOuter :: Var v => v -> loc -> (GeneratedConstraint v loc -> Gen v loc r) -> Gen v loc r
|
||||||
handleIntroOuter v loc k = do
|
handleIntroOuter v loc k = do
|
||||||
@ -146,6 +119,29 @@ handleIntroOuter v loc k = do
|
|||||||
Just a -> pure a
|
Just a -> pure a
|
||||||
k (Unify (Provenance ScopeReference loc) new orig)
|
k (Unify (Provenance ScopeReference loc) new orig)
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Constraints arising from Type annotations
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Check that all annotations in a term are well-kinded
|
||||||
|
termConstraints :: forall v loc. (Var v, Ord loc) => Term.Term v loc -> Gen v loc [GeneratedConstraint v loc]
|
||||||
|
termConstraints x = flatten bottomUp <$> termConstraintTree x
|
||||||
|
|
||||||
|
termConstraintTree :: forall v loc. (Var v, Ord loc) => Term.Term v loc -> Gen v loc (ConstraintTree v loc)
|
||||||
|
termConstraintTree = fmap Node . dfAnns processAnn cons nil . hackyStripAnns
|
||||||
|
where
|
||||||
|
processAnn :: loc -> Type.Type v loc -> Gen v loc [ConstraintTree v loc] -> Gen v loc [ConstraintTree v loc]
|
||||||
|
processAnn ann typ mrest = do
|
||||||
|
instantiateType typ \typ gcs -> do
|
||||||
|
typKind <- freshVar typ
|
||||||
|
annConstraints <- ParentConstraint (IsType typKind (Provenance TypeAnnotation ann)) <$> typeConstraintTree typKind typ
|
||||||
|
let annConstraints' = foldr Constraint annConstraints gcs
|
||||||
|
rest <- mrest
|
||||||
|
pure (annConstraints' : rest)
|
||||||
|
cons mlhs mrhs = (++) <$> mlhs <*> mrhs
|
||||||
|
nil = pure []
|
||||||
|
|
||||||
|
|
||||||
-- | Helper for @termConstraints@ that instantiates the outermost
|
-- | Helper for @termConstraints@ that instantiates the outermost
|
||||||
-- foralls and keeps the type in scope (in the type map) while
|
-- foralls and keeps the type in scope (in the type map) while
|
||||||
-- checking lexically nested type annotations.
|
-- checking lexically nested type annotations.
|
||||||
@ -165,24 +161,6 @@ instantiateType type0 k =
|
|||||||
t -> k t (reverse acc)
|
t -> k t (reverse acc)
|
||||||
in go [] type0
|
in go [] type0
|
||||||
|
|
||||||
-- | Check that all annotations in a term are well-kinded
|
|
||||||
termConstraints :: forall v loc. (Var v, Ord loc) => Term.Term v loc -> Gen v loc [GeneratedConstraint v loc]
|
|
||||||
termConstraints x = flatten bottomUp <$> termConstraintTree x
|
|
||||||
|
|
||||||
termConstraintTree :: forall v loc. (Var v, Ord loc) => Term.Term v loc -> Gen v loc (ConstraintTree v loc)
|
|
||||||
termConstraintTree = fmap Node . dfAnns processAnn cons nil . hackyStripAnns
|
|
||||||
where
|
|
||||||
processAnn :: loc -> Type.Type v loc -> Gen v loc [ConstraintTree v loc] -> Gen v loc [ConstraintTree v loc]
|
|
||||||
processAnn ann typ mrest = do
|
|
||||||
instantiateType typ \typ gcs -> do
|
|
||||||
typKind <- freshVar typ
|
|
||||||
annConstraints <- ParentConstraint (IsType typKind (Provenance TypeAnnotation ann)) <$> typeConstraintTree typKind typ
|
|
||||||
let annConstraints' = foldr Constraint annConstraints gcs
|
|
||||||
rest <- mrest
|
|
||||||
pure (annConstraints' : rest)
|
|
||||||
cons mlhs mrhs = (++) <$> mlhs <*> mrhs
|
|
||||||
nil = pure []
|
|
||||||
|
|
||||||
-- | Process type annotations depth-first. Allows processing
|
-- | Process type annotations depth-first. Allows processing
|
||||||
-- annotations with lexical scoping.
|
-- annotations with lexical scoping.
|
||||||
dfAnns :: (loc -> Type.Type v loc -> b -> b) -> (b -> b -> b) -> b -> Term.Term v loc -> b
|
dfAnns :: (loc -> Type.Type v loc -> b -> b) -> (b -> b -> b) -> b -> Term.Term v loc -> b
|
||||||
@ -222,6 +200,10 @@ hackyStripAnns =
|
|||||||
Term.Ann trm _typ -> trm
|
Term.Ann trm _typ -> trm
|
||||||
t -> ABT.tm ann t
|
t -> ABT.tm ann t
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Constraints arising from Decls
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- | Generate kind constraints for a mutally recursive component of
|
-- | Generate kind constraints for a mutally recursive component of
|
||||||
-- decls
|
-- decls
|
||||||
declComponentConstraints ::
|
declComponentConstraints ::
|
||||||
@ -345,6 +327,12 @@ withInstantiatedConstructorType declType tyParams0 constructorType0 k =
|
|||||||
pure (Unify (Provenance DeclDefinition (ABT.annotation typ)) x tp)
|
pure (Unify (Provenance DeclDefinition (ABT.annotation typ)) x tp)
|
||||||
in goForall constructorType0
|
in goForall constructorType0
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Constraints on builtins
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Constraints on language builtins, used to initialize the kind
|
||||||
|
-- inference state ('Unison.KindInference.Solve.initialState')
|
||||||
builtinConstraints :: forall v loc. (Ord loc, BuiltinAnnotation loc, Var v) => Gen v loc [GeneratedConstraint v loc]
|
builtinConstraints :: forall v loc. (Ord loc, BuiltinAnnotation loc, Var v) => Gen v loc [GeneratedConstraint v loc]
|
||||||
builtinConstraints = flatten bottomUp <$> builtinConstraintTree
|
builtinConstraints = flatten bottomUp <$> builtinConstraintTree
|
||||||
|
|
||||||
@ -417,6 +405,11 @@ builtinConstraintTree =
|
|||||||
kindVar <- pushType (t builtinAnnotation)
|
kindVar <- pushType (t builtinAnnotation)
|
||||||
foldr Constraint (Node []) <$> constrainToKind (Provenance Builtin builtinAnnotation) kindVar k
|
foldr Constraint (Node []) <$> constrainToKind (Provenance Builtin builtinAnnotation) kindVar k
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Helpers for constructing constraints
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Constrain a @UVar@ to the provided @Kind@
|
||||||
constrainToKind :: (Var v) => Provenance v loc -> UVar v loc -> Kind -> Gen v loc [GeneratedConstraint v loc]
|
constrainToKind :: (Var v) => Provenance v loc -> UVar v loc -> Kind -> Gen v loc [GeneratedConstraint v loc]
|
||||||
constrainToKind prov resultVar0 = fmap ($ []) . go resultVar0
|
constrainToKind prov resultVar0 = fmap ($ []) . go resultVar0
|
||||||
where
|
where
|
||||||
@ -438,7 +431,52 @@ data Kind = Type | Ability | Kind :-> Kind
|
|||||||
|
|
||||||
infixr 9 :->
|
infixr 9 :->
|
||||||
|
|
||||||
|
-- | Convert the 'Unison.Kind' annotation type to our internal 'Kind'
|
||||||
fromUnisonKind :: Unison.Kind -> Kind
|
fromUnisonKind :: Unison.Kind -> Kind
|
||||||
fromUnisonKind = \case
|
fromUnisonKind = \case
|
||||||
Unison.Star -> Type
|
Unison.Star -> Type
|
||||||
Unison.Arrow a b -> fromUnisonKind a :-> fromUnisonKind b
|
Unison.Arrow a b -> fromUnisonKind a :-> fromUnisonKind b
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Constraint ordering
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | The order in which constraints are generated has a great impact
|
||||||
|
-- on the error observed. To separate the concern of constraint
|
||||||
|
-- generation and constraint ordering the constraints are generated as
|
||||||
|
-- a constraint tree, and the flattening of this tree determines the
|
||||||
|
-- generated constraint order.
|
||||||
|
data ConstraintTree v loc
|
||||||
|
= Node [ConstraintTree v loc]
|
||||||
|
| Constraint (GeneratedConstraint v loc) (ConstraintTree v loc)
|
||||||
|
| ParentConstraint (GeneratedConstraint v loc) (ConstraintTree v loc)
|
||||||
|
| StrictOrder (ConstraintTree v loc) (ConstraintTree v loc)
|
||||||
|
|
||||||
|
newtype TreeWalk = TreeWalk (forall a. ([a] -> [a]) -> [([a] -> [a], [a] -> [a])] -> [a] -> [a])
|
||||||
|
|
||||||
|
bottomUp :: TreeWalk
|
||||||
|
bottomUp = TreeWalk \down pairs0 -> foldr (\(d, u) b -> d . u . b) id pairs0 . down
|
||||||
|
|
||||||
|
flatten :: TreeWalk -> ConstraintTree v loc -> [GeneratedConstraint v loc]
|
||||||
|
flatten (TreeWalk f) = ($ []) . flattenTop
|
||||||
|
where
|
||||||
|
flattenTop :: ConstraintTree v loc -> [GeneratedConstraint v loc] -> [GeneratedConstraint v loc]
|
||||||
|
flattenTop t0 =
|
||||||
|
f id [flattenRec id t0]
|
||||||
|
|
||||||
|
flattenRec ::
|
||||||
|
([GeneratedConstraint v loc] -> [GeneratedConstraint v loc]) ->
|
||||||
|
ConstraintTree v loc ->
|
||||||
|
([GeneratedConstraint v loc] -> [GeneratedConstraint v loc], [GeneratedConstraint v loc] -> [GeneratedConstraint v loc])
|
||||||
|
flattenRec down = \case
|
||||||
|
Node cts ->
|
||||||
|
let pairs = map (flattenRec id) cts
|
||||||
|
in (f down pairs, id)
|
||||||
|
Constraint c ct -> flattenRec (down . (c :)) ct
|
||||||
|
ParentConstraint c ct ->
|
||||||
|
let (down', up) = flattenRec down ct
|
||||||
|
in (down', up . (c :))
|
||||||
|
StrictOrder a b ->
|
||||||
|
let as = flattenTop a
|
||||||
|
bs = flattenTop b
|
||||||
|
in (f down [(as . bs, id)], id)
|
||||||
|
@ -25,8 +25,10 @@ import Unison.Symbol
|
|||||||
import Unison.Type qualified as T
|
import Unison.Type qualified as T
|
||||||
import Unison.Var
|
import Unison.Var
|
||||||
|
|
||||||
|
-- | A generated constraint
|
||||||
type GeneratedConstraint v loc = Constraint (UVar v loc) v loc Provenance
|
type GeneratedConstraint v loc = Constraint (UVar v loc) v loc Provenance
|
||||||
|
|
||||||
|
-- | The @Gen@ monad state
|
||||||
data GenState v loc = GenState
|
data GenState v loc = GenState
|
||||||
{ unifVars :: !(Set Symbol),
|
{ unifVars :: !(Set Symbol),
|
||||||
typeMap :: !(Map (T.Type v loc) (NonEmpty (UVar v loc))),
|
typeMap :: !(Map (T.Type v loc) (NonEmpty (UVar v loc))),
|
||||||
@ -45,6 +47,7 @@ newtype Gen v loc a = Gen
|
|||||||
)
|
)
|
||||||
via State (GenState v loc)
|
via State (GenState v loc)
|
||||||
|
|
||||||
|
-- | @Gen@ monad runner
|
||||||
run :: Gen v loc a -> GenState v loc -> (a, GenState v loc)
|
run :: Gen v loc a -> GenState v loc -> (a, GenState v loc)
|
||||||
run (Gen ma) st0 = ma st0
|
run (Gen ma) st0 = ma st0
|
||||||
|
|
||||||
@ -71,11 +74,13 @@ pushType t = do
|
|||||||
modify \st -> st {typeMap = newTypeMap}
|
modify \st -> st {typeMap = newTypeMap}
|
||||||
pure var
|
pure var
|
||||||
|
|
||||||
|
-- | Lookup the @UVar@ associated with a @Type@
|
||||||
lookupType :: Var v => T.Type v loc -> Gen v loc (Maybe (UVar v loc))
|
lookupType :: Var v => T.Type v loc -> Gen v loc (Maybe (UVar v loc))
|
||||||
lookupType t = do
|
lookupType t = do
|
||||||
GenState {typeMap} <- get
|
GenState {typeMap} <- get
|
||||||
pure (NonEmpty.head <$> Map.lookup t typeMap)
|
pure (NonEmpty.head <$> Map.lookup t typeMap)
|
||||||
|
|
||||||
|
-- | Remove a @Type@ from the context
|
||||||
popType :: Var v => T.Type v loc -> Gen v loc ()
|
popType :: Var v => T.Type v loc -> Gen v loc ()
|
||||||
popType t = do
|
popType t = do
|
||||||
modify \st -> st {typeMap = del (typeMap st)}
|
modify \st -> st {typeMap = del (typeMap st)}
|
||||||
@ -88,6 +93,7 @@ popType t = do
|
|||||||
x : xs -> Just (x :| xs)
|
x : xs -> Just (x :| xs)
|
||||||
in Map.alter f t m
|
in Map.alter f t m
|
||||||
|
|
||||||
|
-- | Helper to run an action with the given @Type@ in the context
|
||||||
scopedType :: Var v => T.Type v loc -> (UVar v loc -> Gen v loc r) -> Gen v loc r
|
scopedType :: Var v => T.Type v loc -> (UVar v loc -> Gen v loc r) -> Gen v loc r
|
||||||
scopedType t m = do
|
scopedType t m = do
|
||||||
s <- pushType t
|
s <- pushType t
|
||||||
|
@ -1,3 +1,5 @@
|
|||||||
|
-- | Handles solving kind constraints generated by
|
||||||
|
-- "Unison.KindInference.Generate".
|
||||||
module Unison.KindInference.Solve
|
module Unison.KindInference.Solve
|
||||||
( step,
|
( step,
|
||||||
verify,
|
verify,
|
||||||
@ -19,7 +21,7 @@ import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation)
|
|||||||
import Unison.Debug (DebugFlag (KindInference), shouldDebug)
|
import Unison.Debug (DebugFlag (KindInference), shouldDebug)
|
||||||
import Unison.KindInference.Constraint.Provenance (Provenance (..))
|
import Unison.KindInference.Constraint.Provenance (Provenance (..))
|
||||||
import Unison.KindInference.Constraint.Solved qualified as Solved
|
import Unison.KindInference.Constraint.Solved qualified as Solved
|
||||||
import Unison.KindInference.Constraint.StarProvenance (StarProvenance (..))
|
import Unison.KindInference.Constraint.TypeProvenance (TypeProvenance (..))
|
||||||
import Unison.KindInference.Constraint.Unsolved qualified as Unsolved
|
import Unison.KindInference.Constraint.Unsolved qualified as Unsolved
|
||||||
import Unison.KindInference.Error (ConstraintConflict (..), KindError (..), improveError)
|
import Unison.KindInference.Error (ConstraintConflict (..), KindError (..), improveError)
|
||||||
import Unison.KindInference.Generate (builtinConstraints)
|
import Unison.KindInference.Generate (builtinConstraints)
|
||||||
@ -43,10 +45,16 @@ import Unison.Syntax.TypePrinter qualified as TP
|
|||||||
import Unison.Util.Pretty qualified as P
|
import Unison.Util.Pretty qualified as P
|
||||||
import Unison.Var (Var)
|
import Unison.Var (Var)
|
||||||
|
|
||||||
type UnsolvedConstraint v loc = Unsolved.Constraint (UVar v loc) v loc StarProvenance
|
-- | Like 'GeneratedConstraint' but the provenance of @IsType@
|
||||||
|
-- constraints may be due to kind defaulting. (See 'defaultUnconstrainedVars')
|
||||||
|
type UnsolvedConstraint v loc = Unsolved.Constraint (UVar v loc) v loc TypeProvenance
|
||||||
|
|
||||||
|
-- | We feed both @UnsolvedConstraint@ and @GeneratedConstraint@ to
|
||||||
|
-- our constraint solver, so it is useful to convert
|
||||||
|
-- @GeneratedConstraint@ into @UnsolvedConstraint@ to avoid code
|
||||||
|
-- duplication.
|
||||||
_Generated :: forall v loc. Prism' (UnsolvedConstraint v loc) (GeneratedConstraint v loc)
|
_Generated :: forall v loc. Prism' (UnsolvedConstraint v loc) (GeneratedConstraint v loc)
|
||||||
_Generated = prism' (Unsolved.starProv %~ NotDefault) \case
|
_Generated = prism' (Unsolved.typeProv %~ NotDefault) \case
|
||||||
Unsolved.IsType s l -> case l of
|
Unsolved.IsType s l -> case l of
|
||||||
Default -> Nothing
|
Default -> Nothing
|
||||||
NotDefault l -> Just (Unsolved.IsType s l)
|
NotDefault l -> Just (Unsolved.IsType s l)
|
||||||
@ -54,8 +62,9 @@ _Generated = prism' (Unsolved.starProv %~ NotDefault) \case
|
|||||||
Unsolved.IsArr s l a b -> Just (Unsolved.IsArr s l a b)
|
Unsolved.IsArr s l a b -> Just (Unsolved.IsArr s l a b)
|
||||||
Unsolved.Unify l a b -> Just (Unsolved.Unify l a b)
|
Unsolved.Unify l a b -> Just (Unsolved.Unify l a b)
|
||||||
|
|
||||||
-- | Apply some generated constraints to a solve state, returning a
|
-- | This is the primary function in the exposed API. @step@ applies
|
||||||
-- kind error if detected or a new solve state.
|
-- some generated constraints to a solve state, returning a kind error
|
||||||
|
-- if detected or a new solve state.
|
||||||
step ::
|
step ::
|
||||||
(Var v, Ord loc, Show loc) =>
|
(Var v, Ord loc, Show loc) =>
|
||||||
Env ->
|
Env ->
|
||||||
@ -79,7 +88,7 @@ step e st cs =
|
|||||||
Left e -> Left e
|
Left e -> Left e
|
||||||
Right () -> Right finalState
|
Right () -> Right finalState
|
||||||
|
|
||||||
-- | Default any unconstrained vars to *
|
-- | Default any unconstrained vars to @Type@
|
||||||
defaultUnconstrainedVars :: Var v => SolveState v loc -> SolveState v loc
|
defaultUnconstrainedVars :: Var v => SolveState v loc -> SolveState v loc
|
||||||
defaultUnconstrainedVars st =
|
defaultUnconstrainedVars st =
|
||||||
let newConstraints = foldl' phi (constraints st) (newUnifVars st)
|
let newConstraints = foldl' phi (constraints st) (newUnifVars st)
|
||||||
@ -90,124 +99,12 @@ defaultUnconstrainedVars st =
|
|||||||
Just _ -> U.Canonical ecSize d
|
Just _ -> U.Canonical ecSize d
|
||||||
in st {constraints = newConstraints, newUnifVars = []}
|
in st {constraints = newConstraints, newUnifVars = []}
|
||||||
|
|
||||||
prettyConstraintD' :: Show loc => Var v => PrettyPrintEnv -> UnsolvedConstraint v loc -> P.Pretty P.ColorText
|
-- | Loop through the constraints, eliminating constraints until we
|
||||||
prettyConstraintD' ppe =
|
-- have some set that cannot be reduced. There isn't any strong reason
|
||||||
P.wrap . \case
|
-- to avoid halting at the first error -- we don't have constraints
|
||||||
Unsolved.IsType v p -> prettyUVar ppe v <> " ~ Type" <> prettyProv p
|
-- that error but may succeed with more information or anything. The
|
||||||
Unsolved.IsAbility v p -> prettyUVar ppe v <> " ~ Ability" <> prettyProv p
|
-- idea of looping was to resolve as much as possible so that the
|
||||||
Unsolved.IsArr v p a b -> prettyUVar ppe v <> " ~ " <> prettyUVar ppe a <> " -> " <> prettyUVar ppe b <> prettyProv p
|
-- error message can be as filled out as possible.
|
||||||
Unsolved.Unify p a b -> prettyUVar ppe a <> " ~ " <> prettyUVar ppe b <> prettyProv p
|
|
||||||
where
|
|
||||||
prettyProv x =
|
|
||||||
"[" <> P.string (show x) <> "]"
|
|
||||||
|
|
||||||
prettyConstraints :: Show loc => Var v => PrettyPrintEnv -> [UnsolvedConstraint v loc] -> P.Pretty P.ColorText
|
|
||||||
prettyConstraints ppe = P.sep "\n" . map (prettyConstraintD' ppe)
|
|
||||||
|
|
||||||
prettyUVar :: Var v => PrettyPrintEnv -> UVar v loc -> P.Pretty P.ColorText
|
|
||||||
prettyUVar ppe (UVar s t) = TP.pretty ppe t <> " :: " <> P.prettyVar s
|
|
||||||
|
|
||||||
tracePretty :: P.Pretty P.ColorText -> a -> a
|
|
||||||
tracePretty p = trace (P.toAnsiUnbroken p)
|
|
||||||
|
|
||||||
data OccCheckState v loc = OccCheckState
|
|
||||||
{ visitingSet :: Set (UVar v loc),
|
|
||||||
visitingStack :: [UVar v loc],
|
|
||||||
solvedSet :: Set (UVar v loc),
|
|
||||||
solvedConstraints :: ConstraintMap v loc,
|
|
||||||
kindErrors :: [KindError v loc]
|
|
||||||
}
|
|
||||||
|
|
||||||
markVisiting :: Var v => UVar v loc -> M.State (OccCheckState v loc) CycleCheck
|
|
||||||
markVisiting x = do
|
|
||||||
OccCheckState {visitingSet, visitingStack} <- M.get
|
|
||||||
case Set.member x visitingSet of
|
|
||||||
True -> do
|
|
||||||
OccCheckState {solvedConstraints} <- M.get
|
|
||||||
let loc = case U.lookupCanon x solvedConstraints of
|
|
||||||
Just (_, _, Descriptor {descriptorConstraint = Just (Solved.IsArr (Provenance _ loc) _ _)}, _) -> loc
|
|
||||||
_ -> error "cycle without IsArr constraint"
|
|
||||||
addError (CycleDetected loc x solvedConstraints)
|
|
||||||
pure Cycle
|
|
||||||
False -> do
|
|
||||||
M.modify \st ->
|
|
||||||
st
|
|
||||||
{ visitingSet = Set.insert x visitingSet,
|
|
||||||
visitingStack = x : visitingStack
|
|
||||||
}
|
|
||||||
pure NoCycle
|
|
||||||
|
|
||||||
unmarkVisiting :: Var v => UVar v loc -> M.State (OccCheckState v loc) ()
|
|
||||||
unmarkVisiting x = M.modify \st ->
|
|
||||||
st
|
|
||||||
{ visitingSet = Set.delete x (visitingSet st),
|
|
||||||
visitingStack = tail (visitingStack st),
|
|
||||||
solvedSet = Set.insert x (solvedSet st)
|
|
||||||
}
|
|
||||||
|
|
||||||
addError :: KindError v loc -> M.State (OccCheckState v loc) ()
|
|
||||||
addError ke = M.modify \st -> st {kindErrors = ke : kindErrors st}
|
|
||||||
|
|
||||||
isSolved :: Var v => UVar v loc -> M.State (OccCheckState v loc) Bool
|
|
||||||
isSolved x = do
|
|
||||||
OccCheckState {solvedSet} <- M.get
|
|
||||||
pure $ Set.member x solvedSet
|
|
||||||
|
|
||||||
data CycleCheck
|
|
||||||
= Cycle
|
|
||||||
| NoCycle
|
|
||||||
|
|
||||||
-- | occurence check and report any errors
|
|
||||||
occCheck ::
|
|
||||||
forall v loc.
|
|
||||||
Var v =>
|
|
||||||
ConstraintMap v loc ->
|
|
||||||
Either (NonEmpty (KindError v loc)) (ConstraintMap v loc)
|
|
||||||
occCheck constraints0 =
|
|
||||||
let go ::
|
|
||||||
[(UVar v loc)] ->
|
|
||||||
M.State (OccCheckState v loc) ()
|
|
||||||
go = \case
|
|
||||||
[] -> pure ()
|
|
||||||
u : us -> do
|
|
||||||
isSolved u >>= \case
|
|
||||||
True -> go us
|
|
||||||
False -> do
|
|
||||||
markVisiting u >>= \case
|
|
||||||
Cycle -> pure ()
|
|
||||||
NoCycle -> do
|
|
||||||
st@OccCheckState {solvedConstraints} <- M.get
|
|
||||||
let handleNothing = error "impossible"
|
|
||||||
handleJust _canonK ecSize d = case descriptorConstraint d of
|
|
||||||
Nothing -> ([], U.Canonical ecSize d {descriptorConstraint = Just $ Solved.IsType Default})
|
|
||||||
Just v ->
|
|
||||||
let descendants = case v of
|
|
||||||
Solved.IsType _ -> []
|
|
||||||
Solved.IsAbility _ -> []
|
|
||||||
Solved.IsArr _ a b -> [a, b]
|
|
||||||
in (descendants, U.Canonical ecSize d)
|
|
||||||
let (descendants, solvedConstraints') = U.alterF u handleNothing handleJust solvedConstraints
|
|
||||||
M.put st {solvedConstraints = solvedConstraints'}
|
|
||||||
go descendants
|
|
||||||
unmarkVisiting u
|
|
||||||
go us
|
|
||||||
|
|
||||||
OccCheckState {solvedConstraints, kindErrors} =
|
|
||||||
M.execState
|
|
||||||
(go (U.keys constraints0))
|
|
||||||
OccCheckState
|
|
||||||
{ visitingSet = Set.empty,
|
|
||||||
visitingStack = [],
|
|
||||||
solvedSet = Set.empty,
|
|
||||||
solvedConstraints = constraints0,
|
|
||||||
kindErrors = []
|
|
||||||
}
|
|
||||||
in case kindErrors of
|
|
||||||
[] -> Right solvedConstraints
|
|
||||||
e : es -> Left (e :| es)
|
|
||||||
|
|
||||||
-- | loop through the constraints, eliminating constraints until we
|
|
||||||
-- have some set that cannot be reduced
|
|
||||||
reduce ::
|
reduce ::
|
||||||
forall v loc.
|
forall v loc.
|
||||||
(Show loc, Var v, Ord loc) =>
|
(Show loc, Var v, Ord loc) =>
|
||||||
@ -224,36 +121,50 @@ reduce cs0 = dbg "reduce" cs0 (go False [])
|
|||||||
Right () -> error "impossible"
|
Right () -> error "impossible"
|
||||||
c : cs ->
|
c : cs ->
|
||||||
addConstraint c >>= \case
|
addConstraint c >>= \case
|
||||||
|
-- If an error occurs then push it back onto the unsolved
|
||||||
|
-- stack
|
||||||
Left _ -> go b (c : acc) cs
|
Left _ -> go b (c : acc) cs
|
||||||
|
-- Signal that we solved something on this pass (by passing
|
||||||
|
-- @True@) and continue
|
||||||
Right () -> go True acc cs
|
Right () -> go True acc cs
|
||||||
|
|
||||||
|
-- | tracing helper
|
||||||
dbg ::
|
dbg ::
|
||||||
forall a.
|
forall a.
|
||||||
|
-- | A hanging prefix or header
|
||||||
P.Pretty P.ColorText ->
|
P.Pretty P.ColorText ->
|
||||||
|
-- | The constraints to print
|
||||||
[GeneratedConstraint v loc] ->
|
[GeneratedConstraint v loc] ->
|
||||||
([GeneratedConstraint v loc] -> Solve v loc a) ->
|
([GeneratedConstraint v loc] -> Solve v loc a) ->
|
||||||
Solve v loc a
|
Solve v loc a
|
||||||
dbg hdr cs f =
|
dbg = traceApp \ppe cs -> prettyConstraints ppe (map (review _Generated) cs)
|
||||||
case shouldDebug KindInference of
|
|
||||||
True -> do
|
|
||||||
ppe <- asks prettyPrintEnv
|
|
||||||
tracePretty (P.hang (P.bold hdr) (prettyConstraints ppe (map (review _Generated) cs))) (f cs)
|
|
||||||
False -> f cs
|
|
||||||
|
|
||||||
|
-- | Like @dbg@, but for a single constraint
|
||||||
dbgSingle ::
|
dbgSingle ::
|
||||||
forall a.
|
forall a.
|
||||||
P.Pretty P.ColorText ->
|
P.Pretty P.ColorText ->
|
||||||
GeneratedConstraint v loc ->
|
GeneratedConstraint v loc ->
|
||||||
(GeneratedConstraint v loc -> Solve v loc a) ->
|
(GeneratedConstraint v loc -> Solve v loc a) ->
|
||||||
Solve v loc a
|
Solve v loc a
|
||||||
dbgSingle hdr c f =
|
dbgSingle = traceApp \ppe c -> prettyConstraintD' ppe (review _Generated c)
|
||||||
|
|
||||||
|
-- | A helper for @dbg*@
|
||||||
|
traceApp ::
|
||||||
|
forall a b.
|
||||||
|
(PrettyPrintEnv -> a -> P.Pretty P.ColorText) ->
|
||||||
|
P.Pretty P.ColorText ->
|
||||||
|
a ->
|
||||||
|
(a -> Solve v loc b) ->
|
||||||
|
Solve v loc b
|
||||||
|
traceApp prettyA hdr a ab =
|
||||||
case shouldDebug KindInference of
|
case shouldDebug KindInference of
|
||||||
|
False -> ab a
|
||||||
True -> do
|
True -> do
|
||||||
ppe <- asks prettyPrintEnv
|
ppe <- asks prettyPrintEnv
|
||||||
tracePretty (P.hang (P.bold hdr) (prettyConstraintD' ppe (review _Generated c))) (f c)
|
tracePretty (P.hang (P.bold hdr) (prettyA ppe a)) (ab a)
|
||||||
False -> f c
|
|
||||||
|
|
||||||
-- | Add a single constraint, returning an error if there is a
|
-- | Add a single constraint, returning an error if there is a
|
||||||
-- contradictory constraint
|
-- contradictory constraint.
|
||||||
addConstraint ::
|
addConstraint ::
|
||||||
forall v loc.
|
forall v loc.
|
||||||
Ord loc =>
|
Ord loc =>
|
||||||
@ -284,6 +195,9 @@ addConstraint constraint = do
|
|||||||
processPostAction . fmap concat =<< runExceptT ((traverse (ExceptT . addConstraint') (x : xs)))
|
processPostAction . fmap concat =<< runExceptT ((traverse (ExceptT . addConstraint') (x : xs)))
|
||||||
processPostAction =<< addConstraint' (review _Generated constraint)
|
processPostAction =<< addConstraint' (review _Generated constraint)
|
||||||
|
|
||||||
|
-- | Decompose the unsolved constraint into implied constraints,
|
||||||
|
-- returning a constraint conflict if the constraint cannot be
|
||||||
|
-- satisfied.
|
||||||
addConstraint' ::
|
addConstraint' ::
|
||||||
forall v loc.
|
forall v loc.
|
||||||
Ord loc =>
|
Ord loc =>
|
||||||
@ -291,11 +205,21 @@ addConstraint' ::
|
|||||||
UnsolvedConstraint v loc ->
|
UnsolvedConstraint v loc ->
|
||||||
Solve v loc (Either (ConstraintConflict v loc) [UnsolvedConstraint v loc])
|
Solve v loc (Either (ConstraintConflict v loc) [UnsolvedConstraint v loc])
|
||||||
addConstraint' = \case
|
addConstraint' = \case
|
||||||
|
-- @IsAbility@ and @IsType@ constraints are very straightforward,
|
||||||
|
-- they are satisfied of the constraint already exists or no
|
||||||
|
-- constraint exists.
|
||||||
Unsolved.IsAbility s p0 -> do
|
Unsolved.IsAbility s p0 -> do
|
||||||
handleConstraint s (Solved.IsAbility p0) \case
|
handleConstraint s (Solved.IsAbility p0) \case
|
||||||
Solved.IsAbility _ -> Just (Solved.IsAbility p0, [])
|
Solved.IsAbility _ -> Just (Solved.IsAbility p0, [])
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
Unsolved.IsType s p0 -> do
|
||||||
|
handleConstraint s (Solved.IsType p0) \case
|
||||||
|
Solved.IsType _ -> Just (Solved.IsType p0, [])
|
||||||
|
_ -> Nothing
|
||||||
Unsolved.IsArr s p0 a b -> do
|
Unsolved.IsArr s p0 a b -> do
|
||||||
|
-- If an @IsArr@ constraint is already present then we need to unify
|
||||||
|
-- the left and right hand sides of the input constraints and the
|
||||||
|
-- existing constraints, so we return those as implied constraints.
|
||||||
handleConstraint s (Solved.IsArr p0 a b) \case
|
handleConstraint s (Solved.IsArr p0 a b) \case
|
||||||
Solved.IsArr _p1 c d ->
|
Solved.IsArr _p1 c d ->
|
||||||
let implied =
|
let implied =
|
||||||
@ -305,18 +229,23 @@ addConstraint' = \case
|
|||||||
prov = p0
|
prov = p0
|
||||||
in Just (Solved.IsArr prov a b, implied)
|
in Just (Solved.IsArr prov a b, implied)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
Unsolved.IsType s p0 -> do
|
|
||||||
handleConstraint s (Solved.IsType p0) \case
|
|
||||||
Solved.IsType _ -> Just (Solved.IsType p0, [])
|
|
||||||
_ -> Nothing
|
|
||||||
Unsolved.Unify l a b -> Right <$> union l a b
|
Unsolved.Unify l a b -> Right <$> union l a b
|
||||||
where
|
where
|
||||||
|
-- | A helper for solving various @Is*@ constraints. In each case
|
||||||
|
-- we want to lookup any existing constraints on the constrained
|
||||||
|
-- variable. If none exist then we simply add the new constraint,
|
||||||
|
-- as it can't conflict with anything. If there is an existing
|
||||||
|
-- constraint we defer to the passed in function.
|
||||||
handleConstraint ::
|
handleConstraint ::
|
||||||
|
-- | The variable mentioned in the input constraint
|
||||||
UVar v loc ->
|
UVar v loc ->
|
||||||
|
-- | The new constraint
|
||||||
Solved.Constraint (UVar v loc) v loc ->
|
Solved.Constraint (UVar v loc) v loc ->
|
||||||
|
-- | How to handle the an existing constraint
|
||||||
( Solved.Constraint (UVar v loc) v loc ->
|
( Solved.Constraint (UVar v loc) v loc ->
|
||||||
Maybe (Solved.Constraint (UVar v loc) v loc, [UnsolvedConstraint v loc])
|
Maybe (Solved.Constraint (UVar v loc) v loc, [UnsolvedConstraint v loc])
|
||||||
) ->
|
) ->
|
||||||
|
-- | An error or a list of implied constraints
|
||||||
Solve v loc (Either (ConstraintConflict v loc) [UnsolvedConstraint v loc])
|
Solve v loc (Either (ConstraintConflict v loc) [UnsolvedConstraint v loc])
|
||||||
handleConstraint s solvedConstraint phi = do
|
handleConstraint s solvedConstraint phi = do
|
||||||
st@SolveState {constraints} <- M.get
|
st@SolveState {constraints} <- M.get
|
||||||
@ -384,6 +313,16 @@ verify st =
|
|||||||
Left e -> Left e
|
Left e -> Left e
|
||||||
Right m -> Right st {constraints = m}
|
Right m -> Right st {constraints = m}
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- @SolveState@ initialization
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
initialState :: forall v loc. (BuiltinAnnotation loc, Show loc, Ord loc, Var v) => Env -> SolveState v loc
|
||||||
|
initialState env =
|
||||||
|
let ((), finalState) = run env emptyState initializeState
|
||||||
|
in finalState
|
||||||
|
|
||||||
|
|
||||||
initializeState :: forall v loc. (BuiltinAnnotation loc, Ord loc, Show loc, Var v) => Solve v loc ()
|
initializeState :: forall v loc. (BuiltinAnnotation loc, Ord loc, Show loc, Var v) => Solve v loc ()
|
||||||
initializeState = assertGen do
|
initializeState = assertGen do
|
||||||
builtinConstraints
|
builtinConstraints
|
||||||
@ -399,10 +338,129 @@ assertGen gen = do
|
|||||||
st <- step env st cs
|
st <- step env st cs
|
||||||
verify st
|
verify st
|
||||||
case comp of
|
case comp of
|
||||||
Left _ -> error "[assertGen]: constraint failure in among builtin constraints"
|
Left _ -> error "[assertGen]: constraint failure in builtin constraints"
|
||||||
Right st -> M.put st
|
Right st -> M.put st
|
||||||
|
|
||||||
initialState :: forall v loc. (BuiltinAnnotation loc, Show loc, Ord loc, Var v) => Env -> SolveState v loc
|
--------------------------------------------------------------------------------
|
||||||
initialState env =
|
-- Occurence check and helpers
|
||||||
let ((), finalState) = run env emptyState initializeState
|
--------------------------------------------------------------------------------
|
||||||
in finalState
|
|
||||||
|
-- | occurence check and report any errors
|
||||||
|
occCheck ::
|
||||||
|
forall v loc.
|
||||||
|
Var v =>
|
||||||
|
ConstraintMap v loc ->
|
||||||
|
Either (NonEmpty (KindError v loc)) (ConstraintMap v loc)
|
||||||
|
occCheck constraints0 =
|
||||||
|
let go ::
|
||||||
|
[(UVar v loc)] ->
|
||||||
|
M.State (OccCheckState v loc) ()
|
||||||
|
go = \case
|
||||||
|
[] -> pure ()
|
||||||
|
u : us -> do
|
||||||
|
isSolved u >>= \case
|
||||||
|
True -> go us
|
||||||
|
False -> do
|
||||||
|
markVisiting u >>= \case
|
||||||
|
Cycle -> pure ()
|
||||||
|
NoCycle -> do
|
||||||
|
st@OccCheckState {solvedConstraints} <- M.get
|
||||||
|
let handleNothing = error "impossible"
|
||||||
|
handleJust _canonK ecSize d = case descriptorConstraint d of
|
||||||
|
Nothing -> ([], U.Canonical ecSize d {descriptorConstraint = Just $ Solved.IsType Default})
|
||||||
|
Just v ->
|
||||||
|
let descendants = case v of
|
||||||
|
Solved.IsType _ -> []
|
||||||
|
Solved.IsAbility _ -> []
|
||||||
|
Solved.IsArr _ a b -> [a, b]
|
||||||
|
in (descendants, U.Canonical ecSize d)
|
||||||
|
let (descendants, solvedConstraints') = U.alterF u handleNothing handleJust solvedConstraints
|
||||||
|
M.put st {solvedConstraints = solvedConstraints'}
|
||||||
|
go descendants
|
||||||
|
unmarkVisiting u
|
||||||
|
go us
|
||||||
|
|
||||||
|
OccCheckState {solvedConstraints, kindErrors} =
|
||||||
|
M.execState
|
||||||
|
(go (U.keys constraints0))
|
||||||
|
OccCheckState
|
||||||
|
{ visitingSet = Set.empty,
|
||||||
|
visitingStack = [],
|
||||||
|
solvedSet = Set.empty,
|
||||||
|
solvedConstraints = constraints0,
|
||||||
|
kindErrors = []
|
||||||
|
}
|
||||||
|
in case kindErrors of
|
||||||
|
[] -> Right solvedConstraints
|
||||||
|
e : es -> Left (e :| es)
|
||||||
|
|
||||||
|
data OccCheckState v loc = OccCheckState
|
||||||
|
{ visitingSet :: Set (UVar v loc),
|
||||||
|
visitingStack :: [UVar v loc],
|
||||||
|
solvedSet :: Set (UVar v loc),
|
||||||
|
solvedConstraints :: ConstraintMap v loc,
|
||||||
|
kindErrors :: [KindError v loc]
|
||||||
|
}
|
||||||
|
|
||||||
|
markVisiting :: Var v => UVar v loc -> M.State (OccCheckState v loc) CycleCheck
|
||||||
|
markVisiting x = do
|
||||||
|
OccCheckState {visitingSet, visitingStack} <- M.get
|
||||||
|
case Set.member x visitingSet of
|
||||||
|
True -> do
|
||||||
|
OccCheckState {solvedConstraints} <- M.get
|
||||||
|
let loc = case U.lookupCanon x solvedConstraints of
|
||||||
|
Just (_, _, Descriptor {descriptorConstraint = Just (Solved.IsArr (Provenance _ loc) _ _)}, _) -> loc
|
||||||
|
_ -> error "cycle without IsArr constraint"
|
||||||
|
addError (CycleDetected loc x solvedConstraints)
|
||||||
|
pure Cycle
|
||||||
|
False -> do
|
||||||
|
M.modify \st ->
|
||||||
|
st
|
||||||
|
{ visitingSet = Set.insert x visitingSet,
|
||||||
|
visitingStack = x : visitingStack
|
||||||
|
}
|
||||||
|
pure NoCycle
|
||||||
|
|
||||||
|
unmarkVisiting :: Var v => UVar v loc -> M.State (OccCheckState v loc) ()
|
||||||
|
unmarkVisiting x = M.modify \st ->
|
||||||
|
st
|
||||||
|
{ visitingSet = Set.delete x (visitingSet st),
|
||||||
|
visitingStack = tail (visitingStack st),
|
||||||
|
solvedSet = Set.insert x (solvedSet st)
|
||||||
|
}
|
||||||
|
|
||||||
|
addError :: KindError v loc -> M.State (OccCheckState v loc) ()
|
||||||
|
addError ke = M.modify \st -> st {kindErrors = ke : kindErrors st}
|
||||||
|
|
||||||
|
isSolved :: Var v => UVar v loc -> M.State (OccCheckState v loc) Bool
|
||||||
|
isSolved x = do
|
||||||
|
OccCheckState {solvedSet} <- M.get
|
||||||
|
pure $ Set.member x solvedSet
|
||||||
|
|
||||||
|
data CycleCheck
|
||||||
|
= Cycle
|
||||||
|
| NoCycle
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Debug output helpers
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
prettyConstraintD' :: Show loc => Var v => PrettyPrintEnv -> UnsolvedConstraint v loc -> P.Pretty P.ColorText
|
||||||
|
prettyConstraintD' ppe =
|
||||||
|
P.wrap . \case
|
||||||
|
Unsolved.IsType v p -> prettyUVar ppe v <> " ~ Type" <> prettyProv p
|
||||||
|
Unsolved.IsAbility v p -> prettyUVar ppe v <> " ~ Ability" <> prettyProv p
|
||||||
|
Unsolved.IsArr v p a b -> prettyUVar ppe v <> " ~ " <> prettyUVar ppe a <> " -> " <> prettyUVar ppe b <> prettyProv p
|
||||||
|
Unsolved.Unify p a b -> prettyUVar ppe a <> " ~ " <> prettyUVar ppe b <> prettyProv p
|
||||||
|
where
|
||||||
|
prettyProv x =
|
||||||
|
"[" <> P.string (show x) <> "]"
|
||||||
|
|
||||||
|
prettyConstraints :: Show loc => Var v => PrettyPrintEnv -> [UnsolvedConstraint v loc] -> P.Pretty P.ColorText
|
||||||
|
prettyConstraints ppe = P.sep "\n" . map (prettyConstraintD' ppe)
|
||||||
|
|
||||||
|
prettyUVar :: Var v => PrettyPrintEnv -> UVar v loc -> P.Pretty P.ColorText
|
||||||
|
prettyUVar ppe (UVar s t) = TP.pretty ppe t <> " :: " <> P.prettyVar s
|
||||||
|
|
||||||
|
tracePretty :: P.Pretty P.ColorText -> a -> a
|
||||||
|
tracePretty p = trace (P.toAnsiUnbroken p)
|
||||||
|
@ -35,6 +35,18 @@ data Env = Env {prettyPrintEnv :: PrettyPrintEnv}
|
|||||||
|
|
||||||
type ConstraintMap v loc = U.UFMap (UVar v loc) (Descriptor v loc)
|
type ConstraintMap v loc = U.UFMap (UVar v loc) (Descriptor v loc)
|
||||||
|
|
||||||
|
-- | The @SolveState@ holds all kind constraints gathered for each
|
||||||
|
-- type. For example, after processing data and effect decls the
|
||||||
|
-- @typeMap@ will hold entries for every decl, and looking up the
|
||||||
|
-- corresponding @UVar@ in @constraints@ will return its kind.
|
||||||
|
--
|
||||||
|
-- The other fields, @unifVars@ and @newUnifVars@, are relevant when
|
||||||
|
-- interleaving constraint generation with solving. Constraint
|
||||||
|
-- generation needs to create fresh unification variables, so it needs
|
||||||
|
-- the set of bound unification variables from
|
||||||
|
-- @unifVars@. @newUnifVars@ holds the uvars that are candidates for
|
||||||
|
-- kind defaulting (see
|
||||||
|
-- 'Unison.KindInference.Solve.defaultUnconstrainedVars').
|
||||||
data SolveState v loc = SolveState
|
data SolveState v loc = SolveState
|
||||||
{ unifVars :: !(Set Symbol),
|
{ unifVars :: !(Set Symbol),
|
||||||
newUnifVars :: [UVar v loc],
|
newUnifVars :: [UVar v loc],
|
||||||
@ -42,6 +54,7 @@ data SolveState v loc = SolveState
|
|||||||
typeMap :: !(Map (T.Type v loc) (NonEmpty (UVar v loc)))
|
typeMap :: !(Map (T.Type v loc) (NonEmpty (UVar v loc)))
|
||||||
}
|
}
|
||||||
|
|
||||||
|
-- | Constraints associated with a unification variable
|
||||||
data Descriptor v loc = Descriptor
|
data Descriptor v loc = Descriptor
|
||||||
{ descriptorConstraint :: Maybe (Constraint (UVar v loc) v loc)
|
{ descriptorConstraint :: Maybe (Constraint (UVar v loc) v loc)
|
||||||
}
|
}
|
||||||
@ -57,6 +70,7 @@ newtype Solve v loc a = Solve {unSolve :: Env -> SolveState v loc -> (a, SolveSt
|
|||||||
)
|
)
|
||||||
via M.ReaderT Env (M.State (SolveState v loc))
|
via M.ReaderT Env (M.State (SolveState v loc))
|
||||||
|
|
||||||
|
-- | Helper for inteleaving constraint generation and solving
|
||||||
genStateL :: Lens' (SolveState v loc) (Gen.GenState v loc)
|
genStateL :: Lens' (SolveState v loc) (Gen.GenState v loc)
|
||||||
genStateL f st =
|
genStateL f st =
|
||||||
( \genState ->
|
( \genState ->
|
||||||
@ -72,6 +86,7 @@ genStateL f st =
|
|||||||
newVars = []
|
newVars = []
|
||||||
}
|
}
|
||||||
|
|
||||||
|
-- | Interleave constraint generation into constraint solving
|
||||||
runGen :: Var v => Gen v loc a -> Solve v loc a
|
runGen :: Var v => Gen v loc a -> Solve v loc a
|
||||||
runGen gena = do
|
runGen gena = do
|
||||||
st <- M.get
|
st <- M.get
|
||||||
@ -85,15 +100,20 @@ runGen gena = do
|
|||||||
M.modify \st -> st {newUnifVars = vs ++ newUnifVars st}
|
M.modify \st -> st {newUnifVars = vs ++ newUnifVars st}
|
||||||
pure cs
|
pure cs
|
||||||
|
|
||||||
|
-- | Add a unification variable to the constarint mapping with no
|
||||||
|
-- constraints. This is done on uvars created during constraint
|
||||||
|
-- generation to initialize the new uvars (see 'runGen').
|
||||||
addUnconstrainedVar :: Var v => UVar v loc -> Solve v loc ()
|
addUnconstrainedVar :: Var v => UVar v loc -> Solve v loc ()
|
||||||
addUnconstrainedVar uvar = do
|
addUnconstrainedVar uvar = do
|
||||||
st@SolveState {constraints} <- M.get
|
st@SolveState {constraints} <- M.get
|
||||||
let constraints' = U.insert uvar Descriptor {descriptorConstraint = Nothing} constraints
|
let constraints' = U.insert uvar Descriptor {descriptorConstraint = Nothing} constraints
|
||||||
M.put st {constraints = constraints'}
|
M.put st {constraints = constraints'}
|
||||||
|
|
||||||
|
-- | Runner for the @Solve@ monad
|
||||||
run :: Env -> SolveState v loc -> Solve v loc a -> (a, SolveState v loc)
|
run :: Env -> SolveState v loc -> Solve v loc a -> (a, SolveState v loc)
|
||||||
run e st action = unSolve action e st
|
run e st action = unSolve action e st
|
||||||
|
|
||||||
|
-- | Initial solve state
|
||||||
emptyState :: SolveState v loc
|
emptyState :: SolveState v loc
|
||||||
emptyState =
|
emptyState =
|
||||||
SolveState
|
SolveState
|
||||||
@ -103,6 +123,7 @@ emptyState =
|
|||||||
typeMap = M.empty
|
typeMap = M.empty
|
||||||
}
|
}
|
||||||
|
|
||||||
|
-- | Lookup the constraints associated with a unification variable
|
||||||
find :: Var v => UVar v loc -> Solve v loc (Maybe (Constraint (UVar v loc) v loc))
|
find :: Var v => UVar v loc -> Solve v loc (Maybe (Constraint (UVar v loc) v loc))
|
||||||
find k = do
|
find k = do
|
||||||
st@SolveState {constraints} <- M.get
|
st@SolveState {constraints} <- M.get
|
||||||
|
@ -3103,7 +3103,9 @@ declareForeigns = do
|
|||||||
_ -> die "Text.patterns.notCharIn: non-character closure"
|
_ -> die "Text.patterns.notCharIn: non-character closure"
|
||||||
evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs
|
evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs
|
||||||
declareForeign Untracked "Pattern.many" boxDirect . mkForeign $
|
declareForeign Untracked "Pattern.many" boxDirect . mkForeign $
|
||||||
\(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many p
|
\(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many False p
|
||||||
|
declareForeign Untracked "Pattern.many.corrected" boxDirect . mkForeign $
|
||||||
|
\(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many True p
|
||||||
declareForeign Untracked "Pattern.capture" boxDirect . mkForeign $
|
declareForeign Untracked "Pattern.capture" boxDirect . mkForeign $
|
||||||
\(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p
|
\(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p
|
||||||
declareForeign Untracked "Pattern.captureAs" boxBoxDirect . mkForeign $
|
declareForeign Untracked "Pattern.captureAs" boxBoxDirect . mkForeign $
|
||||||
|
@ -363,6 +363,7 @@ performRehash rgrp0 ctx =
|
|||||||
irs = remap $ intermedRemap ctx
|
irs = remap $ intermedRemap ctx
|
||||||
f b r
|
f b r
|
||||||
| not b,
|
| not b,
|
||||||
|
r `Map.notMember` rgrp0,
|
||||||
r <- Map.findWithDefault r r frs,
|
r <- Map.findWithDefault r r frs,
|
||||||
Just r <- Map.lookup r irs =
|
Just r <- Map.lookup r irs =
|
||||||
r
|
r
|
||||||
@ -757,7 +758,9 @@ prepareEvaluation ppe tm ctx = do
|
|||||||
pure (backrefAdd rbkr ctx', rgrp, rmn)
|
pure (backrefAdd rbkr ctx', rgrp, rmn)
|
||||||
where
|
where
|
||||||
(rmn0, frem, rgrp0, rbkr) = intermediateTerm ppe ctx tm
|
(rmn0, frem, rgrp0, rbkr) = intermediateTerm ppe ctx tm
|
||||||
int b r = if b then r else toIntermed ctx r
|
int b r
|
||||||
|
| b || Map.member r rgrp0 = r
|
||||||
|
| otherwise = toIntermed ctx r
|
||||||
(ctx', rrefs, rgrp) =
|
(ctx', rrefs, rgrp) =
|
||||||
performRehash
|
performRehash
|
||||||
((fmap . overGroupLinks) int rgrp0)
|
((fmap . overGroupLinks) int rgrp0)
|
||||||
|
@ -12,7 +12,7 @@ data Pattern
|
|||||||
| Or Pattern Pattern -- left-biased choice: tries second pattern only if first fails
|
| Or Pattern Pattern -- left-biased choice: tries second pattern only if first fails
|
||||||
| Capture Pattern -- capture all the text consumed by the inner pattern, discarding its subcaptures
|
| Capture Pattern -- capture all the text consumed by the inner pattern, discarding its subcaptures
|
||||||
| CaptureAs Text Pattern -- capture the given text, discarding its subcaptures, and name the capture
|
| CaptureAs Text Pattern -- capture the given text, discarding its subcaptures, and name the capture
|
||||||
| Many Pattern -- zero or more repetitions (at least 1 can be written: Join [p, Many p])
|
| Many Bool Pattern -- zero or more repetitions (at least 1 can be written: Join [p, Many p]); boolean determines whether it's the correct version (True) or the original (False).
|
||||||
| Replicate Int Int Pattern -- m to n occurrences of a pattern, optional = 0-1
|
| Replicate Int Int Pattern -- m to n occurrences of a pattern, optional = 0-1
|
||||||
| Eof -- succeed if given the empty text, fail otherwise
|
| Eof -- succeed if given the empty text, fail otherwise
|
||||||
| Literal Text -- succeed if input starts with the given text, advance by that text
|
| Literal Text -- succeed if input starts with the given text, advance by that text
|
||||||
@ -128,7 +128,7 @@ compile (CaptureAs t p) !err !success = go
|
|||||||
success' _ rem acc0 _ = success (pushCapture t acc0) rem
|
success' _ rem acc0 _ = success (pushCapture t acc0) rem
|
||||||
compiled = compile p err' success'
|
compiled = compile p err' success'
|
||||||
go acc t = compiled acc t acc t
|
go acc t = compiled acc t acc t
|
||||||
compile (Capture (Many (Char Any))) !_ !success = \acc t -> success (pushCapture t acc) Text.empty
|
compile (Capture (Many _ (Char Any))) !_ !success = \acc t -> success (pushCapture t acc) Text.empty
|
||||||
compile (Capture c) !err !success = go
|
compile (Capture c) !err !success = go
|
||||||
where
|
where
|
||||||
err' _ _ acc0 t0 = err acc0 t0
|
err' _ _ acc0 t0 = err acc0 t0
|
||||||
@ -152,12 +152,13 @@ compile (Char cp) !err !success = go
|
|||||||
go acc t = case Text.uncons t of
|
go acc t = case Text.uncons t of
|
||||||
Just (ch, rem) | ok ch -> success acc rem
|
Just (ch, rem) | ok ch -> success acc rem
|
||||||
_ -> err acc t
|
_ -> err acc t
|
||||||
compile (Many p) !_ !success = case p of
|
compile (Many correct p) !_ !success = case p of
|
||||||
Char Any -> (\acc _ -> success acc Text.empty)
|
Char Any -> (\acc _ -> success acc Text.empty)
|
||||||
Char cp -> walker (charPatternPred cp)
|
Char cp -> walker (charPatternPred cp)
|
||||||
p -> go
|
p -> go
|
||||||
where
|
where
|
||||||
go = try "Many" (compile p) success success'
|
go | correct = try "Many" (compile p) success success'
|
||||||
|
| otherwise = compile p success success'
|
||||||
success' acc rem
|
success' acc rem
|
||||||
| Text.size rem == 0 = success acc rem
|
| Text.size rem == 0 = success acc rem
|
||||||
| otherwise = go acc rem
|
| otherwise = go acc rem
|
||||||
|
@ -114,12 +114,12 @@ test =
|
|||||||
expect' (P.run (P.Char (P.CharSet "0123")) "3ab" == Just ([], "ab"))
|
expect' (P.run (P.Char (P.CharSet "0123")) "3ab" == Just ([], "ab"))
|
||||||
expect' (P.run (P.Char (P.Not (P.CharSet "0123"))) "a3b" == Just ([], "3b"))
|
expect' (P.run (P.Char (P.Not (P.CharSet "0123"))) "a3b" == Just ([], "3b"))
|
||||||
expect' (P.run (P.Capture (P.Char (P.Not (P.CharSet "0123")))) "a3b" == Just (["a"], "3b"))
|
expect' (P.run (P.Capture (P.Char (P.Not (P.CharSet "0123")))) "a3b" == Just (["a"], "3b"))
|
||||||
expect' (P.run (P.Many (P.Char (P.CharSet "abcd"))) "babbababac123" == Just ([], "123"))
|
expect' (P.run (P.Many True (P.Char (P.CharSet "abcd"))) "babbababac123" == Just ([], "123"))
|
||||||
expect' (P.run (P.Capture (P.Many (P.Char (P.CharSet "abcd")))) "babbababac123" == Just (["babbababac"], "123"))
|
expect' (P.run (P.Capture (P.Many True (P.Char (P.CharSet "abcd")))) "babbababac123" == Just (["babbababac"], "123"))
|
||||||
expect' (P.run (P.Capture (P.Many (P.Char (P.CharClass P.Number)))) "012345abc" == Just (["012345"], "abc"))
|
expect' (P.run (P.Capture (P.Many True (P.Char (P.CharClass P.Number)))) "012345abc" == Just (["012345"], "abc"))
|
||||||
expect' (P.run (P.Join [P.Capture (P.Many (P.Char (P.CharClass P.Number))), P.Literal ",", P.Capture (P.Many (P.Char P.Any))]) "012345,abc" == Just (["012345", "abc"], ""))
|
expect' (P.run (P.Join [P.Capture (P.Many True (P.Char (P.CharClass P.Number))), P.Literal ",", P.Capture (P.Many True (P.Char P.Any))]) "012345,abc" == Just (["012345", "abc"], ""))
|
||||||
expect'
|
expect'
|
||||||
( P.run (P.Many (P.Join [P.Capture (P.Many (P.Char (P.CharClass P.Number))), P.Many (P.Char (P.CharClass P.Whitespace))])) "01 10 20 1123 292 110 10"
|
( P.run (P.Many True (P.Join [P.Capture (P.Many True (P.Char (P.CharClass P.Number))), P.Many True (P.Char (P.CharClass P.Whitespace))])) "01 10 20 1123 292 110 10"
|
||||||
== Just (["01", "10", "20", "1123", "292", "110", "10"], "")
|
== Just (["01", "10", "20", "1123", "292", "110", "10"], "")
|
||||||
)
|
)
|
||||||
expect' $
|
expect' $
|
||||||
|
@ -100,7 +100,7 @@ library
|
|||||||
Unison.KindInference.Constraint.Pretty
|
Unison.KindInference.Constraint.Pretty
|
||||||
Unison.KindInference.Constraint.Provenance
|
Unison.KindInference.Constraint.Provenance
|
||||||
Unison.KindInference.Constraint.Solved
|
Unison.KindInference.Constraint.Solved
|
||||||
Unison.KindInference.Constraint.StarProvenance
|
Unison.KindInference.Constraint.TypeProvenance
|
||||||
Unison.KindInference.Constraint.Unsolved
|
Unison.KindInference.Constraint.Unsolved
|
||||||
Unison.KindInference.Error
|
Unison.KindInference.Error
|
||||||
Unison.KindInference.Error.Pretty
|
Unison.KindInference.Error.Pretty
|
||||||
|
@ -54,7 +54,7 @@
|
|||||||
(let ([bs (grab-bytes)])
|
(let ([bs (grab-bytes)])
|
||||||
(match (builtin-Value.deserialize (bytes->chunked-bytes bs))
|
(match (builtin-Value.deserialize (bytes->chunked-bytes bs))
|
||||||
[(unison-data _ t (list q))
|
[(unison-data _ t (list q))
|
||||||
(= t unison-either-right:tag)
|
(= t ref-either-right:tag)
|
||||||
(apply
|
(apply
|
||||||
values
|
values
|
||||||
(unison-tuple->list (reify-value (unison-quote-val q))))]
|
(unison-tuple->list (reify-value (unison-quote-val q))))]
|
||||||
@ -67,7 +67,7 @@
|
|||||||
(define (do-evaluate)
|
(define (do-evaluate)
|
||||||
(let-values ([(code main-ref) (decode-input)])
|
(let-values ([(code main-ref) (decode-input)])
|
||||||
(add-runtime-code 'unison-main code)
|
(add-runtime-code 'unison-main code)
|
||||||
(handle [unison-exception:typelink] top-exn-handler
|
(handle [ref-exception:typelink] top-exn-handler
|
||||||
((termlink->proc main-ref))
|
((termlink->proc main-ref))
|
||||||
(data 'unit 0))))
|
(data 'unit 0))))
|
||||||
|
|
||||||
|
@ -13,38 +13,39 @@
|
|||||||
#!racket/base
|
#!racket/base
|
||||||
(provide
|
(provide
|
||||||
(all-from-out unison/data-info)
|
(all-from-out unison/data-info)
|
||||||
unison-any:typelink
|
builtin-any:typelink
|
||||||
unison-boolean:typelink
|
builtin-boolean:typelink
|
||||||
unison-bytes:typelink
|
builtin-bytes:typelink
|
||||||
unison-char:typelink
|
builtin-char:typelink
|
||||||
unison-float:typelink
|
builtin-float:typelink
|
||||||
unison-int:typelink
|
builtin-int:typelink
|
||||||
unison-nat:typelink
|
builtin-nat:typelink
|
||||||
unison-text:typelink
|
builtin-text:typelink
|
||||||
unison-code:typelink
|
builtin-code:typelink
|
||||||
unison-mvar:typelink
|
builtin-mvar:typelink
|
||||||
unison-pattern:typelink
|
builtin-pattern:typelink
|
||||||
unison-promise:typelink
|
builtin-promise:typelink
|
||||||
unison-sequence:typelink
|
builtin-sequence:typelink
|
||||||
unison-socket:typelink
|
builtin-socket:typelink
|
||||||
unison-tls:typelink
|
builtin-tls:typelink
|
||||||
unison-timespec:typelink
|
builtin-timespec:typelink
|
||||||
unison-threadid:typelink
|
builtin-threadid:typelink
|
||||||
|
builtin-value:typelink
|
||||||
|
|
||||||
unison-crypto.hashalgorithm:typelink
|
builtin-crypto.hashalgorithm:typelink
|
||||||
unison-char.class:typelink
|
builtin-char.class:typelink
|
||||||
unison-immutablearray:typelink
|
builtin-immutablearray:typelink
|
||||||
unison-immutablebytearray:typelink
|
builtin-immutablebytearray:typelink
|
||||||
unison-mutablearray:typelink
|
builtin-mutablearray:typelink
|
||||||
unison-mutablebytearray:typelink
|
builtin-mutablebytearray:typelink
|
||||||
unison-processhandle:typelink
|
builtin-processhandle:typelink
|
||||||
unison-ref.ticket:typelink
|
builtin-ref.ticket:typelink
|
||||||
unison-tls.cipher:typelink
|
builtin-tls.cipher:typelink
|
||||||
unison-tls.clientconfig:typelink
|
builtin-tls.clientconfig:typelink
|
||||||
unison-tls.privatekey:typelink
|
builtin-tls.privatekey:typelink
|
||||||
unison-tls.serverconfig:typelink
|
builtin-tls.serverconfig:typelink
|
||||||
unison-tls.signedcert:typelink
|
builtin-tls.signedcert:typelink
|
||||||
unison-tls.version:typelink
|
builtin-tls.version:typelink
|
||||||
|
|
||||||
bytevector
|
bytevector
|
||||||
bytes
|
bytes
|
||||||
@ -495,62 +496,54 @@
|
|||||||
(define (reference->termlink rf)
|
(define (reference->termlink rf)
|
||||||
(match rf
|
(match rf
|
||||||
[(unison-data _ t (list nm))
|
[(unison-data _ t (list nm))
|
||||||
#:when (= t unison-reference-builtin:tag)
|
#:when (= t ref-reference-builtin:tag)
|
||||||
(unison-termlink-builtin (chunked-string->string nm))]
|
(unison-termlink-builtin (chunked-string->string nm))]
|
||||||
[(unison-data _ t (list id))
|
[(unison-data _ t (list id))
|
||||||
#:when (= t unison-reference-derived:tag)
|
#:when (= t ref-reference-derived:tag)
|
||||||
(match id
|
(match id
|
||||||
[(unison-data _ t (list rf i))
|
[(unison-data _ t (list rf i))
|
||||||
#:when (= t unison-id-id:tag)
|
#:when (= t ref-id-id:tag)
|
||||||
(unison-termlink-derived rf i)])]))
|
(unison-termlink-derived rf i)])]))
|
||||||
|
|
||||||
(define (referent->termlink rn)
|
(define (referent->termlink rn)
|
||||||
(match rn
|
(match rn
|
||||||
[(unison-data _ t (list rf i))
|
[(unison-data _ t (list rf i))
|
||||||
#:when (= t unison-referent-con:tag)
|
#:when (= t ref-referent-con:tag)
|
||||||
(unison-termlink-con (reference->typelink rf) i)]
|
(unison-termlink-con (reference->typelink rf) i)]
|
||||||
[(unison-data _ t (list rf))
|
[(unison-data _ t (list rf))
|
||||||
#:when (= t unison-referent-def:tag)
|
#:when (= t ref-referent-def:tag)
|
||||||
(reference->termlink rf)]))
|
(reference->termlink rf)]))
|
||||||
|
|
||||||
(define (reference->typelink rf)
|
(define (reference->typelink rf)
|
||||||
(match rf
|
(match rf
|
||||||
[(unison-data _ t (list nm))
|
[(unison-data _ t (list nm))
|
||||||
#:when (= t unison-reference-builtin:tag)
|
#:when (= t ref-reference-builtin:tag)
|
||||||
(unison-typelink-builtin (chunked-string->string nm))]
|
(unison-typelink-builtin (chunked-string->string nm))]
|
||||||
[(unison-data _ t (list id))
|
[(unison-data _ t (list id))
|
||||||
#:when (= t unison-reference-derived:tag)
|
#:when (= t ref-reference-derived:tag)
|
||||||
(match id
|
(match id
|
||||||
[(unison-data _ t (list rf i))
|
[(unison-data _ t (list rf i))
|
||||||
#:when (= t unison-id-id:tag)
|
#:when (= t ref-id-id:tag)
|
||||||
(unison-typelink-derived rf i)])]))
|
(unison-typelink-derived rf i)])]))
|
||||||
|
|
||||||
(define (typelink->reference tl)
|
(define (typelink->reference tl)
|
||||||
(match tl
|
(match tl
|
||||||
[(unison-typelink-builtin nm)
|
[(unison-typelink-builtin nm)
|
||||||
(unison-reference-builtin (string->chunked-string nm))]
|
(ref-reference-builtin (string->chunked-string nm))]
|
||||||
[(unison-typelink-derived hs i)
|
[(unison-typelink-derived hs i)
|
||||||
(unison-reference-derived
|
(ref-reference-derived (ref-id-id hs i))]))
|
||||||
(unison-id-id hs i))]))
|
|
||||||
|
|
||||||
(define (termlink->referent tl)
|
(define (termlink->referent tl)
|
||||||
(match tl
|
(match tl
|
||||||
[(unison-termlink-builtin nm)
|
[(unison-termlink-builtin nm)
|
||||||
(unison-referent-def
|
(ref-referent-def
|
||||||
(unison-reference-builtin nm))]
|
(ref-reference-builtin nm))]
|
||||||
[(unison-termlink-derived rf i)
|
[(unison-termlink-derived rf i)
|
||||||
(unison-referent-def
|
(ref-referent-def
|
||||||
(unison-reference-derived
|
(ref-reference-derived
|
||||||
(unison-id-id rf i)))]
|
(ref-id-id rf i)))]
|
||||||
[(unison-termlink-con tyl i)
|
[(unison-termlink-con tyl i)
|
||||||
(unison-referent-con
|
(ref-referent-con (typelink->reference tyl) i)]))
|
||||||
(typelink->reference tyl)
|
|
||||||
i)]))
|
|
||||||
|
|
||||||
(define (list->unison-tuple l)
|
|
||||||
(foldr unison-tuple-pair unison-unit-unit l))
|
|
||||||
|
|
||||||
(define (unison-tuple . l) (list->unison-tuple l))
|
|
||||||
|
|
||||||
(define (unison-seq . l)
|
(define (unison-seq . l)
|
||||||
(vector->chunked-list (list->vector l)))
|
(vector->chunked-list (list->vector l)))
|
||||||
@ -564,13 +557,13 @@
|
|||||||
[pure (x)
|
[pure (x)
|
||||||
(match x
|
(match x
|
||||||
[(unison-data r 0 (list))
|
[(unison-data r 0 (list))
|
||||||
(eq? r unison-unit:typelink)
|
(eq? r ref-unit:typelink)
|
||||||
(display "")]
|
(display "")]
|
||||||
[else
|
[else
|
||||||
(display (describe-value x))])]
|
(display (describe-value x))])]
|
||||||
[unison-exception:typelink
|
[ref-exception:typelink
|
||||||
[0 (f)
|
[0 (f)
|
||||||
(control unison-exception:typelink k
|
(control ref-exception:typelink k
|
||||||
(let ([disp (describe-value f)])
|
(let ([disp (describe-value f)])
|
||||||
(raise (make-exn:bug "builtin.bug" disp))))]]))
|
(raise (make-exn:bug "builtin.bug" disp))))]]))
|
||||||
|
|
||||||
|
@ -106,37 +106,36 @@
|
|||||||
(or (exn:fail:contract:divide-by-zero? e)
|
(or (exn:fail:contract:divide-by-zero? e)
|
||||||
(exn:fail:contract:non-fixnum-result? e)))
|
(exn:fail:contract:non-fixnum-result? e)))
|
||||||
|
|
||||||
;; TODO Replace strings with proper type links once we have them
|
|
||||||
(define (try-eval thunk)
|
(define (try-eval thunk)
|
||||||
(with-handlers
|
(with-handlers
|
||||||
([exn:break?
|
([exn:break?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-threadkilledfailure:typelink
|
ref-threadkilledfailure:typelink
|
||||||
(string->chunked-string "thread killed")
|
(string->chunked-string "thread killed")
|
||||||
()))]
|
ref-unit-unit))]
|
||||||
[exn:io?
|
[exn:io?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-iofailure:typelink
|
ref-iofailure:typelink
|
||||||
(exception->string e) ()))]
|
(exception->string e) ref-unit-unit))]
|
||||||
[exn:arith?
|
[exn:arith?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-arithfailure:typelink
|
ref-arithfailure:typelink
|
||||||
(exception->string e)
|
(exception->string e)
|
||||||
()))]
|
ref-unit-unit))]
|
||||||
[exn:bug? (lambda (e) (exn:bug->exception e))]
|
[exn:bug? (lambda (e) (exn:bug->exception e))]
|
||||||
[exn:fail?
|
[exn:fail?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-runtimefailure:typelink
|
ref-runtimefailure:typelink
|
||||||
(exception->string e)
|
(exception->string e)
|
||||||
()))]
|
ref-unit-unit))]
|
||||||
[(lambda (x) #t)
|
[(lambda (x) #t)
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-miscfailure:typelink
|
ref-miscfailure:typelink
|
||||||
(string->chunked-string "unknown exception")
|
(exception->string e)
|
||||||
e))])
|
ref-unit-unit))])
|
||||||
(right (thunk)))))
|
(right (thunk)))))
|
||||||
|
@ -30,6 +30,9 @@
|
|||||||
|
|
||||||
chunked-string-foldMap-chunks
|
chunked-string-foldMap-chunks
|
||||||
|
|
||||||
|
unison-tuple
|
||||||
|
list->unison-tuple
|
||||||
|
|
||||||
freeze-bytevector!
|
freeze-bytevector!
|
||||||
freeze-vector!
|
freeze-vector!
|
||||||
freeze-subvector
|
freeze-subvector
|
||||||
@ -69,6 +72,7 @@
|
|||||||
build-path
|
build-path
|
||||||
path->string
|
path->string
|
||||||
match
|
match
|
||||||
|
match*
|
||||||
for/fold)
|
for/fold)
|
||||||
(string-copy! racket-string-copy!)
|
(string-copy! racket-string-copy!)
|
||||||
(bytes-append bytevector-append)
|
(bytes-append bytevector-append)
|
||||||
@ -184,12 +188,43 @@
|
|||||||
[sfx (if (<= l 10) "" "...")])
|
[sfx (if (<= l 10) "" "...")])
|
||||||
(string-append "32x" (substring s 0 10) sfx)))
|
(string-append "32x" (substring s 0 10) sfx)))
|
||||||
|
|
||||||
|
(define (describe-tuple x)
|
||||||
|
(define (format-tuple l)
|
||||||
|
(for/fold
|
||||||
|
([sep ")"]
|
||||||
|
[bits '()]
|
||||||
|
#:result (apply string-append (cons "(" bits)))
|
||||||
|
([e l])
|
||||||
|
(values ", " (list* (describe-value e) sep bits))))
|
||||||
|
|
||||||
|
(define (format-non-tuple l)
|
||||||
|
(for/fold
|
||||||
|
([result #f])
|
||||||
|
([e l])
|
||||||
|
(let ([de (describe-value e)])
|
||||||
|
(if (not result) de
|
||||||
|
(string-append "Cons (" de ") (" result ")")))))
|
||||||
|
|
||||||
|
(let rec ([acc '()] [tup x])
|
||||||
|
(match tup
|
||||||
|
[(unison-data r t (list x y))
|
||||||
|
#:when (eq? r ref-tuple:typelink)
|
||||||
|
(rec (cons x acc) y)]
|
||||||
|
[(unison-data r t (list))
|
||||||
|
#:when (eq? r ref-unit:typelink)
|
||||||
|
(format-tuple acc)]
|
||||||
|
[else
|
||||||
|
(format-non-tuple (cons tup acc))])))
|
||||||
|
|
||||||
(define (describe-value x)
|
(define (describe-value x)
|
||||||
(match x
|
(match x
|
||||||
[(unison-sum t fs)
|
[(unison-sum t fs)
|
||||||
(let ([tt (number->string t)]
|
(let ([tt (number->string t)]
|
||||||
[vs (describe-list-br fs)])
|
[vs (describe-list-br fs)])
|
||||||
(string-append "Sum " tt " " vs))]
|
(string-append "Sum " tt " " vs))]
|
||||||
|
[(unison-data r t fs)
|
||||||
|
#:when (eq? r ref-tuple:typelink)
|
||||||
|
(describe-tuple x)]
|
||||||
[(unison-data r t fs)
|
[(unison-data r t fs)
|
||||||
(let ([tt (number->string t)]
|
(let ([tt (number->string t)]
|
||||||
[rt (describe-ref r)]
|
[rt (describe-ref r)]
|
||||||
@ -258,62 +293,165 @@
|
|||||||
[else sc]))]))
|
[else sc]))]))
|
||||||
|
|
||||||
; universal-compares two lists of values lexicographically
|
; universal-compares two lists of values lexicographically
|
||||||
(define (lexico-compare ls rs)
|
(define (lexico-compare ls rs cmp-ty)
|
||||||
(let rec ([cls ls] [crs rs])
|
(let rec ([cls ls] [crs rs])
|
||||||
(cond
|
(cond
|
||||||
[(and (null? cls) (null? crs)) '=]
|
[(and (null? cls) (null? crs)) '=]
|
||||||
[else
|
[else
|
||||||
(comparisons
|
(comparisons
|
||||||
(universal-compare (car cls) (car crs))
|
(universal-compare (car cls) (car crs) cmp-ty)
|
||||||
(rec (cdr cls) (cdr crs)))])))
|
(rec (cdr cls) (cdr crs)))])))
|
||||||
|
|
||||||
(define (cmp-num l r)
|
(define ((comparison e? l?) l r)
|
||||||
(cond
|
(cond
|
||||||
[(= l r) '=]
|
[(e? l r) '=]
|
||||||
[(< l r) '<]
|
[(l? l r) '<]
|
||||||
[else '>]))
|
[else '>]))
|
||||||
|
|
||||||
(define (compare-char a b)
|
(define compare-num (comparison = <))
|
||||||
(cond
|
(define compare-char (comparison char=? char<?))
|
||||||
[(char=? a b) '=]
|
(define compare-byte (comparison = <))
|
||||||
[(char<? a b) '<]
|
(define compare-bytes (comparison bytes=? bytes<?))
|
||||||
[else '>]))
|
(define compare-string (comparison string=? string<?))
|
||||||
|
|
||||||
(define (compare-byte a b)
|
(define (compare-typelink ll rl)
|
||||||
(cond
|
(match ll
|
||||||
[(= a b) '=]
|
[(unison-typelink-builtin lnm)
|
||||||
[(< a b) '<]
|
(match rl
|
||||||
[else '>]))
|
[(unison-typelink-builtin rnm) (compare-string lnm rnm)]
|
||||||
|
[(? unison-typelink-derived?) '<])]
|
||||||
|
[(unison-typelink-derived lh i)
|
||||||
|
(match rl
|
||||||
|
[(unison-typelink-derived rh j)
|
||||||
|
(comparisons
|
||||||
|
(compare-bytes lh rh)
|
||||||
|
(compare-num i j))]
|
||||||
|
[(? unison-typelink-builtin?) '>])]))
|
||||||
|
|
||||||
(define (universal-compare l r)
|
(define (compare-termlink ll rl)
|
||||||
|
(match ll
|
||||||
|
[(unison-termlink-builtin lnm)
|
||||||
|
(match rl
|
||||||
|
[(unison-termlink-builtin rnm)
|
||||||
|
(compare-string lnm rnm)]
|
||||||
|
[else '<])]
|
||||||
|
[(unison-termlink-derived lh i)
|
||||||
|
(match rl
|
||||||
|
[(unison-termlink-derived rh j)
|
||||||
|
(comparisons
|
||||||
|
(compare-bytes lh rh)
|
||||||
|
(compare-num i j))]
|
||||||
|
[(? unison-termlink-builtin?) '>]
|
||||||
|
[else '<])]
|
||||||
|
[(unison-termlink-con lr t)
|
||||||
|
(match rl
|
||||||
|
[(unison-termlink-con rr u)
|
||||||
|
(comparisons
|
||||||
|
(compare-typelink lr rr)
|
||||||
|
(compare-num t u))]
|
||||||
|
[else '>])]))
|
||||||
|
|
||||||
|
(define (value->category v)
|
||||||
(cond
|
(cond
|
||||||
[(equal? l r) '=]
|
[(procedure? v) 0]
|
||||||
[(and (number? l) (number? r)) (if (< l r) '< '>)]
|
[(unison-closure? v) 0]
|
||||||
[(and (char? l) (char? r)) (if (char<? l r) '< '>)]
|
[(number? v) 1]
|
||||||
|
[(char? v) 1]
|
||||||
|
[(boolean? v) 1]
|
||||||
|
[(unison-data? v) 1]
|
||||||
|
[(chunked-list? v) 3]
|
||||||
|
[(chunked-string? v) 3]
|
||||||
|
[(chunked-bytes? v) 3]
|
||||||
|
[(unison-termlink? v) 3]
|
||||||
|
[(unison-typelink? v) 3]
|
||||||
|
[(bytes? v) 5]))
|
||||||
|
|
||||||
|
(define (compare-data l r cmp-ty)
|
||||||
|
(match* (l r)
|
||||||
|
[((unison-data lr lt lfs) (unison-data rr rt rfs))
|
||||||
|
(compare-data-stuff lr lt lfs rr rt rfs cmp-ty)]))
|
||||||
|
|
||||||
|
(define (compare-data-stuff lr lt lfs rr rt rfs cmp-ty)
|
||||||
|
(define new-cmp-ty (or cmp-ty (eq? lr builtin-any:typelink)))
|
||||||
|
(comparisons
|
||||||
|
(if cmp-ty (compare-typelink lr rr) '=)
|
||||||
|
(compare-num lt rt)
|
||||||
|
(compare-num (length lfs) (length rfs))
|
||||||
|
(lexico-compare lfs rfs new-cmp-ty)))
|
||||||
|
|
||||||
|
; gives links to compare values as pseudo- or actual data types.
|
||||||
|
; This is how the interpreter works, so this is an attempt to obtain
|
||||||
|
; the same ordering.
|
||||||
|
(define (pseudo-data-link v)
|
||||||
|
(cond
|
||||||
|
[(boolean? v) builtin-boolean:typelink]
|
||||||
|
[(char? v) builtin-char:typelink]
|
||||||
|
[(flonum? v) builtin-float:typelink]
|
||||||
|
[(and (number? v) (negative? v)) builtin-int:typelink]
|
||||||
|
[(number? v) builtin-nat:typelink]
|
||||||
|
[(unison-data? v) (unison-data-ref v)]))
|
||||||
|
|
||||||
|
(define (compare-proc l r cmp-ty)
|
||||||
|
(define (unpack v)
|
||||||
|
(if (procedure? v)
|
||||||
|
(values (lookup-function-link v) '())
|
||||||
|
(values
|
||||||
|
(lookup-function-link (unison-closure-code v))
|
||||||
|
(unison-closure-env v))))
|
||||||
|
|
||||||
|
(define-values (lnl envl) (unpack l))
|
||||||
|
|
||||||
|
(define-values (lnr envr) (unpack r))
|
||||||
|
|
||||||
|
(comparisons
|
||||||
|
(compare-termlink lnl lnr)
|
||||||
|
(lexico-compare envl envr cmp-ty)))
|
||||||
|
|
||||||
|
(define (compare-timespec l r)
|
||||||
|
(comparisons
|
||||||
|
(compare-num (unison-timespec-sec l) (unison-timespec-sec r))
|
||||||
|
(compare-num (unison-timespec-nsec l) (unison-timespec-nsec r))))
|
||||||
|
|
||||||
|
(define (universal-compare l r [cmp-ty #f])
|
||||||
|
(define (u-proc? v)
|
||||||
|
(or (procedure? v) (unison-closure? v)))
|
||||||
|
|
||||||
|
(cond
|
||||||
|
[(eq? l r) '=] ; optimistic equality case
|
||||||
[(and (boolean? l) (boolean? r)) (if r '< '>)]
|
[(and (boolean? l) (boolean? r)) (if r '< '>)]
|
||||||
[(and (chunked-list? l) (chunked-list? r)) (chunked-list-compare/recur l r universal-compare)]
|
[(and (char? l) (char? r)) (if (char<? l r) '< '>)]
|
||||||
|
[(and (number? l) (number? r)) (compare-num l r)]
|
||||||
|
[(and (chunked-list? l) (chunked-list? r))
|
||||||
|
(chunked-list-compare/recur l r universal-compare)]
|
||||||
[(and (chunked-string? l) (chunked-string? r))
|
[(and (chunked-string? l) (chunked-string? r))
|
||||||
(chunked-string-compare/recur l r compare-char)]
|
(chunked-string-compare/recur l r compare-char)]
|
||||||
[(and (chunked-bytes? l) (chunked-bytes? r))
|
[(and (chunked-bytes? l) (chunked-bytes? r))
|
||||||
(chunked-bytes-compare/recur l r compare-byte)]
|
(chunked-bytes-compare/recur l r compare-byte)]
|
||||||
[(and (bytes? l) (bytes? r))
|
[(and (unison-data? l) (unison-data? r)) (compare-data l r cmp-ty)]
|
||||||
(cond
|
[(and (bytes? r) (bytes? r)) (compare-bytes l r)]
|
||||||
[(bytes=? l r) '=]
|
[(and (u-proc? l) (u-proc? r)) (compare-proc l r)]
|
||||||
[(bytes<? l r) '<]
|
[(and (unison-termlink? l) (unison-termlink? r))
|
||||||
[else '>])]
|
(compare-termlink l r)]
|
||||||
[(and (unison-data? l) (unison-data? r))
|
[(and (unison-typelink? l) (unison-typelink? r))
|
||||||
(let ([fls (unison-data-fields l)] [frs (unison-data-fields r)])
|
(compare-typelink l r)]
|
||||||
(comparisons
|
[(and (unison-timespec? l) (unison-timespec? r))
|
||||||
(cmp-num (unison-data-tag l) (unison-data-tag r))
|
(compare-timespec l r)]
|
||||||
(cmp-num (length fls) (length frs))
|
[(= 3 (value->category l) (value->category r))
|
||||||
(lexico-compare fls frs)))]
|
(compare-typelink (pseudo-data-link l) (pseudo-data-link r))]
|
||||||
|
[(= (value->category l) (value->category r))
|
||||||
|
(raise
|
||||||
|
(make-exn:bug
|
||||||
|
"unsupported universal comparison of values"
|
||||||
|
(unison-tuple l r)))]
|
||||||
[else
|
[else
|
||||||
(let ([dl (describe-value l)]
|
(compare-num (value->category l) (value->category r))]))
|
||||||
[dr (describe-value r)])
|
|
||||||
(raise
|
|
||||||
(format
|
(define (list->unison-tuple l)
|
||||||
"universal-compare: unimplemented\n~a\n\n~a"
|
(foldr ref-tuple-pair ref-unit-unit l))
|
||||||
dl dr)))]))
|
|
||||||
|
(define (unison-tuple . l) (list->unison-tuple l))
|
||||||
|
|
||||||
|
|
||||||
(define (chunked-string<? l r) (chunked-string=?/recur l r char<?))
|
(define (chunked-string<? l r) (chunked-string=?/recur l r char<?))
|
||||||
|
|
||||||
@ -380,11 +518,29 @@
|
|||||||
(vector-set! dst i (vector-ref src (+ off i)))
|
(vector-set! dst i (vector-ref src (+ off i)))
|
||||||
(next (fx1- i)))))))
|
(next (fx1- i)))))))
|
||||||
|
|
||||||
; TODO needs better pretty printing for when it isn't caught
|
(define (write-exn:bug ex port mode)
|
||||||
(struct exn:bug (msg a)
|
(when mode
|
||||||
#:constructor-name make-exn:bug)
|
(write-string "<exn:bug " port))
|
||||||
|
|
||||||
|
(let ([recur (case mode
|
||||||
|
[(#t) write]
|
||||||
|
[(#f) display]
|
||||||
|
[else (lambda (v port) (print v port mode))])])
|
||||||
|
(recur (chunked-string->string (exn:bug-msg ex)) port)
|
||||||
|
(if mode (write-string " " port) (newline port))
|
||||||
|
(write-string (describe-value (exn:bug-val ex)) port))
|
||||||
|
|
||||||
|
(when mode
|
||||||
|
(write-string ">")))
|
||||||
|
|
||||||
|
(struct exn:bug (msg val)
|
||||||
|
#:constructor-name make-exn:bug
|
||||||
|
#:methods gen:custom-write
|
||||||
|
[(define write-proc write-exn:bug)])
|
||||||
|
|
||||||
|
|
||||||
(define (exn:bug->exception b)
|
(define (exn:bug->exception b)
|
||||||
(exception
|
(exception
|
||||||
unison-runtimefailure:typelink
|
ref-runtimefailure:typelink
|
||||||
(exn:bug-msg b)
|
(exn:bug-msg b)
|
||||||
(exn:bug-a b)))
|
(exn:bug-val b)))
|
||||||
|
@ -25,6 +25,7 @@
|
|||||||
(struct-out unison-typelink-derived)
|
(struct-out unison-typelink-derived)
|
||||||
(struct-out unison-code)
|
(struct-out unison-code)
|
||||||
(struct-out unison-quote)
|
(struct-out unison-quote)
|
||||||
|
(struct-out unison-timespec)
|
||||||
|
|
||||||
define-builtin-link
|
define-builtin-link
|
||||||
declare-builtin-link
|
declare-builtin-link
|
||||||
@ -53,47 +54,47 @@
|
|||||||
failure
|
failure
|
||||||
exception
|
exception
|
||||||
|
|
||||||
unison-any:typelink
|
builtin-any:typelink
|
||||||
unison-any-any:tag
|
unison-any-any:tag
|
||||||
unison-any-any
|
unison-any-any
|
||||||
|
|
||||||
unison-boolean:typelink
|
builtin-boolean:typelink
|
||||||
unison-boolean-true:tag
|
unison-boolean-true:tag
|
||||||
unison-boolean-false:tag
|
unison-boolean-false:tag
|
||||||
unison-boolean-true
|
unison-boolean-true
|
||||||
unison-boolean-false
|
unison-boolean-false
|
||||||
|
|
||||||
unison-bytes:typelink
|
builtin-bytes:typelink
|
||||||
unison-char:typelink
|
builtin-char:typelink
|
||||||
unison-float:typelink
|
builtin-float:typelink
|
||||||
unison-int:typelink
|
builtin-int:typelink
|
||||||
unison-nat:typelink
|
builtin-nat:typelink
|
||||||
unison-text:typelink
|
builtin-text:typelink
|
||||||
unison-code:typelink
|
builtin-code:typelink
|
||||||
unison-mvar:typelink
|
builtin-mvar:typelink
|
||||||
unison-pattern:typelink
|
builtin-pattern:typelink
|
||||||
unison-promise:typelink
|
builtin-promise:typelink
|
||||||
unison-sequence:typelink
|
builtin-sequence:typelink
|
||||||
unison-socket:typelink
|
builtin-socket:typelink
|
||||||
unison-tls:typelink
|
builtin-tls:typelink
|
||||||
unison-timespec:typelink
|
builtin-timespec:typelink
|
||||||
unison-threadid:typelink
|
builtin-threadid:typelink
|
||||||
; unison-value:typelink
|
builtin-value:typelink
|
||||||
|
|
||||||
unison-crypto.hashalgorithm:typelink
|
builtin-crypto.hashalgorithm:typelink
|
||||||
unison-char.class:typelink
|
builtin-char.class:typelink
|
||||||
unison-immutablearray:typelink
|
builtin-immutablearray:typelink
|
||||||
unison-immutablebytearray:typelink
|
builtin-immutablebytearray:typelink
|
||||||
unison-mutablearray:typelink
|
builtin-mutablearray:typelink
|
||||||
unison-mutablebytearray:typelink
|
builtin-mutablebytearray:typelink
|
||||||
unison-processhandle:typelink
|
builtin-processhandle:typelink
|
||||||
unison-ref.ticket:typelink
|
builtin-ref.ticket:typelink
|
||||||
unison-tls.cipher:typelink
|
builtin-tls.cipher:typelink
|
||||||
unison-tls.clientconfig:typelink
|
builtin-tls.clientconfig:typelink
|
||||||
unison-tls.privatekey:typelink
|
builtin-tls.privatekey:typelink
|
||||||
unison-tls.serverconfig:typelink
|
builtin-tls.serverconfig:typelink
|
||||||
unison-tls.signedcert:typelink
|
builtin-tls.signedcert:typelink
|
||||||
unison-tls.version:typelink
|
builtin-tls.version:typelink
|
||||||
|
|
||||||
unison-tuple->list)
|
unison-tuple->list)
|
||||||
|
|
||||||
@ -253,6 +254,26 @@
|
|||||||
(apply (unison-closure-code clo)
|
(apply (unison-closure-code clo)
|
||||||
(append (unison-closure-env clo) rest))]))
|
(append (unison-closure-env clo) rest))]))
|
||||||
|
|
||||||
|
(struct unison-timespec (sec nsec)
|
||||||
|
#:transparent
|
||||||
|
#:property prop:equal+hash
|
||||||
|
(let ()
|
||||||
|
(define (equal-proc tml tmr rec)
|
||||||
|
(match tml
|
||||||
|
[(unison-timespec sl nsl)
|
||||||
|
(match tmr
|
||||||
|
[(unison-timespec sr nsr)
|
||||||
|
(and (= sl sr) (= nsl nsr))])]))
|
||||||
|
|
||||||
|
(define ((hash-proc init) tm rec)
|
||||||
|
(match tm
|
||||||
|
[(unison-timespec s ns)
|
||||||
|
(fxxor (fx*/wraparound (rec s) 67)
|
||||||
|
(fx*/wraparound (rec ns) 71)
|
||||||
|
(fx*/wraparound init 73))]))
|
||||||
|
|
||||||
|
(list equal-proc (hash-proc 3) (hash-proc 5))))
|
||||||
|
|
||||||
(define-syntax (define-builtin-link stx)
|
(define-syntax (define-builtin-link stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ name)
|
[(_ name)
|
||||||
@ -332,63 +353,63 @@
|
|||||||
(define (either-get either) (car (unison-sum-fields either)))
|
(define (either-get either) (car (unison-sum-fields either)))
|
||||||
|
|
||||||
; a -> Any
|
; a -> Any
|
||||||
(define unison-any:typelink (unison-typelink-builtin "Any"))
|
(define builtin-any:typelink (unison-typelink-builtin "Any"))
|
||||||
(define unison-any-any:tag 0)
|
(define unison-any-any:tag 0)
|
||||||
(define (unison-any-any x)
|
(define (unison-any-any x)
|
||||||
(data unison-any:typelink unison-any-any:tag x))
|
(data builtin-any:typelink unison-any-any:tag x))
|
||||||
|
|
||||||
(define unison-boolean:typelink (unison-typelink-builtin "Boolean"))
|
(define builtin-boolean:typelink (unison-typelink-builtin "Boolean"))
|
||||||
(define unison-boolean-true:tag 1)
|
(define unison-boolean-true:tag 1)
|
||||||
(define unison-boolean-false:tag 0)
|
(define unison-boolean-false:tag 0)
|
||||||
(define unison-boolean-true
|
(define unison-boolean-true
|
||||||
(data unison-boolean:typelink unison-boolean-true:tag))
|
(data builtin-boolean:typelink unison-boolean-true:tag))
|
||||||
(define unison-boolean-false
|
(define unison-boolean-false
|
||||||
(data unison-boolean:typelink unison-boolean-false:tag))
|
(data builtin-boolean:typelink unison-boolean-false:tag))
|
||||||
|
|
||||||
(define unison-bytes:typelink (unison-typelink-builtin "Bytes"))
|
(define builtin-bytes:typelink (unison-typelink-builtin "Bytes"))
|
||||||
(define unison-char:typelink (unison-typelink-builtin "Char"))
|
(define builtin-char:typelink (unison-typelink-builtin "Char"))
|
||||||
(define unison-code:typelink (unison-typelink-builtin "Code"))
|
(define builtin-code:typelink (unison-typelink-builtin "Code"))
|
||||||
(define unison-float:typelink (unison-typelink-builtin "Float"))
|
(define builtin-float:typelink (unison-typelink-builtin "Float"))
|
||||||
(define unison-int:typelink (unison-typelink-builtin "Int"))
|
(define builtin-int:typelink (unison-typelink-builtin "Int"))
|
||||||
(define unison-mvar:typelink (unison-typelink-builtin "MVar"))
|
(define builtin-mvar:typelink (unison-typelink-builtin "MVar"))
|
||||||
(define unison-nat:typelink (unison-typelink-builtin "Nat"))
|
(define builtin-nat:typelink (unison-typelink-builtin "Nat"))
|
||||||
(define unison-pattern:typelink (unison-typelink-builtin "Pattern"))
|
(define builtin-pattern:typelink (unison-typelink-builtin "Pattern"))
|
||||||
(define unison-promise:typelink (unison-typelink-builtin "Promise"))
|
(define builtin-promise:typelink (unison-typelink-builtin "Promise"))
|
||||||
(define unison-sequence:typelink (unison-typelink-builtin "Sequence"))
|
(define builtin-sequence:typelink (unison-typelink-builtin "Sequence"))
|
||||||
(define unison-socket:typelink (unison-typelink-builtin "Socket"))
|
(define builtin-socket:typelink (unison-typelink-builtin "Socket"))
|
||||||
(define unison-text:typelink (unison-typelink-builtin "Text"))
|
(define builtin-text:typelink (unison-typelink-builtin "Text"))
|
||||||
(define unison-tls:typelink (unison-typelink-builtin "Tls"))
|
(define builtin-tls:typelink (unison-typelink-builtin "Tls"))
|
||||||
(define unison-timespec:typelink (unison-typelink-builtin "TimeSpec"))
|
(define builtin-timespec:typelink (unison-typelink-builtin "TimeSpec"))
|
||||||
(define unison-threadid:typelink (unison-typelink-builtin "ThreadId"))
|
(define builtin-threadid:typelink (unison-typelink-builtin "ThreadId"))
|
||||||
; (define unison-value:typelink (unison-typelink-builtin "Value"))
|
(define builtin-value:typelink (unison-typelink-builtin "Value"))
|
||||||
|
|
||||||
(define unison-crypto.hashalgorithm:typelink
|
(define builtin-crypto.hashalgorithm:typelink
|
||||||
(unison-typelink-builtin "crypto.HashAlgorithm"))
|
(unison-typelink-builtin "crypto.HashAlgorithm"))
|
||||||
(define unison-char.class:typelink
|
(define builtin-char.class:typelink
|
||||||
(unison-typelink-builtin "Char.Class"))
|
(unison-typelink-builtin "Char.Class"))
|
||||||
(define unison-immutablearray:typelink
|
(define builtin-immutablearray:typelink
|
||||||
(unison-typelink-builtin "ImmutableArray"))
|
(unison-typelink-builtin "ImmutableArray"))
|
||||||
(define unison-immutablebytearray:typelink
|
(define builtin-immutablebytearray:typelink
|
||||||
(unison-typelink-builtin "ImmutableByteArray"))
|
(unison-typelink-builtin "ImmutableByteArray"))
|
||||||
(define unison-mutablearray:typelink
|
(define builtin-mutablearray:typelink
|
||||||
(unison-typelink-builtin "MutableArray"))
|
(unison-typelink-builtin "MutableArray"))
|
||||||
(define unison-mutablebytearray:typelink
|
(define builtin-mutablebytearray:typelink
|
||||||
(unison-typelink-builtin "MutableArray"))
|
(unison-typelink-builtin "MutableArray"))
|
||||||
(define unison-processhandle:typelink
|
(define builtin-processhandle:typelink
|
||||||
(unison-typelink-builtin "ProcessHandle"))
|
(unison-typelink-builtin "ProcessHandle"))
|
||||||
(define unison-ref.ticket:typelink
|
(define builtin-ref.ticket:typelink
|
||||||
(unison-typelink-builtin "Ref.Ticket"))
|
(unison-typelink-builtin "Ref.Ticket"))
|
||||||
(define unison-tls.cipher:typelink
|
(define builtin-tls.cipher:typelink
|
||||||
(unison-typelink-builtin "Tls.Cipher"))
|
(unison-typelink-builtin "Tls.Cipher"))
|
||||||
(define unison-tls.clientconfig:typelink
|
(define builtin-tls.clientconfig:typelink
|
||||||
(unison-typelink-builtin "Tls.ClientConfig"))
|
(unison-typelink-builtin "Tls.ClientConfig"))
|
||||||
(define unison-tls.privatekey:typelink
|
(define builtin-tls.privatekey:typelink
|
||||||
(unison-typelink-builtin "Tls.PrivateKey"))
|
(unison-typelink-builtin "Tls.PrivateKey"))
|
||||||
(define unison-tls.serverconfig:typelink
|
(define builtin-tls.serverconfig:typelink
|
||||||
(unison-typelink-builtin "Tls.ServerConfig"))
|
(unison-typelink-builtin "Tls.ServerConfig"))
|
||||||
(define unison-tls.signedcert:typelink
|
(define builtin-tls.signedcert:typelink
|
||||||
(unison-typelink-builtin "Tls.SignedCert"))
|
(unison-typelink-builtin "Tls.SignedCert"))
|
||||||
(define unison-tls.version:typelink
|
(define builtin-tls.version:typelink
|
||||||
(unison-typelink-builtin "Tls.Version"))
|
(unison-typelink-builtin "Tls.Version"))
|
||||||
|
|
||||||
; Type -> Text -> Any -> Failure
|
; Type -> Text -> Any -> Failure
|
||||||
|
@ -43,87 +43,103 @@
|
|||||||
|
|
||||||
; typeLink msg any
|
; typeLink msg any
|
||||||
(define (Exception typeLink message payload)
|
(define (Exception typeLink message payload)
|
||||||
(let* ([x7 (unison-any-any payload)]
|
(let* ([a (unison-any-any payload)]
|
||||||
[x8 (unison-failure-failure typeLink message x7)])
|
[msg (string->chunked-string message)]
|
||||||
(unison-either-left x8)))
|
[f (ref-failure-failure typeLink msg a)])
|
||||||
|
(ref-either-left f)))
|
||||||
|
|
||||||
(define-unison (isFileOpen.impl.v3 port)
|
(define-unison (isFileOpen.impl.v3 port)
|
||||||
(unison-either-right (not (port-closed? port))))
|
(ref-either-right (not (port-closed? port))))
|
||||||
|
|
||||||
(define-unison (ready.impl.v1 port)
|
(define-unison (ready.impl.v1 port)
|
||||||
(if (byte-ready? port)
|
(if (byte-ready? port)
|
||||||
(unison-either-right #t)
|
(ref-either-right #t)
|
||||||
(if (port-eof? port)
|
(if (port-eof? port)
|
||||||
(Exception unison-iofailure:typelink "EOF" port)
|
(Exception ref-iofailure:typelink "EOF" port)
|
||||||
(unison-either-right #f))))
|
(ref-either-right #f))))
|
||||||
|
|
||||||
(define-unison (getCurrentDirectory.impl.v3 unit)
|
(define-unison (getCurrentDirectory.impl.v3 unit)
|
||||||
(unison-either-right
|
(ref-either-right
|
||||||
(string->chunked-string (path->string (current-directory)))))
|
(string->chunked-string (path->string (current-directory)))))
|
||||||
|
|
||||||
(define-unison (isSeekable.impl.v3 handle)
|
(define-unison (isSeekable.impl.v3 handle)
|
||||||
(unison-either-right
|
(ref-either-right
|
||||||
(port-has-set-port-position!? handle)))
|
(port-has-set-port-position!? handle)))
|
||||||
|
|
||||||
(define-unison (handlePosition.impl.v3 handle)
|
(define-unison (handlePosition.impl.v3 handle)
|
||||||
(unison-either-right (port-position handle)))
|
(ref-either-right (port-position handle)))
|
||||||
|
|
||||||
(define-unison (seekHandle.impl.v3 handle mode amount)
|
(define-unison (seekHandle.impl.v3 handle mode amount)
|
||||||
(data-case mode
|
(data-case mode
|
||||||
(0 ()
|
(0 ()
|
||||||
(set-port-position! handle amount)
|
(set-port-position! handle amount)
|
||||||
(unison-either-right none))
|
(ref-either-right none))
|
||||||
(1 ()
|
(1 ()
|
||||||
(let ([current (port-position handle)])
|
(let ([current (port-position handle)])
|
||||||
(set-port-position! handle (+ current amount))
|
(set-port-position! handle (+ current amount))
|
||||||
(unison-either-right none)))
|
(ref-either-right none)))
|
||||||
(2 ()
|
(2 ()
|
||||||
(Exception unison-iofailure:typelink "SeekFromEnd not supported" 0))))
|
(Exception
|
||||||
|
ref-iofailure:typelink
|
||||||
|
"SeekFromEnd not supported"
|
||||||
|
0))))
|
||||||
|
|
||||||
(define-unison (getLine.impl.v1 handle)
|
(define-unison (getLine.impl.v1 handle)
|
||||||
(let* ([line (read-line handle)])
|
(let* ([line (read-line handle)])
|
||||||
(if (eof-object? line)
|
(if (eof-object? line)
|
||||||
(unison-either-right (string->chunked-string ""))
|
(ref-either-right (string->chunked-string ""))
|
||||||
(unison-either-right (string->chunked-string line))
|
(ref-either-right (string->chunked-string line))
|
||||||
)))
|
)))
|
||||||
|
|
||||||
(define-unison (getChar.impl.v1 handle)
|
(define-unison (getChar.impl.v1 handle)
|
||||||
(let* ([char (read-char handle)])
|
(let* ([char (read-char handle)])
|
||||||
(if (eof-object? char)
|
(if (eof-object? char)
|
||||||
(Exception unison-iofailure:typelink "End of file reached")
|
(Exception
|
||||||
(unison-either-right char))))
|
ref-iofailure:typelink
|
||||||
|
"End of file reached"
|
||||||
|
ref-unit-unit)
|
||||||
|
(ref-either-right char))))
|
||||||
|
|
||||||
(define-unison (getSomeBytes.impl.v1 handle bytes)
|
(define-unison (getSomeBytes.impl.v1 handle bytes)
|
||||||
(let* ([buffer (make-bytes bytes)]
|
(let* ([buffer (make-bytes bytes)]
|
||||||
[line (read-bytes-avail! buffer handle)])
|
[line (read-bytes-avail! buffer handle)])
|
||||||
(if (eof-object? line)
|
(if (eof-object? line)
|
||||||
(unison-either-right (bytes->chunked-bytes #""))
|
(ref-either-right (bytes->chunked-bytes #""))
|
||||||
(unison-either-right (bytes->chunked-bytes buffer))
|
(ref-either-right (bytes->chunked-bytes buffer))
|
||||||
)))
|
)))
|
||||||
|
|
||||||
(define-unison (getBuffering.impl.v3 handle)
|
(define-unison (getBuffering.impl.v3 handle)
|
||||||
(case (file-stream-buffer-mode handle)
|
(case (file-stream-buffer-mode handle)
|
||||||
[(none) (unison-either-right unison-buffermode-no-buffering)]
|
[(none) (ref-either-right ref-buffermode-no-buffering)]
|
||||||
[(line) (unison-either-right
|
[(line) (ref-either-right
|
||||||
unison-buffermode-line-buffering)]
|
ref-buffermode-line-buffering)]
|
||||||
[(block) (unison-either-right
|
[(block) (ref-either-right
|
||||||
unison-buffermode-block-buffering)]
|
ref-buffermode-block-buffering)]
|
||||||
[(#f) (Exception unison-iofailure:typelink "Unable to determine buffering mode of handle" '())]
|
[(#f) (Exception
|
||||||
[else (Exception unison-iofailure:typelink "Unexpected response from file-stream-buffer-mode" '())]))
|
ref-iofailure:typelink
|
||||||
|
"Unable to determine buffering mode of handle"
|
||||||
|
ref-unit-unit)]
|
||||||
|
[else (Exception
|
||||||
|
ref-iofailure:typelink
|
||||||
|
"Unexpected response from file-stream-buffer-mode"
|
||||||
|
ref-unit-unit)]))
|
||||||
|
|
||||||
(define-unison (setBuffering.impl.v3 handle mode)
|
(define-unison (setBuffering.impl.v3 handle mode)
|
||||||
(data-case mode
|
(data-case mode
|
||||||
(0 ()
|
(0 ()
|
||||||
(file-stream-buffer-mode handle 'none)
|
(file-stream-buffer-mode handle 'none)
|
||||||
(unison-either-right none))
|
(ref-either-right none))
|
||||||
(1 ()
|
(1 ()
|
||||||
(file-stream-buffer-mode handle 'line)
|
(file-stream-buffer-mode handle 'line)
|
||||||
(unison-either-right none))
|
(ref-either-right none))
|
||||||
(2 ()
|
(2 ()
|
||||||
(file-stream-buffer-mode handle 'block)
|
(file-stream-buffer-mode handle 'block)
|
||||||
(unison-either-right none))
|
(ref-either-right none))
|
||||||
(3 (size)
|
(3 (size)
|
||||||
(Exception unison-iofailure:typelink "Sized block buffering not supported" '()))))
|
(Exception
|
||||||
|
ref-iofailure:typelink
|
||||||
|
"Sized block buffering not supported"
|
||||||
|
ref-unit-unit))))
|
||||||
|
|
||||||
(define (with-buffer-mode port mode)
|
(define (with-buffer-mode port mode)
|
||||||
(file-stream-buffer-mode port mode)
|
(file-stream-buffer-mode port mode)
|
||||||
@ -141,8 +157,11 @@
|
|||||||
|
|
||||||
(define-unison (getEcho.impl.v1 handle)
|
(define-unison (getEcho.impl.v1 handle)
|
||||||
(if (eq? handle stdin)
|
(if (eq? handle stdin)
|
||||||
(unison-either-right (get-stdin-echo))
|
(ref-either-right (get-stdin-echo))
|
||||||
(Exception unison-iofailure:typelink "getEcho only supported on stdin" '())))
|
(Exception
|
||||||
|
ref-iofailure:typelink
|
||||||
|
"getEcho only supported on stdin"
|
||||||
|
ref-unit-unit)))
|
||||||
|
|
||||||
(define-unison (setEcho.impl.v1 handle echo)
|
(define-unison (setEcho.impl.v1 handle echo)
|
||||||
(if (eq? handle stdin)
|
(if (eq? handle stdin)
|
||||||
@ -150,23 +169,29 @@
|
|||||||
(if echo
|
(if echo
|
||||||
(system "stty echo")
|
(system "stty echo")
|
||||||
(system "stty -echo"))
|
(system "stty -echo"))
|
||||||
(unison-either-right none))
|
(ref-either-right none))
|
||||||
(Exception unison-iofailure:typelink "setEcho only supported on stdin" '())))
|
(Exception
|
||||||
|
ref-iofailure:typelink
|
||||||
|
"setEcho only supported on stdin"
|
||||||
|
ref-unit-unit)))
|
||||||
|
|
||||||
(define (get-stdin-echo)
|
(define (get-stdin-echo)
|
||||||
(let ([current (with-output-to-string (lambda () (system "stty -a")))])
|
(let ([current (with-output-to-string (lambda () (system "stty -a")))])
|
||||||
(string-contains? current " echo ")))
|
(string-contains? current " echo ")))
|
||||||
|
|
||||||
(define-unison (getArgs.impl.v1 unit)
|
(define-unison (getArgs.impl.v1 unit)
|
||||||
(unison-either-right
|
(ref-either-right
|
||||||
(vector->chunked-list
|
(vector->chunked-list
|
||||||
(vector-map string->chunked-string (current-command-line-arguments)))))
|
(vector-map string->chunked-string (current-command-line-arguments)))))
|
||||||
|
|
||||||
(define-unison (getEnv.impl.v1 key)
|
(define-unison (getEnv.impl.v1 key)
|
||||||
(let ([value (environment-variables-ref (current-environment-variables) (string->bytes/utf-8 (chunked-string->string key)))])
|
(let ([value (environment-variables-ref (current-environment-variables) (string->bytes/utf-8 (chunked-string->string key)))])
|
||||||
(if (false? value)
|
(if (false? value)
|
||||||
(Exception unison-iofailure:typelink "environmental variable not found" key)
|
(Exception
|
||||||
(unison-either-right
|
ref-iofailure:typelink
|
||||||
|
"environmental variable not found"
|
||||||
|
key)
|
||||||
|
(ref-either-right
|
||||||
(string->chunked-string (bytes->string/utf-8 value))))))
|
(string->chunked-string (bytes->string/utf-8 value))))))
|
||||||
|
|
||||||
;; From https://github.com/sorawee/shlex/blob/5de06500e8c831cfc8dffb99d57a76decc02c569/main.rkt (MIT License)
|
;; From https://github.com/sorawee/shlex/blob/5de06500e8c831cfc8dffb99d57a76decc02c569/main.rkt (MIT License)
|
||||||
|
@ -46,20 +46,26 @@
|
|||||||
(with-handlers
|
(with-handlers
|
||||||
[[exn:fail:filesystem?
|
[[exn:fail:filesystem?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception unison-iofailure:typelink (exception->string e) '()))]]
|
(exception
|
||||||
|
ref-iofailure:typelink
|
||||||
|
(exception->string e)
|
||||||
|
ref-unit-unit))]]
|
||||||
(right (file-size (chunked-string->string path)))))
|
(right (file-size (chunked-string->string path)))))
|
||||||
|
|
||||||
(define (getFileTimestamp.impl.v3 path)
|
(define (getFileTimestamp.impl.v3 path)
|
||||||
(with-handlers
|
(with-handlers
|
||||||
[[exn:fail:filesystem?
|
[[exn:fail:filesystem?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception unison-iofailure:typelink (exception->string e) '()))]]
|
(exception
|
||||||
|
ref-iofailure:typelink
|
||||||
|
(exception->string e)
|
||||||
|
ref-unit-unit))]]
|
||||||
(right (file-or-directory-modify-seconds (chunked-string->string path)))))
|
(right (file-or-directory-modify-seconds (chunked-string->string path)))))
|
||||||
|
|
||||||
; in haskell, it's not just file but also directory
|
; in haskell, it's not just file but also directory
|
||||||
(define-unison (fileExists.impl.v3 path)
|
(define-unison (fileExists.impl.v3 path)
|
||||||
(let ([path-string (chunked-string->string path)])
|
(let ([path-string (chunked-string->string path)])
|
||||||
(unison-either-right
|
(ref-either-right
|
||||||
(or
|
(or
|
||||||
(file-exists? path-string)
|
(file-exists? path-string)
|
||||||
(directory-exists? path-string)))))
|
(directory-exists? path-string)))))
|
||||||
@ -73,10 +79,10 @@
|
|||||||
|
|
||||||
(define-unison (setCurrentDirectory.impl.v3 path)
|
(define-unison (setCurrentDirectory.impl.v3 path)
|
||||||
(current-directory (chunked-string->string path))
|
(current-directory (chunked-string->string path))
|
||||||
(unison-either-right none))
|
(ref-either-right none))
|
||||||
|
|
||||||
(define-unison (createTempDirectory.impl.v3 prefix)
|
(define-unison (createTempDirectory.impl.v3 prefix)
|
||||||
(unison-either-right
|
(ref-either-right
|
||||||
(string->chunked-string
|
(string->chunked-string
|
||||||
(path->string
|
(path->string
|
||||||
(make-temporary-directory*
|
(make-temporary-directory*
|
||||||
@ -85,44 +91,65 @@
|
|||||||
|
|
||||||
(define-unison (createDirectory.impl.v3 file)
|
(define-unison (createDirectory.impl.v3 file)
|
||||||
(make-directory (chunked-string->string file))
|
(make-directory (chunked-string->string file))
|
||||||
(unison-either-right none))
|
(ref-either-right none))
|
||||||
|
|
||||||
(define-unison (removeDirectory.impl.v3 file)
|
(define-unison (removeDirectory.impl.v3 file)
|
||||||
(delete-directory/files (chunked-string->string file))
|
(delete-directory/files (chunked-string->string file))
|
||||||
(unison-either-right none))
|
(ref-either-right none))
|
||||||
|
|
||||||
(define-unison (isDirectory.impl.v3 path)
|
(define-unison (isDirectory.impl.v3 path)
|
||||||
(unison-either-right
|
(ref-either-right
|
||||||
(directory-exists? (chunked-string->string path))))
|
(directory-exists? (chunked-string->string path))))
|
||||||
|
|
||||||
(define-unison (renameDirectory.impl.v3 old new)
|
(define-unison (renameDirectory.impl.v3 old new)
|
||||||
(rename-file-or-directory (chunked-string->string old)
|
(rename-file-or-directory (chunked-string->string old)
|
||||||
(chunked-string->string new))
|
(chunked-string->string new))
|
||||||
(unison-either-right none))
|
(ref-either-right none))
|
||||||
|
|
||||||
(define-unison (renameFile.impl.v3 old new)
|
(define-unison (renameFile.impl.v3 old new)
|
||||||
(rename-file-or-directory (chunked-string->string old)
|
(rename-file-or-directory (chunked-string->string old)
|
||||||
(chunked-string->string new))
|
(chunked-string->string new))
|
||||||
(unison-either-right none))
|
(ref-either-right none))
|
||||||
|
|
||||||
(define-unison (systemTime.impl.v3 unit)
|
(define-unison (systemTime.impl.v3 unit)
|
||||||
(unison-either-right (current-seconds)))
|
(ref-either-right (current-seconds)))
|
||||||
|
|
||||||
(define-unison (systemTimeMicroseconds.impl.v3 unit)
|
(define-unison (systemTimeMicroseconds.impl.v3 unit)
|
||||||
(unison-either-right (inexact->exact (* 1000 (current-inexact-milliseconds)))))
|
(ref-either-right (inexact->exact (* 1000 (current-inexact-milliseconds)))))
|
||||||
|
|
||||||
(define (threadCPUTime.v1)
|
(define (threadCPUTime.v1)
|
||||||
(right (current-process-milliseconds (current-thread))))
|
(right
|
||||||
|
(integer->time
|
||||||
|
(current-process-milliseconds (current-thread)))))
|
||||||
|
|
||||||
(define (processCPUTime.v1)
|
(define (processCPUTime.v1)
|
||||||
(right (current-process-milliseconds 'process)))
|
(right
|
||||||
|
(integer->time
|
||||||
|
(current-process-milliseconds #f))))
|
||||||
|
|
||||||
(define (realtime.v1)
|
(define (realtime.v1)
|
||||||
(right (current-inexact-milliseconds)))
|
(right
|
||||||
|
(float->time
|
||||||
|
(current-inexact-milliseconds))))
|
||||||
|
|
||||||
(define (monotonic.v1)
|
(define (monotonic.v1)
|
||||||
(right (current-inexact-monotonic-milliseconds)))
|
(right
|
||||||
|
(float->time
|
||||||
|
(current-inexact-monotonic-milliseconds))))
|
||||||
|
|
||||||
|
(define (integer->time msecs)
|
||||||
|
(unison-timespec
|
||||||
|
(truncate (/ msecs 1000))
|
||||||
|
(* (modulo msecs 1000) 1000000)))
|
||||||
|
|
||||||
|
(define (float->time msecs)
|
||||||
|
(unison-timespec
|
||||||
|
(trunc (/ msecs 1000))
|
||||||
|
(trunc (* (flmod msecs 1000.0) 1000000))))
|
||||||
|
|
||||||
;
|
;
|
||||||
(define (flt f) (fl->exact-integer (fltruncate f)))
|
(define (trunc f) (inexact->exact (truncate f)))
|
||||||
|
|
||||||
(define (sec.v1 ts) (flt (/ ts 1000)))
|
(define sec.v1 unison-timespec-sec)
|
||||||
|
|
||||||
(define (nsec.v1 ts) (flt (* (flmod ts 1000.0) 1000000)))
|
(define nsec.v1 unison-timespec-nsec)
|
||||||
|
@ -83,10 +83,10 @@
|
|||||||
(define (decode-term tm)
|
(define (decode-term tm)
|
||||||
(match tm
|
(match tm
|
||||||
[(unison-data _ t (list tms))
|
[(unison-data _ t (list tms))
|
||||||
#:when (= t unison-schemeterm-sexpr:tag)
|
#:when (= t ref-schemeterm-sexpr:tag)
|
||||||
(map decode-term (chunked-list->list tms))]
|
(map decode-term (chunked-list->list tms))]
|
||||||
[(unison-data _ t (list as h tms))
|
[(unison-data _ t (list as h tms))
|
||||||
#:when (= t unison-schemeterm-handle:tag)
|
#:when (= t ref-schemeterm-handle:tag)
|
||||||
`(handle
|
`(handle
|
||||||
,(map
|
,(map
|
||||||
(lambda (tx) (text->linkname tx))
|
(lambda (tx) (text->linkname tx))
|
||||||
@ -94,27 +94,27 @@
|
|||||||
,(text->ident h)
|
,(text->ident h)
|
||||||
,@(map decode-term (chunked-list->list tms)))]
|
,@(map decode-term (chunked-list->list tms)))]
|
||||||
[(unison-data _ t (list hd sc cs))
|
[(unison-data _ t (list hd sc cs))
|
||||||
#:when (= t unison-schemeterm-cases:tag)
|
#:when (= t ref-schemeterm-cases:tag)
|
||||||
(assemble-cases
|
(assemble-cases
|
||||||
(text->ident hd)
|
(text->ident hd)
|
||||||
(decode-term sc)
|
(decode-term sc)
|
||||||
(map decode-term (chunked-list->list cs)))]
|
(map decode-term (chunked-list->list cs)))]
|
||||||
[(unison-data _ t (list hd bs bd))
|
[(unison-data _ t (list hd bs bd))
|
||||||
#:when (= t unison-schemeterm-binds:tag)
|
#:when (= t ref-schemeterm-binds:tag)
|
||||||
`(,(text->ident hd)
|
`(,(text->ident hd)
|
||||||
,(map decode-binding (chunked-list->list bs))
|
,(map decode-binding (chunked-list->list bs))
|
||||||
,(decode-term bd))]
|
,(decode-term bd))]
|
||||||
[(unison-data _ t (list tx))
|
[(unison-data _ t (list tx))
|
||||||
#:when (= t unison-schemeterm-ident:tag)
|
#:when (= t ref-schemeterm-ident:tag)
|
||||||
(text->ident tx)]
|
(text->ident tx)]
|
||||||
[(unison-data _ t (list tx))
|
[(unison-data _ t (list tx))
|
||||||
#:when (= t unison-schemeterm-string:tag)
|
#:when (= t ref-schemeterm-string:tag)
|
||||||
(chunked-string->string tx)]
|
(chunked-string->string tx)]
|
||||||
[(unison-data _ t (list tx))
|
[(unison-data _ t (list tx))
|
||||||
#:when (= t unison-schemeterm-symbol:tag)
|
#:when (= t ref-schemeterm-symbol:tag)
|
||||||
`(quote ,(text->ident tx))]
|
`(quote ,(text->ident tx))]
|
||||||
[(unison-data _ t (list ns))
|
[(unison-data _ t (list ns))
|
||||||
#:when (= t unison-schemeterm-bytevec:tag)
|
#:when (= t ref-schemeterm-bytevec:tag)
|
||||||
(list->bytes (chunked-list->list ns))]
|
(list->bytes (chunked-list->list ns))]
|
||||||
[else
|
[else
|
||||||
(raise (format "decode-term: unimplemented case: ~a" tm))]))
|
(raise (format "decode-term: unimplemented case: ~a" tm))]))
|
||||||
@ -131,13 +131,13 @@
|
|||||||
(define (decode-syntax dfn)
|
(define (decode-syntax dfn)
|
||||||
(match dfn
|
(match dfn
|
||||||
[(unison-data _ t (list nm vs bd))
|
[(unison-data _ t (list nm vs bd))
|
||||||
#:when (= t unison-schemedefn-define:tag)
|
#:when (= t ref-schemedefn-define:tag)
|
||||||
(let ([head (map text->ident
|
(let ([head (map text->ident
|
||||||
(cons nm (chunked-list->list vs)))]
|
(cons nm (chunked-list->list vs)))]
|
||||||
[body (decode-term bd)])
|
[body (decode-term bd)])
|
||||||
(list 'define-unison head body))]
|
(list 'define-unison head body))]
|
||||||
[(unison-data _ t (list nm bd))
|
[(unison-data _ t (list nm bd))
|
||||||
#:when (= t unison-schemedefn-alias:tag)
|
#:when (= t ref-schemedefn-alias:tag)
|
||||||
(list 'define (text->ident nm) (decode-term bd))]
|
(list 'define (text->ident nm) (decode-term bd))]
|
||||||
[else
|
[else
|
||||||
(raise (format "decode-syntax: unimplemented case: ~a" dfn))]))
|
(raise (format "decode-syntax: unimplemented case: ~a" dfn))]))
|
||||||
@ -167,10 +167,10 @@
|
|||||||
(define (decode-ref rf)
|
(define (decode-ref rf)
|
||||||
(match rf
|
(match rf
|
||||||
[(unison-data r t (list name))
|
[(unison-data r t (list name))
|
||||||
#:when (= t unison-reference-builtin:tag)
|
#:when (= t ref-reference-builtin:tag)
|
||||||
(sum 0 (chunked-string->string name))]
|
(sum 0 (chunked-string->string name))]
|
||||||
[(unison-data r t (list id))
|
[(unison-data r t (list id))
|
||||||
#:when (= t unison-reference-derived:tag)
|
#:when (= t ref-reference-derived:tag)
|
||||||
(data-case id
|
(data-case id
|
||||||
[0 (bs i) (sum 1 bs i)])]))
|
[0 (bs i) (sum 1 bs i)])]))
|
||||||
|
|
||||||
@ -200,7 +200,7 @@
|
|||||||
[(_)
|
[(_)
|
||||||
#`(lambda (gr)
|
#`(lambda (gr)
|
||||||
(data-case (group-ref-ident gr)
|
(data-case (group-ref-ident gr)
|
||||||
[#,unison-schemeterm-ident:tag (name) name]
|
[#,ref-schemeterm-ident:tag (name) name]
|
||||||
[else
|
[else
|
||||||
(raise
|
(raise
|
||||||
(format
|
(format
|
||||||
@ -242,10 +242,10 @@
|
|||||||
(define (termlink->reference rn)
|
(define (termlink->reference rn)
|
||||||
(match rn
|
(match rn
|
||||||
[(unison-termlink-builtin name)
|
[(unison-termlink-builtin name)
|
||||||
(unison-reference-builtin
|
(ref-reference-builtin
|
||||||
(string->chunked-string name))]
|
(string->chunked-string name))]
|
||||||
[(unison-termlink-derived bs i)
|
[(unison-termlink-derived bs i)
|
||||||
(unison-reference-derived (unison-id-id bs i))]
|
(ref-reference-derived (ref-id-id bs i))]
|
||||||
[else (raise "termlink->reference: con case")]))
|
[else (raise "termlink->reference: con case")]))
|
||||||
|
|
||||||
(define (group-reference gr)
|
(define (group-reference gr)
|
||||||
@ -260,19 +260,19 @@
|
|||||||
(define runtime-module-map (make-hash))
|
(define runtime-module-map (make-hash))
|
||||||
|
|
||||||
(define (reflect-derived bs i)
|
(define (reflect-derived bs i)
|
||||||
(data unison-reference:typelink unison-reference-derived:tag
|
(data ref-reference:typelink ref-reference-derived:tag
|
||||||
(data unison-id:typelink unison-id-id:tag bs i)))
|
(data ref-id:typelink ref-id-id:tag bs i)))
|
||||||
|
|
||||||
(define (function->groupref f)
|
(define (function->groupref f)
|
||||||
(match (lookup-function-link f)
|
(match (lookup-function-link f)
|
||||||
[(unison-termlink-derived h i)
|
[(unison-termlink-derived h i)
|
||||||
(unison-groupref-group
|
(ref-groupref-group
|
||||||
(unison-reference-derived
|
(ref-reference-derived
|
||||||
(unison-id-id h i))
|
(ref-id-id h i))
|
||||||
0)]
|
0)]
|
||||||
[(unison-termlink-builtin name)
|
[(unison-termlink-builtin name)
|
||||||
(unison-groupref-group
|
(ref-groupref-group
|
||||||
(unison-reference-builtin (string->chunked-string name))
|
(ref-reference-builtin (string->chunked-string name))
|
||||||
0)]
|
0)]
|
||||||
[else (raise "function->groupref: con case")]))
|
[else (raise "function->groupref: con case")]))
|
||||||
|
|
||||||
@ -280,19 +280,19 @@
|
|||||||
(match vl
|
(match vl
|
||||||
[(unison-data _ t (list l))
|
[(unison-data _ t (list l))
|
||||||
(cond
|
(cond
|
||||||
[(= t unison-vlit-bytes:tag) l]
|
[(= t ref-vlit-bytes:tag) l]
|
||||||
[(= t unison-vlit-char:tag) l]
|
[(= t ref-vlit-char:tag) l]
|
||||||
[(= t unison-vlit-bytearray:tag) l]
|
[(= t ref-vlit-bytearray:tag) l]
|
||||||
[(= t unison-vlit-text:tag) l]
|
[(= t ref-vlit-text:tag) l]
|
||||||
[(= t unison-vlit-termlink:tag) (referent->termlink l)]
|
[(= t ref-vlit-termlink:tag) (referent->termlink l)]
|
||||||
[(= t unison-vlit-typelink:tag) (reference->typelink l)]
|
[(= t ref-vlit-typelink:tag) (reference->typelink l)]
|
||||||
[(= t unison-vlit-float:tag) l]
|
[(= t ref-vlit-float:tag) l]
|
||||||
[(= t unison-vlit-pos:tag) l]
|
[(= t ref-vlit-pos:tag) l]
|
||||||
[(= t unison-vlit-neg:tag) (- l)]
|
[(= t ref-vlit-neg:tag) (- l)]
|
||||||
[(= t unison-vlit-quote:tag) (unison-quote l)]
|
[(= t ref-vlit-quote:tag) (unison-quote l)]
|
||||||
[(= t unison-vlit-code:tag) (unison-code l)]
|
[(= t ref-vlit-code:tag) (unison-code l)]
|
||||||
[(= t unison-vlit-array:tag) (vector-map reify-value l)]
|
[(= t ref-vlit-array:tag) (vector-map reify-value l)]
|
||||||
[(= t unison-vlit-seq:tag)
|
[(= t ref-vlit-seq:tag)
|
||||||
; TODO: better map over chunked list
|
; TODO: better map over chunked list
|
||||||
(vector->chunked-list
|
(vector->chunked-list
|
||||||
(vector-map reify-value (chunked-list->vector l)))]
|
(vector-map reify-value (chunked-list->vector l)))]
|
||||||
@ -302,19 +302,19 @@
|
|||||||
(define (reify-value v)
|
(define (reify-value v)
|
||||||
(match v
|
(match v
|
||||||
[(unison-data _ t (list rf rt bs0))
|
[(unison-data _ t (list rf rt bs0))
|
||||||
#:when (= t unison-value-data:tag)
|
#:when (= t ref-value-data:tag)
|
||||||
(let ([bs (map reify-value (chunked-list->list bs0))])
|
(let ([bs (map reify-value (chunked-list->list bs0))])
|
||||||
(make-data (reference->typelink rf) rt bs))]
|
(make-data (reference->typelink rf) rt bs))]
|
||||||
[(unison-data _ t (list gr bs0))
|
[(unison-data _ t (list gr bs0))
|
||||||
#:when (= t unison-value-partial:tag)
|
#:when (= t ref-value-partial:tag)
|
||||||
(let ([bs (map reify-value (chunked-list->list bs0))]
|
(let ([bs (map reify-value (chunked-list->list bs0))]
|
||||||
[proc (resolve-proc gr)])
|
[proc (resolve-proc gr)])
|
||||||
(apply proc bs))]
|
(apply proc bs))]
|
||||||
[(unison-data _ t (list vl))
|
[(unison-data _ t (list vl))
|
||||||
#:when (= t unison-value-vlit:tag)
|
#:when (= t ref-value-vlit:tag)
|
||||||
(reify-vlit vl)]
|
(reify-vlit vl)]
|
||||||
[(unison-data _ t (list bs0 k))
|
[(unison-data _ t (list bs0 k))
|
||||||
#:when (= t unison-value-cont:tag)
|
#:when (= t ref-value-cont:tag)
|
||||||
(raise "reify-value: unimplemented cont case")]
|
(raise "reify-value: unimplemented cont case")]
|
||||||
[(unison-data r t fs)
|
[(unison-data r t fs)
|
||||||
(raise "reify-value: unimplemented data case")]
|
(raise "reify-value: unimplemented data case")]
|
||||||
@ -324,75 +324,75 @@
|
|||||||
(define (reflect-typelink tl)
|
(define (reflect-typelink tl)
|
||||||
(match tl
|
(match tl
|
||||||
[(unison-typelink-builtin name)
|
[(unison-typelink-builtin name)
|
||||||
(unison-reference-builtin
|
(ref-reference-builtin
|
||||||
(string->chunked-string name))]
|
(string->chunked-string name))]
|
||||||
[(unison-typelink-derived h i)
|
[(unison-typelink-derived h i)
|
||||||
(unison-reference-derived (unison-id-id h i))]))
|
(ref-reference-derived (ref-id-id h i))]))
|
||||||
|
|
||||||
(define (reflect-termlink tl)
|
(define (reflect-termlink tl)
|
||||||
(match tl
|
(match tl
|
||||||
[(unison-termlink-con r i)
|
[(unison-termlink-con r i)
|
||||||
(unison-referent-con (reflect-typelink r) i)]
|
(ref-referent-con (reflect-typelink r) i)]
|
||||||
[(unison-termlink-builtin name)
|
[(unison-termlink-builtin name)
|
||||||
(unison-referent-def
|
(ref-referent-def
|
||||||
(unison-reference-builtin
|
(ref-reference-builtin
|
||||||
(string->chunked-string name)))]
|
(string->chunked-string name)))]
|
||||||
[(unison-termlink-derived h i)
|
[(unison-termlink-derived h i)
|
||||||
(unison-referent-def
|
(ref-referent-def
|
||||||
(unison-reference-derived
|
(ref-reference-derived
|
||||||
(unison-id-id h i)))]))
|
(ref-id-id h i)))]))
|
||||||
|
|
||||||
(define (number-reference n)
|
(define (number-reference n)
|
||||||
(cond
|
(cond
|
||||||
[(exact-nonnegative-integer? n)
|
[(exact-nonnegative-integer? n)
|
||||||
(unison-reference-builtin (string->chunked-string "Nat"))]
|
(ref-reference-builtin (string->chunked-string "Nat"))]
|
||||||
[(exact-integer? n)
|
[(exact-integer? n)
|
||||||
(unison-reference-builtin (string->chunked-string "Int"))]
|
(ref-reference-builtin (string->chunked-string "Int"))]
|
||||||
[else
|
[else
|
||||||
(unison-reference-builtin (string->chunked-string "Float"))]))
|
(ref-reference-builtin (string->chunked-string "Float"))]))
|
||||||
|
|
||||||
(define (reflect-value v)
|
(define (reflect-value v)
|
||||||
(match v
|
(match v
|
||||||
[(? exact-nonnegative-integer?)
|
[(? exact-nonnegative-integer?)
|
||||||
(unison-value-vlit (unison-vlit-pos v))]
|
(ref-value-vlit (ref-vlit-pos v))]
|
||||||
[(? exact-integer?)
|
[(? exact-integer?)
|
||||||
(unison-value-vlit (unison-vlit-neg (- v)))]
|
(ref-value-vlit (ref-vlit-neg (- v)))]
|
||||||
[(? inexact-real?)
|
[(? inexact-real?)
|
||||||
(unison-value-vlit (unison-vlit-float v))]
|
(ref-value-vlit (ref-vlit-float v))]
|
||||||
[(? char?)
|
[(? char?)
|
||||||
(unison-value-vlit (unison-vlit-char v))]
|
(ref-value-vlit (ref-vlit-char v))]
|
||||||
[(? chunked-bytes?)
|
[(? chunked-bytes?)
|
||||||
(unison-value-vlit (unison-vlit-bytes v))]
|
(ref-value-vlit (ref-vlit-bytes v))]
|
||||||
[(? bytes?)
|
[(? bytes?)
|
||||||
(unison-value-vlit (unison-vlit-bytearray v))]
|
(ref-value-vlit (ref-vlit-bytearray v))]
|
||||||
[(? vector?)
|
[(? vector?)
|
||||||
(unison-value-vlit
|
(ref-value-vlit
|
||||||
(unison-vlit-array
|
(ref-vlit-array
|
||||||
(vector-map reflect-value v)))]
|
(vector-map reflect-value v)))]
|
||||||
[(? chunked-string?)
|
[(? chunked-string?)
|
||||||
(unison-value-vlit (unison-vlit-text v))]
|
(ref-value-vlit (ref-vlit-text v))]
|
||||||
; TODO: better map over chunked lists
|
; TODO: better map over chunked lists
|
||||||
[(? chunked-list?)
|
[(? chunked-list?)
|
||||||
(unison-value-vlit
|
(ref-value-vlit
|
||||||
(unison-vlit-seq
|
(ref-vlit-seq
|
||||||
(list->chunked-list
|
(list->chunked-list
|
||||||
(map reflect-value (chunked-list->list v)))))]
|
(map reflect-value (chunked-list->list v)))))]
|
||||||
[(? unison-termlink?)
|
[(? unison-termlink?)
|
||||||
(unison-value-vlit (unison-vlit-termlink (reflect-termlink v)))]
|
(ref-value-vlit (ref-vlit-termlink (reflect-termlink v)))]
|
||||||
[(? unison-typelink?)
|
[(? unison-typelink?)
|
||||||
(unison-value-vlit (unison-vlit-typelink (reflect-typelink v)))]
|
(ref-value-vlit (ref-vlit-typelink (reflect-typelink v)))]
|
||||||
[(unison-code sg) (unison-value-vlit (unison-vlit-code sg))]
|
[(unison-code sg) (ref-value-vlit (ref-vlit-code sg))]
|
||||||
[(unison-quote q) (unison-value-vlit (unison-vlit-quote q))]
|
[(unison-quote q) (ref-value-vlit (ref-vlit-quote q))]
|
||||||
[(unison-closure f as)
|
[(unison-closure f as)
|
||||||
(unison-value-partial
|
(ref-value-partial
|
||||||
(function->groupref f)
|
(function->groupref f)
|
||||||
(list->chunked-list (map reflect-value as)))]
|
(list->chunked-list (map reflect-value as)))]
|
||||||
[(? procedure?)
|
[(? procedure?)
|
||||||
(unison-value-partial
|
(ref-value-partial
|
||||||
(function->groupref v)
|
(function->groupref v)
|
||||||
empty-chunked-list)]
|
empty-chunked-list)]
|
||||||
[(unison-data rf t fs)
|
[(unison-data rf t fs)
|
||||||
(unison-value-data
|
(ref-value-data
|
||||||
(reflect-typelink rf)
|
(reflect-typelink rf)
|
||||||
t
|
t
|
||||||
(list->chunked-list (map reflect-value fs)))]))
|
(list->chunked-list (map reflect-value fs)))]))
|
||||||
@ -428,8 +428,8 @@
|
|||||||
|
|
||||||
#:result
|
#:result
|
||||||
(if (null? unkn)
|
(if (null? unkn)
|
||||||
(unison-either-right (list->chunked-list sdbx))
|
(ref-either-right (list->chunked-list sdbx))
|
||||||
(unison-either-left (list->chunked-list unkn))))
|
(ref-either-left (list->chunked-list unkn))))
|
||||||
|
|
||||||
([r (in-chunked-list (value-term-dependencies v))])
|
([r (in-chunked-list (value-term-dependencies v))])
|
||||||
|
|
||||||
@ -593,7 +593,7 @@
|
|||||||
|
|
||||||
,@sdefs
|
,@sdefs
|
||||||
|
|
||||||
(handle [unison-exception:typelink] top-exn-handler
|
(handle [ref-exception:typelink] top-exn-handler
|
||||||
(,pname #f)))))
|
(,pname #f)))))
|
||||||
|
|
||||||
(define (build-runtime-module mname tylinks tmlinks defs)
|
(define (build-runtime-module mname tylinks tmlinks defs)
|
||||||
@ -646,23 +646,22 @@
|
|||||||
[fdeps (filter need-dependency? deps)]
|
[fdeps (filter need-dependency? deps)]
|
||||||
[rdeps (remove* refs fdeps)])
|
[rdeps (remove* refs fdeps)])
|
||||||
(cond
|
(cond
|
||||||
[(null? fdeps) #f]
|
[(null? fdeps) empty-chunked-list]
|
||||||
[(null? rdeps)
|
[(null? rdeps)
|
||||||
(let ([ndefs (map gen-code udefs)] [sdefs (flatten (map gen-code udefs))]
|
(let ([ndefs (map gen-code udefs)]
|
||||||
|
[sdefs (flatten (map gen-code udefs))]
|
||||||
[mname (or mname0 (generate-module-name tmlinks))])
|
[mname (or mname0 (generate-module-name tmlinks))])
|
||||||
(expand-sandbox tmlinks (map-links depss))
|
(expand-sandbox tmlinks (map-links depss))
|
||||||
(register-code udefs)
|
(register-code udefs)
|
||||||
(add-module-associations tmlinks mname)
|
(add-module-associations tmlinks mname)
|
||||||
(add-runtime-module mname tylinks tmlinks sdefs)
|
(add-runtime-module mname tylinks tmlinks sdefs)
|
||||||
#f)]
|
empty-chunked-list)]
|
||||||
[else (list->chunked-list rdeps)]))]
|
[else
|
||||||
[else #f])))
|
(list->chunked-list
|
||||||
|
(map reference->termlink rdeps))]))]
|
||||||
|
[else empty-chunked-list])))
|
||||||
|
|
||||||
(define (unison-POp-CACH dfns0)
|
(define (unison-POp-CACH dfns0) (add-runtime-code #f dfns0))
|
||||||
(let ([result (add-runtime-code #f dfns0)])
|
|
||||||
(if result
|
|
||||||
(sum 1 result)
|
|
||||||
(sum 0 '()))))
|
|
||||||
|
|
||||||
(define (unison-POp-LOAD v0)
|
(define (unison-POp-LOAD v0)
|
||||||
(let* ([val (unison-quote-val v0)]
|
(let* ([val (unison-quote-val v0)]
|
||||||
@ -671,14 +670,16 @@
|
|||||||
[fdeps (filter need-dependency? (chunked-list->list deps))])
|
[fdeps (filter need-dependency? (chunked-list->list deps))])
|
||||||
(if (null? fdeps)
|
(if (null? fdeps)
|
||||||
(sum 1 (reify-value val))
|
(sum 1 (reify-value val))
|
||||||
(sum 0 (list->chunked-list fdeps)))))
|
(sum 0
|
||||||
|
(list->chunked-list
|
||||||
|
(map reference->termlink fdeps))))))
|
||||||
|
|
||||||
(define (unison-POp-LKUP tl) (lookup-code tl))
|
(define (unison-POp-LKUP tl) (lookup-code tl))
|
||||||
|
|
||||||
(define-unison (builtin-Code.lookup tl)
|
(define-unison (builtin-Code.lookup tl)
|
||||||
(match (lookup-code tl)
|
(match (lookup-code tl)
|
||||||
[(unison-sum 0 (list)) unison-optional-none]
|
[(unison-sum 0 (list)) ref-optional-none]
|
||||||
[(unison-sum 1 (list co)) (unison-optional-some co)]))
|
[(unison-sum 1 (list co)) (ref-optional-some co)]))
|
||||||
|
|
||||||
(define-unison (builtin-validateSandboxed ok v)
|
(define-unison (builtin-validateSandboxed ok v)
|
||||||
(let ([l (sandbox-scheme-value (chunked-list->list ok) v)])
|
(let ([l (sandbox-scheme-value (chunked-list->list ok) v)])
|
||||||
|
@ -24,13 +24,6 @@
|
|||||||
#!r6rs
|
#!r6rs
|
||||||
(library (unison primops)
|
(library (unison primops)
|
||||||
(export
|
(export
|
||||||
builtin-Any:typelink
|
|
||||||
builtin-Char:typelink
|
|
||||||
builtin-Float:typelink
|
|
||||||
builtin-Int:typelink
|
|
||||||
builtin-Nat:typelink
|
|
||||||
builtin-Text:typelink
|
|
||||||
|
|
||||||
builtin-Float.*
|
builtin-Float.*
|
||||||
builtin-Float.*:termlink
|
builtin-Float.*:termlink
|
||||||
builtin-Float.>=
|
builtin-Float.>=
|
||||||
@ -255,6 +248,8 @@
|
|||||||
builtin-Char.Class.is:termlink
|
builtin-Char.Class.is:termlink
|
||||||
builtin-Pattern.captureAs
|
builtin-Pattern.captureAs
|
||||||
builtin-Pattern.captureAs:termlink
|
builtin-Pattern.captureAs:termlink
|
||||||
|
builtin-Pattern.many.corrected
|
||||||
|
builtin-Pattern.many.corrected:termlink
|
||||||
builtin-Pattern.isMatch
|
builtin-Pattern.isMatch
|
||||||
builtin-Pattern.isMatch:termlink
|
builtin-Pattern.isMatch:termlink
|
||||||
builtin-IO.fileExists.impl.v3
|
builtin-IO.fileExists.impl.v3
|
||||||
@ -645,13 +640,6 @@
|
|||||||
(unison concurrent)
|
(unison concurrent)
|
||||||
(racket random))
|
(racket random))
|
||||||
|
|
||||||
(define builtin-Any:typelink unison-any:typelink)
|
|
||||||
(define builtin-Char:typelink unison-char:typelink)
|
|
||||||
(define builtin-Float:typelink unison-float:typelink)
|
|
||||||
(define builtin-Int:typelink unison-int:typelink)
|
|
||||||
(define builtin-Nat:typelink unison-nat:typelink)
|
|
||||||
(define builtin-Text:typelink unison-text:typelink)
|
|
||||||
|
|
||||||
(define-builtin-link Float.*)
|
(define-builtin-link Float.*)
|
||||||
(define-builtin-link Float.fromRepresentation)
|
(define-builtin-link Float.fromRepresentation)
|
||||||
(define-builtin-link Float.toRepresentation)
|
(define-builtin-link Float.toRepresentation)
|
||||||
@ -754,6 +742,7 @@
|
|||||||
(define-builtin-link Universal.compare)
|
(define-builtin-link Universal.compare)
|
||||||
(define-builtin-link Universal.murmurHash)
|
(define-builtin-link Universal.murmurHash)
|
||||||
(define-builtin-link Pattern.captureAs)
|
(define-builtin-link Pattern.captureAs)
|
||||||
|
(define-builtin-link Pattern.many.corrected)
|
||||||
(define-builtin-link Pattern.isMatch)
|
(define-builtin-link Pattern.isMatch)
|
||||||
(define-builtin-link Char.Class.is)
|
(define-builtin-link Char.Class.is)
|
||||||
(define-builtin-link Scope.bytearrayOf)
|
(define-builtin-link Scope.bytearrayOf)
|
||||||
@ -780,13 +769,13 @@
|
|||||||
|
|
||||||
(define-unison (builtin-List.splitLeft n s)
|
(define-unison (builtin-List.splitLeft n s)
|
||||||
(match (unison-POp-SPLL n s)
|
(match (unison-POp-SPLL n s)
|
||||||
[(unison-sum 0 fs) unison-seqview-empty]
|
[(unison-sum 0 fs) ref-seqview-empty]
|
||||||
[(unison-sum 1 (list l r)) (unison-seqview-elem l r)]))
|
[(unison-sum 1 (list l r)) (ref-seqview-elem l r)]))
|
||||||
|
|
||||||
(define-unison (builtin-List.splitRight n s)
|
(define-unison (builtin-List.splitRight n s)
|
||||||
(match (unison-POp-SPLR n s)
|
(match (unison-POp-SPLR n s)
|
||||||
[(unison-sum 0 fs) unison-seqview-empty]
|
[(unison-sum 0 fs) ref-seqview-empty]
|
||||||
[(unison-sum 1 (list l r)) (unison-seqview-elem l r)]))
|
[(unison-sum 1 (list l r)) (ref-seqview-elem l r)]))
|
||||||
|
|
||||||
(define-unison (builtin-Float.> x y) (fl> x y))
|
(define-unison (builtin-Float.> x y) (fl> x y))
|
||||||
(define-unison (builtin-Float.< x y) (fl< x y))
|
(define-unison (builtin-Float.< x y) (fl< x y))
|
||||||
@ -876,6 +865,8 @@
|
|||||||
(define-unison (builtin-Pattern.captureAs c p)
|
(define-unison (builtin-Pattern.captureAs c p)
|
||||||
(capture-as c p))
|
(capture-as c p))
|
||||||
|
|
||||||
|
(define-unison (builtin-Pattern.many.corrected p) (many p))
|
||||||
|
|
||||||
(define-unison (builtin-Pattern.isMatch p s)
|
(define-unison (builtin-Pattern.isMatch p s)
|
||||||
(pattern-match? p s))
|
(pattern-match? p s))
|
||||||
|
|
||||||
@ -896,7 +887,7 @@
|
|||||||
(define (reify-exn thunk)
|
(define (reify-exn thunk)
|
||||||
(guard
|
(guard
|
||||||
(e [else
|
(e [else
|
||||||
(sum 0 '() (exception->string e) e)])
|
(sum 0 '() (exception->string e) ref-unit-unit)])
|
||||||
(thunk)))
|
(thunk)))
|
||||||
|
|
||||||
; Core implemented primops, upon which primops-in-unison can be built.
|
; Core implemented primops, upon which primops-in-unison can be built.
|
||||||
@ -923,7 +914,7 @@
|
|||||||
(define (unison-POp-EQLT s t) (bool (equal? s t)))
|
(define (unison-POp-EQLT s t) (bool (equal? s t)))
|
||||||
(define (unison-POp-LEQT s t) (bool (chunked-string<? s t)))
|
(define (unison-POp-LEQT s t) (bool (chunked-string<? s t)))
|
||||||
(define (unison-POp-EQLU x y) (bool (universal=? x y)))
|
(define (unison-POp-EQLU x y) (bool (universal=? x y)))
|
||||||
(define (unison-POp-EROR fnm x) ;; TODO raise the correct failure, use display
|
(define (unison-POp-EROR fnm x)
|
||||||
(let-values ([(p g) (open-string-output-port)])
|
(let-values ([(p g) (open-string-output-port)])
|
||||||
(put-string p (chunked-string->string fnm))
|
(put-string p (chunked-string->string fnm))
|
||||||
(put-string p ": ")
|
(put-string p ": ")
|
||||||
@ -977,8 +968,8 @@
|
|||||||
|
|
||||||
(define (->optional v)
|
(define (->optional v)
|
||||||
(if v
|
(if v
|
||||||
(unison-optional-some v)
|
(ref-optional-some v)
|
||||||
unison-optional-none))
|
ref-optional-none))
|
||||||
|
|
||||||
(define-unison (builtin-Text.indexOf n h)
|
(define-unison (builtin-Text.indexOf n h)
|
||||||
(->optional (chunked-string-index-of h n)))
|
(->optional (chunked-string-index-of h n)))
|
||||||
@ -1130,7 +1121,7 @@
|
|||||||
([exn:fail:contract?
|
([exn:fail:contract?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-iofailure:typelink
|
ref-iofailure:typelink
|
||||||
(string->chunked-string
|
(string->chunked-string
|
||||||
(string-append
|
(string-append
|
||||||
"Invalid UTF-8 stream: "
|
"Invalid UTF-8 stream: "
|
||||||
@ -1143,7 +1134,7 @@
|
|||||||
(bytes->chunked-bytes (string->bytes/utf-8 (chunked-string->string s))))
|
(bytes->chunked-bytes (string->bytes/utf-8 (chunked-string->string s))))
|
||||||
|
|
||||||
(define-unison (builtin-IO.isFileEOF.impl.v3 p)
|
(define-unison (builtin-IO.isFileEOF.impl.v3 p)
|
||||||
(unison-either-right (port-eof? p)))
|
(ref-either-right (port-eof? p)))
|
||||||
|
|
||||||
(define (unison-FOp-IO.closeFile.impl.v3 h)
|
(define (unison-FOp-IO.closeFile.impl.v3 h)
|
||||||
(if (input-port? h)
|
(if (input-port? h)
|
||||||
@ -1471,5 +1462,6 @@
|
|||||||
(declare-builtin-link builtin-Pattern.isMatch)
|
(declare-builtin-link builtin-Pattern.isMatch)
|
||||||
(declare-builtin-link builtin-Scope.bytearrayOf)
|
(declare-builtin-link builtin-Scope.bytearrayOf)
|
||||||
(declare-builtin-link builtin-Char.Class.is)
|
(declare-builtin-link builtin-Char.Class.is)
|
||||||
|
(declare-builtin-link builtin-Pattern.many.corrected)
|
||||||
(declare-builtin-link builtin-unsafe.coerceAbilities)
|
(declare-builtin-link builtin-unsafe.coerceAbilities)
|
||||||
)
|
)
|
||||||
|
@ -30,21 +30,22 @@
|
|||||||
[[exn:fail:network?
|
[[exn:fail:network?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-iofailure:typelink
|
ref-iofailure:typelink
|
||||||
(exception->string e) '()))]
|
(exception->string e)
|
||||||
|
ref-unit-unit))]
|
||||||
[exn:fail:contract?
|
[exn:fail:contract?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-miscfailure:typelink
|
ref-miscfailure:typelink
|
||||||
(exception->string e)
|
(exception->string e)
|
||||||
'()))]
|
ref-unit-unit))]
|
||||||
[(lambda _ #t)
|
[(lambda _ #t)
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-miscfailure:typelink
|
ref-miscfailure:typelink
|
||||||
(chunked-string->string
|
(chunked-string->string
|
||||||
(format "Unknown exception ~a" (exn->string e)))
|
(format "Unknown exception ~a" (exn->string e)))
|
||||||
e))]]
|
ref-unit-unit))]]
|
||||||
(fn)))
|
(fn)))
|
||||||
|
|
||||||
(define (closeSocket.impl.v3 socket)
|
(define (closeSocket.impl.v3 socket)
|
||||||
@ -66,9 +67,9 @@
|
|||||||
(define (socketSend.impl.v3 socket data) ; socket bytes -> ()
|
(define (socketSend.impl.v3 socket data) ; socket bytes -> ()
|
||||||
(if (not (socket-pair? socket))
|
(if (not (socket-pair? socket))
|
||||||
(exception
|
(exception
|
||||||
unison-iofailure:typelink
|
ref-iofailure:typelink
|
||||||
"Cannot send on a server socket"
|
(string->chunked-string "Cannot send on a server socket")
|
||||||
'())
|
ref-unit-unit)
|
||||||
(begin
|
(begin
|
||||||
(write-bytes (chunked-bytes->bytes data) (socket-pair-output socket))
|
(write-bytes (chunked-bytes->bytes data) (socket-pair-output socket))
|
||||||
(flush-output (socket-pair-output socket))
|
(flush-output (socket-pair-output socket))
|
||||||
@ -77,8 +78,8 @@
|
|||||||
(define (socketReceive.impl.v3 socket amt) ; socket int -> bytes
|
(define (socketReceive.impl.v3 socket amt) ; socket int -> bytes
|
||||||
(if (not (socket-pair? socket))
|
(if (not (socket-pair? socket))
|
||||||
(exception
|
(exception
|
||||||
unison-iofailure:typelink
|
ref-iofailure:typelink
|
||||||
"Cannot receive on a server socket")
|
(string->chunked-string "Cannot receive on a server socket"))
|
||||||
(handle-errors
|
(handle-errors
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(begin
|
(begin
|
||||||
@ -106,20 +107,21 @@
|
|||||||
[[exn:fail:network?
|
[[exn:fail:network?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-iofailure:typelink
|
ref-iofailure:typelink
|
||||||
(exception->string e) '()))]
|
(exception->string e)
|
||||||
|
ref-unit-unit))]
|
||||||
[exn:fail:contract?
|
[exn:fail:contract?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-iofailure:typelink
|
ref-iofailure:typelink
|
||||||
(exception->string e)
|
(exception->string e)
|
||||||
'()))]
|
ref-unit-unit))]
|
||||||
[(lambda _ #t)
|
[(lambda _ #t)
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-miscfailure:typelink
|
ref-miscfailure:typelink
|
||||||
(string->chunked-string "Unknown exception")
|
(string->chunked-string "Unknown exception")
|
||||||
e))] ]
|
ref-unit-unit))] ]
|
||||||
(let ([listener (tcp-listen (string->number port ) 4 #f (if (equal? 0 hostname) #f hostname))])
|
(let ([listener (tcp-listen (string->number port ) 4 #f (if (equal? 0 hostname) #f hostname))])
|
||||||
(right listener))))))
|
(right listener))))))
|
||||||
|
|
||||||
@ -135,9 +137,9 @@
|
|||||||
(define (socketAccept.impl.v3 listener)
|
(define (socketAccept.impl.v3 listener)
|
||||||
(if (socket-pair? listener)
|
(if (socket-pair? listener)
|
||||||
(exception
|
(exception
|
||||||
unison-iofailure:typelink
|
ref-iofailure:typelink
|
||||||
(string->chunked-string "Cannot accept on a non-server socket")
|
(string->chunked-string "Cannot accept on a non-server socket")
|
||||||
'())
|
ref-unit-unit)
|
||||||
(begin
|
(begin
|
||||||
(let-values ([(input output) (tcp-accept listener)])
|
(let-values ([(input output) (tcp-accept listener)])
|
||||||
(right (socket-pair input output))))))
|
(right (socket-pair input output))))))
|
||||||
|
@ -63,8 +63,9 @@
|
|||||||
(if (= 1 (length certs))
|
(if (= 1 (length certs))
|
||||||
(right bytes)
|
(right bytes)
|
||||||
(exception
|
(exception
|
||||||
unison-tlsfailure:typelink
|
ref-tlsfailure:typelink
|
||||||
(string->chunked-string "nope") certs)))) ; TODO passing certs is wrong, should either be converted to chunked-list or removed
|
(string->chunked-string "nope")
|
||||||
|
bytes))))
|
||||||
|
|
||||||
; We don't actually "decode" certificates, we just validate them
|
; We don't actually "decode" certificates, we just validate them
|
||||||
(define (encodeCert bytes) bytes)
|
(define (encodeCert bytes) bytes)
|
||||||
@ -112,42 +113,41 @@
|
|||||||
(define (ClientConfig.certificates.set certs config) ; list tlsSignedCert tlsClientConfig -> tlsClientConfig
|
(define (ClientConfig.certificates.set certs config) ; list tlsSignedCert tlsClientConfig -> tlsClientConfig
|
||||||
(client-config (client-config-host config) certs))
|
(client-config (client-config-host config) certs))
|
||||||
|
|
||||||
; TODO: have someone familiar with TLS verify these exception
|
|
||||||
; classifications
|
|
||||||
(define (handle-errors fn)
|
(define (handle-errors fn)
|
||||||
(with-handlers
|
(with-handlers
|
||||||
[[exn:fail:network?
|
[[exn:fail:network?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-iofailure:typelink
|
ref-iofailure:typelink
|
||||||
(exception->string e) '()))]
|
(exception->string e)
|
||||||
|
ref-unit-unit))]
|
||||||
[exn:fail:contract?
|
[exn:fail:contract?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-miscfailure:typelink
|
ref-miscfailure:typelink
|
||||||
(exception->string e)
|
(exception->string e)
|
||||||
'()))]
|
ref-unit-unit))]
|
||||||
[(lambda err
|
[(lambda err
|
||||||
(string-contains? (exn->string err) "not valid for hostname"))
|
(string-contains? (exn->string err) "not valid for hostname"))
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-tlsfailure:typelink
|
ref-tlsfailure:typelink
|
||||||
(string->chunked-string "NameMismatch")
|
(string->chunked-string "NameMismatch")
|
||||||
'()))]
|
ref-unit-unit))]
|
||||||
[(lambda err
|
[(lambda err
|
||||||
(string-contains? (exn->string err) "certificate verify failed"))
|
(string-contains? (exn->string err) "certificate verify failed"))
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-tlsfailure:typelink
|
ref-tlsfailure:typelink
|
||||||
(string->chunked-string "certificate verify failed")
|
(string->chunked-string "certificate verify failed")
|
||||||
'()))]
|
ref-unit-unit))]
|
||||||
[(lambda _ #t)
|
[(lambda _ #t)
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-miscfailure:typelink
|
ref-miscfailure:typelink
|
||||||
(string->chunked-string
|
(string->chunked-string
|
||||||
(format "Unknown exception ~a" (exn->string e)))
|
(format "Unknown exception ~a" (exn->string e)))
|
||||||
e))]]
|
ref-unit-unit))]]
|
||||||
(fn)))
|
(fn)))
|
||||||
|
|
||||||
(define (newClient.impl.v3 config socket)
|
(define (newClient.impl.v3 config socket)
|
||||||
|
@ -110,7 +110,7 @@
|
|||||||
[[exn:fail?
|
[[exn:fail?
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(exception
|
(exception
|
||||||
unison-miscfailure:typelink
|
ref-miscfailure:typelink
|
||||||
(exception->string e)
|
(exception->string e)
|
||||||
'()))]]
|
'()))]]
|
||||||
(right
|
(right
|
||||||
|
@ -13,10 +13,10 @@ usage() {
|
|||||||
prev_version="${prev_tag#release/}"
|
prev_version="${prev_tag#release/}"
|
||||||
prefix="${prev_version%.*}"
|
prefix="${prev_version%.*}"
|
||||||
next_version="${prefix}.$(( ${prev_version##*.} + 1 ))"
|
next_version="${prefix}.$(( ${prev_version##*.} + 1 ))"
|
||||||
echo "usage: $0 <version> [target]"
|
echo "usage: $0 <version> [ref]"
|
||||||
echo ""
|
echo ""
|
||||||
echo "version: The new version number"
|
echo "version: The new version number"
|
||||||
echo "target: The Git revision to make the release from, defaults to 'origin/trunk'"
|
echo "ref: The Git revision to make the release from, defaults to 'origin/trunk'"
|
||||||
echo ""
|
echo ""
|
||||||
echo "Try: $0 $next_version"
|
echo "Try: $0 $next_version"
|
||||||
}
|
}
|
||||||
@ -53,8 +53,8 @@ git fetch origin trunk
|
|||||||
git tag "${tag}" "${target}"
|
git tag "${tag}" "${target}"
|
||||||
git push origin "${tag}"
|
git push origin "${tag}"
|
||||||
gh workflow run release --repo unisonweb/unison \
|
gh workflow run release --repo unisonweb/unison \
|
||||||
--field "version=${version}" \
|
--ref "${tag}" \
|
||||||
--field "target=${target}"
|
--field "version=${version}"
|
||||||
|
|
||||||
echo "Kicking off Homebrew update task"
|
echo "Kicking off Homebrew update task"
|
||||||
gh workflow run release --repo unisonweb/homebrew-unison --field "version=${version}"
|
gh workflow run release --repo unisonweb/homebrew-unison --field "version=${version}"
|
||||||
|
114
stack.yaml
114
stack.yaml
@ -8,68 +8,70 @@ build:
|
|||||||
interleaved-output: false
|
interleaved-output: false
|
||||||
|
|
||||||
packages:
|
packages:
|
||||||
- codebase2/codebase
|
- codebase2/codebase
|
||||||
- codebase2/codebase-sqlite
|
- codebase2/codebase-sqlite
|
||||||
- codebase2/codebase-sqlite-hashing-v2
|
- codebase2/codebase-sqlite-hashing-v2
|
||||||
- codebase2/codebase-sync
|
- codebase2/codebase-sync
|
||||||
- codebase2/core
|
- codebase2/core
|
||||||
- codebase2/util-serialization
|
- codebase2/util-serialization
|
||||||
- codebase2/util-term
|
- codebase2/util-term
|
||||||
- lib/orphans/network-uri-orphans-sqlite
|
- lib/orphans/network-uri-orphans-sqlite
|
||||||
- lib/orphans/unison-core-orphans-sqlite
|
- lib/orphans/unison-core-orphans-sqlite
|
||||||
- lib/orphans/unison-hash-orphans-aeson
|
- lib/orphans/unison-hash-orphans-aeson
|
||||||
- lib/orphans/unison-hash-orphans-sqlite
|
- lib/orphans/unison-hash-orphans-sqlite
|
||||||
- lib/orphans/uuid-orphans-sqlite
|
- lib/orphans/uuid-orphans-sqlite
|
||||||
- lib/unison-hash
|
- lib/unison-hash
|
||||||
- lib/unison-hashing
|
- lib/unison-hashing
|
||||||
- lib/unison-prelude
|
- lib/unison-prelude
|
||||||
- lib/unison-pretty-printer
|
- lib/unison-pretty-printer
|
||||||
- lib/unison-sqlite
|
- lib/unison-sqlite
|
||||||
- lib/unison-util-base32hex
|
- lib/unison-util-base32hex
|
||||||
- lib/unison-util-bytes
|
- lib/unison-util-bytes
|
||||||
- lib/unison-util-cache
|
- lib/unison-util-cache
|
||||||
- lib/unison-util-file-embed
|
- lib/unison-util-file-embed
|
||||||
- lib/unison-util-nametree
|
- lib/unison-util-nametree
|
||||||
- lib/unison-util-relation
|
- lib/unison-util-relation
|
||||||
- lib/unison-util-rope
|
- lib/unison-util-rope
|
||||||
- parser-typechecker
|
- parser-typechecker
|
||||||
- unison-cli
|
- unison-cli
|
||||||
- unison-core
|
- unison-cli-integration
|
||||||
- unison-hashing-v2
|
- unison-cli-main
|
||||||
- unison-merge
|
- unison-core
|
||||||
- unison-share-api
|
- unison-hashing-v2
|
||||||
- unison-share-projects-api
|
- unison-merge
|
||||||
- unison-syntax
|
- unison-share-api
|
||||||
- yaks/easytest
|
- unison-share-projects-api
|
||||||
|
- unison-syntax
|
||||||
|
- yaks/easytest
|
||||||
|
|
||||||
resolver: lts-20.26
|
resolver: lts-20.26
|
||||||
|
|
||||||
extra-deps:
|
extra-deps:
|
||||||
# broken version in snapshot
|
# broken version in snapshot
|
||||||
- github: unisonweb/configurator
|
- github: unisonweb/configurator
|
||||||
commit: e47e9e9fe1f576f8c835183b9def52d73c01327a
|
commit: e47e9e9fe1f576f8c835183b9def52d73c01327a
|
||||||
# This custom Haskeline alters ANSI rendering on Windows.
|
# This custom Haskeline alters ANSI rendering on Windows.
|
||||||
# If changing the haskeline dependency, please ensure color renders properly in a
|
# If changing the haskeline dependency, please ensure color renders properly in a
|
||||||
# Windows terminal.
|
# Windows terminal.
|
||||||
# https://github.com/judah/haskeline/pull/126
|
# https://github.com/judah/haskeline/pull/126
|
||||||
- github: unisonweb/haskeline
|
- github: unisonweb/haskeline
|
||||||
commit: 9275eea7982dabbf47be2ba078ced669ae7ef3d5
|
commit: 9275eea7982dabbf47be2ba078ced669ae7ef3d5
|
||||||
|
|
||||||
# not in stackage
|
# not in stackage
|
||||||
- fuzzyfind-3.0.1
|
- fuzzyfind-3.0.1
|
||||||
- guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078
|
- guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078
|
||||||
- lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484
|
- lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484
|
||||||
- monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505
|
- monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505
|
||||||
- recover-rtti-0.4.2@sha256:c179a303921126d8d782264e14f386c96e54a270df74be002e4c4ec3c8c7aebd,4529
|
- recover-rtti-0.4.2@sha256:c179a303921126d8d782264e14f386c96e54a270df74be002e4c4ec3c8c7aebd,4529
|
||||||
- lsp-2.2.0.0@sha256:82fbf4b69d94d8d22543be71f89986b3e90050032d671fb3de3f8253ea1e5b6f,3550
|
- lsp-2.2.0.0@sha256:82fbf4b69d94d8d22543be71f89986b3e90050032d671fb3de3f8253ea1e5b6f,3550
|
||||||
- lsp-types-2.0.2.0@sha256:a9a51c3cea0726d91fe63fa0670935ee720f7b31bc3f3b33b2483fc538152677,29421
|
- lsp-types-2.0.2.0@sha256:a9a51c3cea0726d91fe63fa0670935ee720f7b31bc3f3b33b2483fc538152677,29421
|
||||||
- row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071
|
- row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071
|
||||||
|
|
||||||
ghc-options:
|
ghc-options:
|
||||||
# All packages
|
# All packages
|
||||||
"$locals": -Wall -Werror -Wno-name-shadowing -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info #-freverse-errors
|
"$locals": -Wall -Werror -Wno-name-shadowing -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info #-freverse-errors
|
||||||
|
|
||||||
# See https://github.com/haskell/haskell-language-server/issues/208
|
# See https://github.com/haskell/haskell-language-server/issues/208
|
||||||
"$everything": -haddock
|
"$everything": -haddock
|
||||||
|
|
||||||
statistics: -fsimpl-tick-factor=10000 # statistics fails on GHC 9 without this, https://github.com/haskell/statistics/issues/173
|
statistics: -fsimpl-tick-factor=10000 # statistics fails on GHC 9 without this, https://github.com/haskell/statistics/issues/173
|
||||||
|
@ -12,7 +12,7 @@ import System.Process (readProcessWithExitCode)
|
|||||||
import Text.Printf
|
import Text.Printf
|
||||||
|
|
||||||
integrationTestsDir :: FilePath
|
integrationTestsDir :: FilePath
|
||||||
integrationTestsDir = "unison-cli" </> "integration-tests" </> "IntegrationTests"
|
integrationTestsDir = "unison-cli-integration" </> "integration-tests" </> "IntegrationTests"
|
||||||
|
|
||||||
uFile :: FilePath
|
uFile :: FilePath
|
||||||
uFile = integrationTestsDir </> "print.u"
|
uFile = integrationTestsDir </> "print.u"
|
@ -40,5 +40,5 @@ main = do
|
|||||||
|
|
||||||
```ucm
|
```ucm
|
||||||
.> add
|
.> add
|
||||||
.> compile main ./unison-cli/integration-tests/IntegrationTests/main
|
.> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main
|
||||||
```
|
```
|
@ -29,14 +29,16 @@ main = do
|
|||||||
|
|
||||||
```ucm
|
```ucm
|
||||||
|
|
||||||
|
Loading changes detected in scratch.u.
|
||||||
|
|
||||||
I found and typechecked these definitions in scratch.u. If you
|
I found and typechecked these definitions in scratch.u. If you
|
||||||
do an `add` or `update`, here's how your codebase would
|
do an `add` or `update`, here's how your codebase would
|
||||||
change:
|
change:
|
||||||
|
|
||||||
⍟ These new definitions are ok to `add`:
|
⍟ These new definitions are ok to `add`:
|
||||||
|
|
||||||
structural ability Break
|
structural ability Break
|
||||||
unique type MyBool
|
type MyBool
|
||||||
main : '{IO, Exception} ()
|
main : '{IO, Exception} ()
|
||||||
resume : Request {g, Break} x -> x
|
resume : Request {g, Break} x -> x
|
||||||
|
|
||||||
@ -45,12 +47,12 @@ main = do
|
|||||||
.> add
|
.> add
|
||||||
|
|
||||||
⍟ I've added these definitions:
|
⍟ I've added these definitions:
|
||||||
|
|
||||||
structural ability Break
|
structural ability Break
|
||||||
unique type MyBool
|
type MyBool
|
||||||
main : '{IO, Exception} ()
|
main : '{IO, Exception} ()
|
||||||
resume : Request {g, Break} x -> x
|
resume : Request {g, Break} x -> x
|
||||||
|
|
||||||
.> compile main ./unison-cli/integration-tests/IntegrationTests/main
|
.> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main
|
||||||
|
|
||||||
```
|
```
|
68
unison-cli-integration/package.yaml
Normal file
68
unison-cli-integration/package.yaml
Normal file
@ -0,0 +1,68 @@
|
|||||||
|
name: unison-cli-integration
|
||||||
|
github: unisonweb/unison
|
||||||
|
copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors
|
||||||
|
|
||||||
|
flags:
|
||||||
|
optimized:
|
||||||
|
manual: true
|
||||||
|
default: false
|
||||||
|
|
||||||
|
ghc-options: -Wall
|
||||||
|
|
||||||
|
executables:
|
||||||
|
cli-integration-tests:
|
||||||
|
when:
|
||||||
|
- condition: false
|
||||||
|
other-modules: Paths_unison_cli_integration
|
||||||
|
source-dirs: integration-tests
|
||||||
|
main: Suite.hs
|
||||||
|
ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0
|
||||||
|
dependencies:
|
||||||
|
- base
|
||||||
|
- code-page
|
||||||
|
- filepath
|
||||||
|
- directory
|
||||||
|
- easytest
|
||||||
|
- process
|
||||||
|
- shellmet
|
||||||
|
- time
|
||||||
|
build-tools:
|
||||||
|
- unison-cli-main:unison
|
||||||
|
|
||||||
|
when:
|
||||||
|
- condition: flag(optimized)
|
||||||
|
ghc-options: -O2 -funbox-strict-fields
|
||||||
|
|
||||||
|
default-extensions:
|
||||||
|
- ApplicativeDo
|
||||||
|
- BangPatterns
|
||||||
|
- BlockArguments
|
||||||
|
- DeriveAnyClass
|
||||||
|
- DeriveFunctor
|
||||||
|
- DeriveFoldable
|
||||||
|
- DeriveTraversable
|
||||||
|
- DeriveGeneric
|
||||||
|
- DerivingStrategies
|
||||||
|
- DerivingVia
|
||||||
|
- DoAndIfThenElse
|
||||||
|
- DuplicateRecordFields
|
||||||
|
- FlexibleContexts
|
||||||
|
- FlexibleInstances
|
||||||
|
- GADTs
|
||||||
|
- GeneralizedNewtypeDeriving
|
||||||
|
- ImportQualifiedPost
|
||||||
|
- InstanceSigs
|
||||||
|
- KindSignatures
|
||||||
|
- LambdaCase
|
||||||
|
- MultiParamTypeClasses
|
||||||
|
- MultiWayIf
|
||||||
|
- NamedFieldPuns
|
||||||
|
- NumericUnderscores
|
||||||
|
- OverloadedLabels
|
||||||
|
- OverloadedStrings
|
||||||
|
- PatternSynonyms
|
||||||
|
- RankNTypes
|
||||||
|
- ScopedTypeVariables
|
||||||
|
- TupleSections
|
||||||
|
- TypeApplications
|
||||||
|
- ViewPatterns
|
75
unison-cli-integration/unison-cli-integration.cabal
Normal file
75
unison-cli-integration/unison-cli-integration.cabal
Normal file
@ -0,0 +1,75 @@
|
|||||||
|
cabal-version: 1.12
|
||||||
|
|
||||||
|
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||||
|
--
|
||||||
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
|
name: unison-cli-integration
|
||||||
|
version: 0.0.0
|
||||||
|
homepage: https://github.com/unisonweb/unison#readme
|
||||||
|
bug-reports: https://github.com/unisonweb/unison/issues
|
||||||
|
copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors
|
||||||
|
build-type: Simple
|
||||||
|
|
||||||
|
source-repository head
|
||||||
|
type: git
|
||||||
|
location: https://github.com/unisonweb/unison
|
||||||
|
|
||||||
|
flag optimized
|
||||||
|
manual: True
|
||||||
|
default: False
|
||||||
|
|
||||||
|
executable cli-integration-tests
|
||||||
|
main-is: Suite.hs
|
||||||
|
other-modules:
|
||||||
|
IntegrationTests.ArgumentParsing
|
||||||
|
hs-source-dirs:
|
||||||
|
integration-tests
|
||||||
|
default-extensions:
|
||||||
|
ApplicativeDo
|
||||||
|
BangPatterns
|
||||||
|
BlockArguments
|
||||||
|
DeriveAnyClass
|
||||||
|
DeriveFunctor
|
||||||
|
DeriveFoldable
|
||||||
|
DeriveTraversable
|
||||||
|
DeriveGeneric
|
||||||
|
DerivingStrategies
|
||||||
|
DerivingVia
|
||||||
|
DoAndIfThenElse
|
||||||
|
DuplicateRecordFields
|
||||||
|
FlexibleContexts
|
||||||
|
FlexibleInstances
|
||||||
|
GADTs
|
||||||
|
GeneralizedNewtypeDeriving
|
||||||
|
ImportQualifiedPost
|
||||||
|
InstanceSigs
|
||||||
|
KindSignatures
|
||||||
|
LambdaCase
|
||||||
|
MultiParamTypeClasses
|
||||||
|
MultiWayIf
|
||||||
|
NamedFieldPuns
|
||||||
|
NumericUnderscores
|
||||||
|
OverloadedLabels
|
||||||
|
OverloadedStrings
|
||||||
|
PatternSynonyms
|
||||||
|
RankNTypes
|
||||||
|
ScopedTypeVariables
|
||||||
|
TupleSections
|
||||||
|
TypeApplications
|
||||||
|
ViewPatterns
|
||||||
|
ghc-options: -Wall -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0
|
||||||
|
build-tool-depends:
|
||||||
|
unison-cli-main:unison
|
||||||
|
build-depends:
|
||||||
|
base
|
||||||
|
, code-page
|
||||||
|
, directory
|
||||||
|
, easytest
|
||||||
|
, filepath
|
||||||
|
, process
|
||||||
|
, shellmet
|
||||||
|
, time
|
||||||
|
default-language: Haskell2010
|
||||||
|
if flag(optimized)
|
||||||
|
ghc-options: -O2 -funbox-strict-fields
|
19
unison-cli-main/LICENSE
Normal file
19
unison-cli-main/LICENSE
Normal file
@ -0,0 +1,19 @@
|
|||||||
|
Copyright (c) 2021, Unison Computing, public benefit corp and contributors
|
||||||
|
|
||||||
|
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||||
|
of this software and associated documentation files (the "Software"), to deal
|
||||||
|
in the Software without restriction, including without limitation the rights
|
||||||
|
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||||
|
copies of the Software, and to permit persons to whom the Software is
|
||||||
|
furnished to do so, subject to the following conditions:
|
||||||
|
|
||||||
|
The above copyright notice and this permission notice shall be included in
|
||||||
|
all copies or substantial portions of the Software.
|
||||||
|
|
||||||
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||||
|
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||||
|
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||||
|
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||||
|
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||||
|
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
|
||||||
|
THE SOFTWARE.
|
63
unison-cli-main/package.yaml
Normal file
63
unison-cli-main/package.yaml
Normal file
@ -0,0 +1,63 @@
|
|||||||
|
name: unison-cli-main
|
||||||
|
github: unisonweb/unison
|
||||||
|
copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors
|
||||||
|
|
||||||
|
flags:
|
||||||
|
optimized:
|
||||||
|
manual: true
|
||||||
|
default: false
|
||||||
|
|
||||||
|
ghc-options: -Wall
|
||||||
|
|
||||||
|
executables:
|
||||||
|
unison:
|
||||||
|
when:
|
||||||
|
- condition: false
|
||||||
|
other-modules: Paths_unison_cli_main
|
||||||
|
source-dirs: unison
|
||||||
|
main: Main.hs
|
||||||
|
ghc-options: -threaded -rtsopts "-with-rtsopts=-I0 -N -qn4 -qg1 -T" -optP-Wno-nonportable-include-path
|
||||||
|
dependencies:
|
||||||
|
- base
|
||||||
|
- shellmet
|
||||||
|
- template-haskell
|
||||||
|
- text
|
||||||
|
- unison-cli
|
||||||
|
|
||||||
|
when:
|
||||||
|
- condition: flag(optimized)
|
||||||
|
ghc-options: -O2 -funbox-strict-fields
|
||||||
|
|
||||||
|
default-extensions:
|
||||||
|
- ApplicativeDo
|
||||||
|
- BangPatterns
|
||||||
|
- BlockArguments
|
||||||
|
- DeriveAnyClass
|
||||||
|
- DeriveFunctor
|
||||||
|
- DeriveFoldable
|
||||||
|
- DeriveTraversable
|
||||||
|
- DeriveGeneric
|
||||||
|
- DerivingStrategies
|
||||||
|
- DerivingVia
|
||||||
|
- DoAndIfThenElse
|
||||||
|
- DuplicateRecordFields
|
||||||
|
- FlexibleContexts
|
||||||
|
- FlexibleInstances
|
||||||
|
- GADTs
|
||||||
|
- GeneralizedNewtypeDeriving
|
||||||
|
- ImportQualifiedPost
|
||||||
|
- InstanceSigs
|
||||||
|
- KindSignatures
|
||||||
|
- LambdaCase
|
||||||
|
- MultiParamTypeClasses
|
||||||
|
- MultiWayIf
|
||||||
|
- NamedFieldPuns
|
||||||
|
- NumericUnderscores
|
||||||
|
- OverloadedLabels
|
||||||
|
- OverloadedStrings
|
||||||
|
- PatternSynonyms
|
||||||
|
- RankNTypes
|
||||||
|
- ScopedTypeVariables
|
||||||
|
- TupleSections
|
||||||
|
- TypeApplications
|
||||||
|
- ViewPatterns
|
72
unison-cli-main/unison-cli-main.cabal
Normal file
72
unison-cli-main/unison-cli-main.cabal
Normal file
@ -0,0 +1,72 @@
|
|||||||
|
cabal-version: 1.12
|
||||||
|
|
||||||
|
-- This file has been generated from package.yaml by hpack version 0.36.0.
|
||||||
|
--
|
||||||
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
|
name: unison-cli-main
|
||||||
|
version: 0.0.0
|
||||||
|
homepage: https://github.com/unisonweb/unison#readme
|
||||||
|
bug-reports: https://github.com/unisonweb/unison/issues
|
||||||
|
copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors
|
||||||
|
license: MIT
|
||||||
|
license-file: LICENSE
|
||||||
|
build-type: Simple
|
||||||
|
|
||||||
|
source-repository head
|
||||||
|
type: git
|
||||||
|
location: https://github.com/unisonweb/unison
|
||||||
|
|
||||||
|
flag optimized
|
||||||
|
manual: True
|
||||||
|
default: False
|
||||||
|
|
||||||
|
executable unison
|
||||||
|
main-is: Main.hs
|
||||||
|
other-modules:
|
||||||
|
Version
|
||||||
|
hs-source-dirs:
|
||||||
|
unison
|
||||||
|
default-extensions:
|
||||||
|
ApplicativeDo
|
||||||
|
BangPatterns
|
||||||
|
BlockArguments
|
||||||
|
DeriveAnyClass
|
||||||
|
DeriveFunctor
|
||||||
|
DeriveFoldable
|
||||||
|
DeriveTraversable
|
||||||
|
DeriveGeneric
|
||||||
|
DerivingStrategies
|
||||||
|
DerivingVia
|
||||||
|
DoAndIfThenElse
|
||||||
|
DuplicateRecordFields
|
||||||
|
FlexibleContexts
|
||||||
|
FlexibleInstances
|
||||||
|
GADTs
|
||||||
|
GeneralizedNewtypeDeriving
|
||||||
|
ImportQualifiedPost
|
||||||
|
InstanceSigs
|
||||||
|
KindSignatures
|
||||||
|
LambdaCase
|
||||||
|
MultiParamTypeClasses
|
||||||
|
MultiWayIf
|
||||||
|
NamedFieldPuns
|
||||||
|
NumericUnderscores
|
||||||
|
OverloadedLabels
|
||||||
|
OverloadedStrings
|
||||||
|
PatternSynonyms
|
||||||
|
RankNTypes
|
||||||
|
ScopedTypeVariables
|
||||||
|
TupleSections
|
||||||
|
TypeApplications
|
||||||
|
ViewPatterns
|
||||||
|
ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-I0 -N -qn4 -qg1 -T" -optP-Wno-nonportable-include-path
|
||||||
|
build-depends:
|
||||||
|
base
|
||||||
|
, shellmet
|
||||||
|
, template-haskell
|
||||||
|
, text
|
||||||
|
, unison-cli
|
||||||
|
default-language: Haskell2010
|
||||||
|
if flag(optimized)
|
||||||
|
ghc-options: -O2 -funbox-strict-fields
|
15
unison-cli-main/unison/Main.hs
Normal file
15
unison-cli-main/unison/Main.hs
Normal file
@ -0,0 +1,15 @@
|
|||||||
|
{-# LANGUAGE ApplicativeDo #-}
|
||||||
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
|
{-# LANGUAGE PartialTypeSignatures #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
|
||||||
|
|
||||||
|
module Main (main) where
|
||||||
|
|
||||||
|
import Unison.Main qualified
|
||||||
|
import Version (version)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = Unison.Main.main version
|
@ -1,7 +1,7 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
module Version where
|
module Version (version) where
|
||||||
|
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Data.Text
|
import Data.Text
|
||||||
@ -9,6 +9,10 @@ import Data.Text qualified as Text
|
|||||||
import Language.Haskell.TH (Exp (TupE), runIO)
|
import Language.Haskell.TH (Exp (TupE), runIO)
|
||||||
import Language.Haskell.TH.Syntax (Exp (LitE), Lit (StringL))
|
import Language.Haskell.TH.Syntax (Exp (LitE), Lit (StringL))
|
||||||
import Shellmet
|
import Shellmet
|
||||||
|
import Unison.Version (CommitDate, GitRef, Version (Version))
|
||||||
|
|
||||||
|
version :: Version
|
||||||
|
version = Version gitDescribeWithDate gitDescribe
|
||||||
|
|
||||||
-- | A formatted descriptor of when and against which commit this unison executable was built
|
-- | A formatted descriptor of when and against which commit this unison executable was built
|
||||||
-- E.g. latest-149-g5cef8f851 (built on 2021-10-04)
|
-- E.g. latest-149-g5cef8f851 (built on 2021-10-04)
|
||||||
@ -16,13 +20,9 @@ import Shellmet
|
|||||||
gitDescribeWithDate :: Text
|
gitDescribeWithDate :: Text
|
||||||
gitDescribeWithDate =
|
gitDescribeWithDate =
|
||||||
let formatDate d = " (built on " <> d <> ")"
|
let formatDate d = " (built on " <> d <> ")"
|
||||||
(gitRef, date) = gitDescribe
|
(gitRef, date) = Version.gitDescribe
|
||||||
in gitRef <> formatDate date
|
in gitRef <> formatDate date
|
||||||
|
|
||||||
type CommitDate = Text
|
|
||||||
|
|
||||||
type GitRef = Text
|
|
||||||
|
|
||||||
-- | Uses Template Haskell to embed a git descriptor of the commit
|
-- | Uses Template Haskell to embed a git descriptor of the commit
|
||||||
-- which was used to build the executable.
|
-- which was used to build the executable.
|
||||||
-- E.g. latest-149-g5cef8f851 (built on 2021-10-04)
|
-- E.g. latest-149-g5cef8f851 (built on 2021-10-04)
|
@ -20,6 +20,7 @@ dependencies:
|
|||||||
- bytes
|
- bytes
|
||||||
- bytestring
|
- bytestring
|
||||||
- co-log-core
|
- co-log-core
|
||||||
|
- code-page
|
||||||
- concurrent-output
|
- concurrent-output
|
||||||
- configurator
|
- configurator
|
||||||
- containers >= 0.6.3
|
- containers >= 0.6.3
|
||||||
@ -53,6 +54,7 @@ dependencies:
|
|||||||
- network-uri
|
- network-uri
|
||||||
- nonempty-containers
|
- nonempty-containers
|
||||||
- open-browser
|
- open-browser
|
||||||
|
- optparse-applicative >= 0.16.1.0
|
||||||
- pretty-simple
|
- pretty-simple
|
||||||
- process
|
- process
|
||||||
- random >= 1.2.0
|
- random >= 1.2.0
|
||||||
@ -63,7 +65,10 @@ dependencies:
|
|||||||
- semigroups
|
- semigroups
|
||||||
- servant
|
- servant
|
||||||
- servant-client
|
- servant-client
|
||||||
|
- shellmet
|
||||||
- stm
|
- stm
|
||||||
|
- template-haskell
|
||||||
|
- temporary
|
||||||
- text
|
- text
|
||||||
- text-builder
|
- text-builder
|
||||||
- text-rope
|
- text-rope
|
||||||
@ -97,15 +102,28 @@ dependencies:
|
|||||||
- warp
|
- warp
|
||||||
- witch
|
- witch
|
||||||
- witherable
|
- witherable
|
||||||
- witherable
|
|
||||||
|
internal-libraries:
|
||||||
|
unison-cli-lib:
|
||||||
|
source-dirs: src
|
||||||
|
when:
|
||||||
|
- condition: "!os(windows)"
|
||||||
|
dependencies: unix
|
||||||
|
- condition: false
|
||||||
|
other-modules: Paths_unison_cli
|
||||||
|
|
||||||
library:
|
library:
|
||||||
source-dirs: src
|
source-dirs: unison
|
||||||
when:
|
when:
|
||||||
- condition: '!os(windows)'
|
|
||||||
dependencies: unix
|
|
||||||
- condition: false
|
- condition: false
|
||||||
other-modules: Paths_unison_cli
|
other-modules: Paths_unison_cli
|
||||||
|
dependencies:
|
||||||
|
- code-page
|
||||||
|
- optparse-applicative >= 0.16.1.0
|
||||||
|
- shellmet
|
||||||
|
- template-haskell
|
||||||
|
- temporary
|
||||||
|
- unison-cli-lib
|
||||||
|
|
||||||
tests:
|
tests:
|
||||||
cli-tests:
|
cli-tests:
|
||||||
@ -118,26 +136,11 @@ tests:
|
|||||||
- here
|
- here
|
||||||
- shellmet
|
- shellmet
|
||||||
- temporary
|
- temporary
|
||||||
- unison-cli
|
- unison-cli-lib
|
||||||
main: Main.hs
|
main: Main.hs
|
||||||
source-dirs: tests
|
source-dirs: tests
|
||||||
|
|
||||||
executables:
|
executables:
|
||||||
unison:
|
|
||||||
when:
|
|
||||||
- condition: false
|
|
||||||
other-modules: Paths_unison_cli
|
|
||||||
source-dirs: unison
|
|
||||||
main: Main.hs
|
|
||||||
ghc-options: -threaded -rtsopts "-with-rtsopts=-I0 -N -qn4 -qg1 -T" -optP-Wno-nonportable-include-path
|
|
||||||
dependencies:
|
|
||||||
- code-page
|
|
||||||
- optparse-applicative >= 0.16.1.0
|
|
||||||
- shellmet
|
|
||||||
- template-haskell
|
|
||||||
- temporary
|
|
||||||
- unison-cli
|
|
||||||
|
|
||||||
transcripts:
|
transcripts:
|
||||||
when:
|
when:
|
||||||
- condition: false
|
- condition: false
|
||||||
@ -150,25 +153,9 @@ executables:
|
|||||||
- easytest
|
- easytest
|
||||||
- process
|
- process
|
||||||
- shellmet
|
- shellmet
|
||||||
- unison-cli
|
- unison-cli-lib
|
||||||
- silently
|
- silently
|
||||||
|
|
||||||
cli-integration-tests:
|
|
||||||
when:
|
|
||||||
- condition: false
|
|
||||||
other-modules: Paths_unison_cli
|
|
||||||
source-dirs: integration-tests
|
|
||||||
main: Suite.hs
|
|
||||||
ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0
|
|
||||||
dependencies:
|
|
||||||
- code-page
|
|
||||||
- easytest
|
|
||||||
- process
|
|
||||||
- shellmet
|
|
||||||
- time
|
|
||||||
build-tools:
|
|
||||||
- unison-cli:unison
|
|
||||||
|
|
||||||
when:
|
when:
|
||||||
- condition: flag(optimized)
|
- condition: flag(optimized)
|
||||||
ghc-options: -O2 -funbox-strict-fields
|
ghc-options: -O2 -funbox-strict-fields
|
||||||
|
@ -2523,7 +2523,7 @@ runScheme =
|
|||||||
InputPattern
|
InputPattern
|
||||||
"run.native"
|
"run.native"
|
||||||
[]
|
[]
|
||||||
I.Visible
|
I.Hidden
|
||||||
[("definition to run", Required, exactDefinitionTermQueryArg), ("arguments", ZeroPlus, noCompletionsArg)]
|
[("definition to run", Required, exactDefinitionTermQueryArg), ("arguments", ZeroPlus, noCompletionsArg)]
|
||||||
( P.wrapColumn2
|
( P.wrapColumn2
|
||||||
[ ( makeExample runScheme ["main", "args"],
|
[ ( makeExample runScheme ["main", "args"],
|
||||||
@ -2540,7 +2540,7 @@ compileScheme =
|
|||||||
InputPattern
|
InputPattern
|
||||||
"compile.native"
|
"compile.native"
|
||||||
[]
|
[]
|
||||||
I.Visible
|
I.Hidden
|
||||||
[("definition to compile", Required, exactDefinitionTermQueryArg), ("output file", Required, filePathArg)]
|
[("definition to compile", Required, exactDefinitionTermQueryArg), ("output file", Required, filePathArg)]
|
||||||
( P.wrapColumn2
|
( P.wrapColumn2
|
||||||
[ ( makeExample compileScheme ["main", "file"],
|
[ ( makeExample compileScheme ["main", "file"],
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
cabal-version: 1.12
|
cabal-version: 2.0
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.36.0.
|
-- This file has been generated from package.yaml by hpack version 0.36.0.
|
||||||
--
|
--
|
||||||
@ -22,6 +22,147 @@ flag optimized
|
|||||||
default: False
|
default: False
|
||||||
|
|
||||||
library
|
library
|
||||||
|
exposed-modules:
|
||||||
|
ArgParse
|
||||||
|
Stats
|
||||||
|
System.Path
|
||||||
|
Unison.Main
|
||||||
|
Unison.Version
|
||||||
|
hs-source-dirs:
|
||||||
|
unison
|
||||||
|
default-extensions:
|
||||||
|
ApplicativeDo
|
||||||
|
BangPatterns
|
||||||
|
BlockArguments
|
||||||
|
DeriveAnyClass
|
||||||
|
DeriveFunctor
|
||||||
|
DeriveFoldable
|
||||||
|
DeriveTraversable
|
||||||
|
DeriveGeneric
|
||||||
|
DerivingStrategies
|
||||||
|
DerivingVia
|
||||||
|
DoAndIfThenElse
|
||||||
|
DuplicateRecordFields
|
||||||
|
FlexibleContexts
|
||||||
|
FlexibleInstances
|
||||||
|
GADTs
|
||||||
|
GeneralizedNewtypeDeriving
|
||||||
|
ImportQualifiedPost
|
||||||
|
InstanceSigs
|
||||||
|
KindSignatures
|
||||||
|
LambdaCase
|
||||||
|
MultiParamTypeClasses
|
||||||
|
MultiWayIf
|
||||||
|
NamedFieldPuns
|
||||||
|
NumericUnderscores
|
||||||
|
OverloadedLabels
|
||||||
|
OverloadedStrings
|
||||||
|
PatternSynonyms
|
||||||
|
RankNTypes
|
||||||
|
ScopedTypeVariables
|
||||||
|
TupleSections
|
||||||
|
TypeApplications
|
||||||
|
ViewPatterns
|
||||||
|
ghc-options: -Wall
|
||||||
|
build-depends:
|
||||||
|
IntervalMap
|
||||||
|
, ListLike
|
||||||
|
, aeson >=2.0.0.0
|
||||||
|
, aeson-pretty
|
||||||
|
, ansi-terminal
|
||||||
|
, async
|
||||||
|
, base
|
||||||
|
, bytes
|
||||||
|
, bytestring
|
||||||
|
, co-log-core
|
||||||
|
, code-page
|
||||||
|
, concurrent-output
|
||||||
|
, configurator
|
||||||
|
, containers >=0.6.3
|
||||||
|
, cryptonite
|
||||||
|
, directory
|
||||||
|
, either
|
||||||
|
, errors
|
||||||
|
, exceptions
|
||||||
|
, extra
|
||||||
|
, filepath
|
||||||
|
, free
|
||||||
|
, friendly-time
|
||||||
|
, fsnotify
|
||||||
|
, fuzzyfind
|
||||||
|
, generic-lens
|
||||||
|
, haskeline
|
||||||
|
, http-client >=0.7.6
|
||||||
|
, http-client-tls
|
||||||
|
, http-types
|
||||||
|
, jwt
|
||||||
|
, ki
|
||||||
|
, lens
|
||||||
|
, lock-file
|
||||||
|
, lsp >=2.2.0.0
|
||||||
|
, lsp-types >=2.0.2.0
|
||||||
|
, megaparsec
|
||||||
|
, memory
|
||||||
|
, mtl
|
||||||
|
, network
|
||||||
|
, network-simple
|
||||||
|
, network-uri
|
||||||
|
, nonempty-containers
|
||||||
|
, open-browser
|
||||||
|
, optparse-applicative >=0.16.1.0
|
||||||
|
, pretty-simple
|
||||||
|
, process
|
||||||
|
, random >=1.2.0
|
||||||
|
, random-shuffle
|
||||||
|
, recover-rtti
|
||||||
|
, regex-tdfa
|
||||||
|
, semialign
|
||||||
|
, semigroups
|
||||||
|
, servant
|
||||||
|
, servant-client
|
||||||
|
, shellmet
|
||||||
|
, stm
|
||||||
|
, template-haskell
|
||||||
|
, temporary
|
||||||
|
, text
|
||||||
|
, text-builder
|
||||||
|
, text-rope
|
||||||
|
, these
|
||||||
|
, these-lens
|
||||||
|
, time
|
||||||
|
, transformers
|
||||||
|
, unison-cli-lib
|
||||||
|
, unison-codebase
|
||||||
|
, unison-codebase-sqlite
|
||||||
|
, unison-codebase-sqlite-hashing-v2
|
||||||
|
, unison-core
|
||||||
|
, unison-core1
|
||||||
|
, unison-hash
|
||||||
|
, unison-merge
|
||||||
|
, unison-parser-typechecker
|
||||||
|
, unison-prelude
|
||||||
|
, unison-pretty-printer
|
||||||
|
, unison-share-api
|
||||||
|
, unison-share-projects-api
|
||||||
|
, unison-sqlite
|
||||||
|
, unison-syntax
|
||||||
|
, unison-util-base32hex
|
||||||
|
, unison-util-nametree
|
||||||
|
, unison-util-relation
|
||||||
|
, unliftio
|
||||||
|
, unordered-containers
|
||||||
|
, uri-encode
|
||||||
|
, uuid
|
||||||
|
, vector
|
||||||
|
, wai
|
||||||
|
, warp
|
||||||
|
, witch
|
||||||
|
, witherable
|
||||||
|
default-language: Haskell2010
|
||||||
|
if flag(optimized)
|
||||||
|
ghc-options: -O2 -funbox-strict-fields
|
||||||
|
|
||||||
|
library unison-cli-lib
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Compat
|
Compat
|
||||||
Unison.Auth.CredentialFile
|
Unison.Auth.CredentialFile
|
||||||
@ -180,6 +321,7 @@ library
|
|||||||
, bytes
|
, bytes
|
||||||
, bytestring
|
, bytestring
|
||||||
, co-log-core
|
, co-log-core
|
||||||
|
, code-page
|
||||||
, concurrent-output
|
, concurrent-output
|
||||||
, configurator
|
, configurator
|
||||||
, containers >=0.6.3
|
, containers >=0.6.3
|
||||||
@ -213,6 +355,7 @@ library
|
|||||||
, network-uri
|
, network-uri
|
||||||
, nonempty-containers
|
, nonempty-containers
|
||||||
, open-browser
|
, open-browser
|
||||||
|
, optparse-applicative >=0.16.1.0
|
||||||
, pretty-simple
|
, pretty-simple
|
||||||
, process
|
, process
|
||||||
, random >=1.2.0
|
, random >=1.2.0
|
||||||
@ -223,7 +366,10 @@ library
|
|||||||
, semigroups
|
, semigroups
|
||||||
, servant
|
, servant
|
||||||
, servant-client
|
, servant-client
|
||||||
|
, shellmet
|
||||||
, stm
|
, stm
|
||||||
|
, template-haskell
|
||||||
|
, temporary
|
||||||
, text
|
, text
|
||||||
, text-builder
|
, text-builder
|
||||||
, text-rope
|
, text-rope
|
||||||
@ -264,143 +410,6 @@ library
|
|||||||
build-depends:
|
build-depends:
|
||||||
unix
|
unix
|
||||||
|
|
||||||
executable cli-integration-tests
|
|
||||||
main-is: Suite.hs
|
|
||||||
other-modules:
|
|
||||||
IntegrationTests.ArgumentParsing
|
|
||||||
hs-source-dirs:
|
|
||||||
integration-tests
|
|
||||||
default-extensions:
|
|
||||||
ApplicativeDo
|
|
||||||
BangPatterns
|
|
||||||
BlockArguments
|
|
||||||
DeriveAnyClass
|
|
||||||
DeriveFunctor
|
|
||||||
DeriveFoldable
|
|
||||||
DeriveTraversable
|
|
||||||
DeriveGeneric
|
|
||||||
DerivingStrategies
|
|
||||||
DerivingVia
|
|
||||||
DoAndIfThenElse
|
|
||||||
DuplicateRecordFields
|
|
||||||
FlexibleContexts
|
|
||||||
FlexibleInstances
|
|
||||||
GADTs
|
|
||||||
GeneralizedNewtypeDeriving
|
|
||||||
ImportQualifiedPost
|
|
||||||
InstanceSigs
|
|
||||||
KindSignatures
|
|
||||||
LambdaCase
|
|
||||||
MultiParamTypeClasses
|
|
||||||
MultiWayIf
|
|
||||||
NamedFieldPuns
|
|
||||||
NumericUnderscores
|
|
||||||
OverloadedLabels
|
|
||||||
OverloadedStrings
|
|
||||||
PatternSynonyms
|
|
||||||
RankNTypes
|
|
||||||
ScopedTypeVariables
|
|
||||||
TupleSections
|
|
||||||
TypeApplications
|
|
||||||
ViewPatterns
|
|
||||||
ghc-options: -Wall -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0
|
|
||||||
build-tools:
|
|
||||||
unison
|
|
||||||
build-depends:
|
|
||||||
IntervalMap
|
|
||||||
, ListLike
|
|
||||||
, aeson >=2.0.0.0
|
|
||||||
, aeson-pretty
|
|
||||||
, ansi-terminal
|
|
||||||
, async
|
|
||||||
, base
|
|
||||||
, bytes
|
|
||||||
, bytestring
|
|
||||||
, co-log-core
|
|
||||||
, code-page
|
|
||||||
, concurrent-output
|
|
||||||
, configurator
|
|
||||||
, containers >=0.6.3
|
|
||||||
, cryptonite
|
|
||||||
, directory
|
|
||||||
, easytest
|
|
||||||
, either
|
|
||||||
, errors
|
|
||||||
, exceptions
|
|
||||||
, extra
|
|
||||||
, filepath
|
|
||||||
, free
|
|
||||||
, friendly-time
|
|
||||||
, fsnotify
|
|
||||||
, fuzzyfind
|
|
||||||
, generic-lens
|
|
||||||
, haskeline
|
|
||||||
, http-client >=0.7.6
|
|
||||||
, http-client-tls
|
|
||||||
, http-types
|
|
||||||
, jwt
|
|
||||||
, ki
|
|
||||||
, lens
|
|
||||||
, lock-file
|
|
||||||
, lsp >=2.2.0.0
|
|
||||||
, lsp-types >=2.0.2.0
|
|
||||||
, megaparsec
|
|
||||||
, memory
|
|
||||||
, mtl
|
|
||||||
, network
|
|
||||||
, network-simple
|
|
||||||
, network-uri
|
|
||||||
, nonempty-containers
|
|
||||||
, open-browser
|
|
||||||
, pretty-simple
|
|
||||||
, process
|
|
||||||
, random >=1.2.0
|
|
||||||
, random-shuffle
|
|
||||||
, recover-rtti
|
|
||||||
, regex-tdfa
|
|
||||||
, semialign
|
|
||||||
, semigroups
|
|
||||||
, servant
|
|
||||||
, servant-client
|
|
||||||
, shellmet
|
|
||||||
, stm
|
|
||||||
, text
|
|
||||||
, text-builder
|
|
||||||
, text-rope
|
|
||||||
, these
|
|
||||||
, these-lens
|
|
||||||
, time
|
|
||||||
, transformers
|
|
||||||
, unison-codebase
|
|
||||||
, unison-codebase-sqlite
|
|
||||||
, unison-codebase-sqlite-hashing-v2
|
|
||||||
, unison-core
|
|
||||||
, unison-core1
|
|
||||||
, unison-hash
|
|
||||||
, unison-merge
|
|
||||||
, unison-parser-typechecker
|
|
||||||
, unison-prelude
|
|
||||||
, unison-pretty-printer
|
|
||||||
, unison-share-api
|
|
||||||
, unison-share-projects-api
|
|
||||||
, unison-sqlite
|
|
||||||
, unison-syntax
|
|
||||||
, unison-util-base32hex
|
|
||||||
, unison-util-nametree
|
|
||||||
, unison-util-relation
|
|
||||||
, unliftio
|
|
||||||
, unordered-containers
|
|
||||||
, uri-encode
|
|
||||||
, uuid
|
|
||||||
, vector
|
|
||||||
, wai
|
|
||||||
, warp
|
|
||||||
, witch
|
|
||||||
, witherable
|
|
||||||
default-language: Haskell2010
|
|
||||||
if flag(optimized)
|
|
||||||
ghc-options: -O2 -funbox-strict-fields
|
|
||||||
|
|
||||||
executable transcripts
|
executable transcripts
|
||||||
main-is: Transcripts.hs
|
main-is: Transcripts.hs
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
@ -485,6 +494,7 @@ executable transcripts
|
|||||||
, network-uri
|
, network-uri
|
||||||
, nonempty-containers
|
, nonempty-containers
|
||||||
, open-browser
|
, open-browser
|
||||||
|
, optparse-applicative >=0.16.1.0
|
||||||
, pretty-simple
|
, pretty-simple
|
||||||
, process
|
, process
|
||||||
, random >=1.2.0
|
, random >=1.2.0
|
||||||
@ -498,145 +508,6 @@ executable transcripts
|
|||||||
, shellmet
|
, shellmet
|
||||||
, silently
|
, silently
|
||||||
, stm
|
, stm
|
||||||
, text
|
|
||||||
, text-builder
|
|
||||||
, text-rope
|
|
||||||
, these
|
|
||||||
, these-lens
|
|
||||||
, time
|
|
||||||
, transformers
|
|
||||||
, unison-cli
|
|
||||||
, unison-codebase
|
|
||||||
, unison-codebase-sqlite
|
|
||||||
, unison-codebase-sqlite-hashing-v2
|
|
||||||
, unison-core
|
|
||||||
, unison-core1
|
|
||||||
, unison-hash
|
|
||||||
, unison-merge
|
|
||||||
, unison-parser-typechecker
|
|
||||||
, unison-prelude
|
|
||||||
, unison-pretty-printer
|
|
||||||
, unison-share-api
|
|
||||||
, unison-share-projects-api
|
|
||||||
, unison-sqlite
|
|
||||||
, unison-syntax
|
|
||||||
, unison-util-base32hex
|
|
||||||
, unison-util-nametree
|
|
||||||
, unison-util-relation
|
|
||||||
, unliftio
|
|
||||||
, unordered-containers
|
|
||||||
, uri-encode
|
|
||||||
, uuid
|
|
||||||
, vector
|
|
||||||
, wai
|
|
||||||
, warp
|
|
||||||
, witch
|
|
||||||
, witherable
|
|
||||||
default-language: Haskell2010
|
|
||||||
if flag(optimized)
|
|
||||||
ghc-options: -O2 -funbox-strict-fields
|
|
||||||
|
|
||||||
executable unison
|
|
||||||
main-is: Main.hs
|
|
||||||
other-modules:
|
|
||||||
ArgParse
|
|
||||||
Stats
|
|
||||||
System.Path
|
|
||||||
Version
|
|
||||||
hs-source-dirs:
|
|
||||||
unison
|
|
||||||
default-extensions:
|
|
||||||
ApplicativeDo
|
|
||||||
BangPatterns
|
|
||||||
BlockArguments
|
|
||||||
DeriveAnyClass
|
|
||||||
DeriveFunctor
|
|
||||||
DeriveFoldable
|
|
||||||
DeriveTraversable
|
|
||||||
DeriveGeneric
|
|
||||||
DerivingStrategies
|
|
||||||
DerivingVia
|
|
||||||
DoAndIfThenElse
|
|
||||||
DuplicateRecordFields
|
|
||||||
FlexibleContexts
|
|
||||||
FlexibleInstances
|
|
||||||
GADTs
|
|
||||||
GeneralizedNewtypeDeriving
|
|
||||||
ImportQualifiedPost
|
|
||||||
InstanceSigs
|
|
||||||
KindSignatures
|
|
||||||
LambdaCase
|
|
||||||
MultiParamTypeClasses
|
|
||||||
MultiWayIf
|
|
||||||
NamedFieldPuns
|
|
||||||
NumericUnderscores
|
|
||||||
OverloadedLabels
|
|
||||||
OverloadedStrings
|
|
||||||
PatternSynonyms
|
|
||||||
RankNTypes
|
|
||||||
ScopedTypeVariables
|
|
||||||
TupleSections
|
|
||||||
TypeApplications
|
|
||||||
ViewPatterns
|
|
||||||
ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-I0 -N -qn4 -qg1 -T" -optP-Wno-nonportable-include-path
|
|
||||||
build-depends:
|
|
||||||
IntervalMap
|
|
||||||
, ListLike
|
|
||||||
, aeson >=2.0.0.0
|
|
||||||
, aeson-pretty
|
|
||||||
, ansi-terminal
|
|
||||||
, async
|
|
||||||
, base
|
|
||||||
, bytes
|
|
||||||
, bytestring
|
|
||||||
, co-log-core
|
|
||||||
, code-page
|
|
||||||
, concurrent-output
|
|
||||||
, configurator
|
|
||||||
, containers >=0.6.3
|
|
||||||
, cryptonite
|
|
||||||
, directory
|
|
||||||
, either
|
|
||||||
, errors
|
|
||||||
, exceptions
|
|
||||||
, extra
|
|
||||||
, filepath
|
|
||||||
, free
|
|
||||||
, friendly-time
|
|
||||||
, fsnotify
|
|
||||||
, fuzzyfind
|
|
||||||
, generic-lens
|
|
||||||
, haskeline
|
|
||||||
, http-client >=0.7.6
|
|
||||||
, http-client-tls
|
|
||||||
, http-types
|
|
||||||
, jwt
|
|
||||||
, ki
|
|
||||||
, lens
|
|
||||||
, lock-file
|
|
||||||
, lsp >=2.2.0.0
|
|
||||||
, lsp-types >=2.0.2.0
|
|
||||||
, megaparsec
|
|
||||||
, memory
|
|
||||||
, mtl
|
|
||||||
, network
|
|
||||||
, network-simple
|
|
||||||
, network-uri
|
|
||||||
, nonempty-containers
|
|
||||||
, open-browser
|
|
||||||
, optparse-applicative >=0.16.1.0
|
|
||||||
, pretty-simple
|
|
||||||
, process
|
|
||||||
, random >=1.2.0
|
|
||||||
, random-shuffle
|
|
||||||
, recover-rtti
|
|
||||||
, regex-tdfa
|
|
||||||
, semialign
|
|
||||||
, semigroups
|
|
||||||
, servant
|
|
||||||
, servant-client
|
|
||||||
, shellmet
|
|
||||||
, stm
|
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, temporary
|
, temporary
|
||||||
, text
|
, text
|
||||||
@ -646,7 +517,7 @@ executable unison
|
|||||||
, these-lens
|
, these-lens
|
||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
, unison-cli
|
, unison-cli-lib
|
||||||
, unison-codebase
|
, unison-codebase
|
||||||
, unison-codebase-sqlite
|
, unison-codebase-sqlite
|
||||||
, unison-codebase-sqlite-hashing-v2
|
, unison-codebase-sqlite-hashing-v2
|
||||||
@ -770,6 +641,7 @@ test-suite cli-tests
|
|||||||
, network-uri
|
, network-uri
|
||||||
, nonempty-containers
|
, nonempty-containers
|
||||||
, open-browser
|
, open-browser
|
||||||
|
, optparse-applicative >=0.16.1.0
|
||||||
, pretty-simple
|
, pretty-simple
|
||||||
, process
|
, process
|
||||||
, random >=1.2.0
|
, random >=1.2.0
|
||||||
@ -782,6 +654,7 @@ test-suite cli-tests
|
|||||||
, servant-client
|
, servant-client
|
||||||
, shellmet
|
, shellmet
|
||||||
, stm
|
, stm
|
||||||
|
, template-haskell
|
||||||
, temporary
|
, temporary
|
||||||
, text
|
, text
|
||||||
, text-builder
|
, text-builder
|
||||||
@ -790,7 +663,7 @@ test-suite cli-tests
|
|||||||
, these-lens
|
, these-lens
|
||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
, unison-cli
|
, unison-cli-lib
|
||||||
, unison-codebase
|
, unison-codebase
|
||||||
, unison-codebase-sqlite
|
, unison-codebase-sqlite
|
||||||
, unison-codebase-sqlite-hashing-v2
|
, unison-codebase-sqlite-hashing-v2
|
||||||
|
@ -6,7 +6,7 @@
|
|||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
|
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
|
||||||
|
|
||||||
module Main
|
module Unison.Main
|
||||||
( main,
|
( main,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
@ -89,9 +89,10 @@ import Unison.Server.Backend qualified as Backend
|
|||||||
import Unison.Server.CodebaseServer qualified as Server
|
import Unison.Server.CodebaseServer qualified as Server
|
||||||
import Unison.Symbol (Symbol)
|
import Unison.Symbol (Symbol)
|
||||||
import Unison.Util.Pretty qualified as P
|
import Unison.Util.Pretty qualified as P
|
||||||
|
import Unison.Version (Version)
|
||||||
|
import Unison.Version qualified as Version
|
||||||
import UnliftIO qualified
|
import UnliftIO qualified
|
||||||
import UnliftIO.Directory (getHomeDirectory)
|
import UnliftIO.Directory (getHomeDirectory)
|
||||||
import Version qualified
|
|
||||||
|
|
||||||
type Runtimes =
|
type Runtimes =
|
||||||
(RTI.Runtime Symbol, RTI.Runtime Symbol, RTI.Runtime Symbol)
|
(RTI.Runtime Symbol, RTI.Runtime Symbol, RTI.Runtime Symbol)
|
||||||
@ -102,8 +103,8 @@ fixNativeRuntimePath override = do
|
|||||||
let ucr = takeDirectory ucm </> "runtime" </> "unison-runtime" <.> exeExtension
|
let ucr = takeDirectory ucm </> "runtime" </> "unison-runtime" <.> exeExtension
|
||||||
pure $ maybe ucr id override
|
pure $ maybe ucr id override
|
||||||
|
|
||||||
main :: IO ()
|
main :: Version -> IO ()
|
||||||
main = do
|
main version = do
|
||||||
-- Replace the default exception handler with one complains loudly, because we shouldn't have any uncaught exceptions.
|
-- Replace the default exception handler with one complains loudly, because we shouldn't have any uncaught exceptions.
|
||||||
-- Sometimes `show` and `displayException` are different strings; in this case, we want to show them both, so this
|
-- Sometimes `show` and `displayException` are different strings; in this case, we want to show them both, so this
|
||||||
-- issue is easier to debug.
|
-- issue is easier to debug.
|
||||||
@ -131,17 +132,17 @@ main = do
|
|||||||
withCP65001 . runInUnboundThread . Ki.scoped $ \scope -> do
|
withCP65001 . runInUnboundThread . Ki.scoped $ \scope -> do
|
||||||
interruptHandler <- defaultInterruptHandler
|
interruptHandler <- defaultInterruptHandler
|
||||||
withInterruptHandler interruptHandler $ do
|
withInterruptHandler interruptHandler $ do
|
||||||
void $ Ki.fork scope initHTTPClient
|
void $ Ki.fork scope (initHTTPClient version)
|
||||||
progName <- getProgName
|
progName <- getProgName
|
||||||
-- hSetBuffering stdout NoBuffering -- cool
|
-- hSetBuffering stdout NoBuffering -- cool
|
||||||
(renderUsageInfo, globalOptions, command) <- parseCLIArgs progName (Text.unpack Version.gitDescribeWithDate)
|
(renderUsageInfo, globalOptions, command) <- parseCLIArgs progName (Text.unpack (Version.gitDescribeWithDate version))
|
||||||
nrtp <- fixNativeRuntimePath (nativeRuntimePath globalOptions)
|
nrtp <- fixNativeRuntimePath (nativeRuntimePath globalOptions)
|
||||||
let GlobalOptions {codebasePathOption = mCodePathOption, exitOption, lspFormattingConfig} = globalOptions
|
let GlobalOptions {codebasePathOption = mCodePathOption, exitOption, lspFormattingConfig} = globalOptions
|
||||||
withConfig mCodePathOption \config -> do
|
withConfig mCodePathOption \config -> do
|
||||||
currentDir <- getCurrentDirectory
|
currentDir <- getCurrentDirectory
|
||||||
case command of
|
case command of
|
||||||
PrintVersion ->
|
PrintVersion ->
|
||||||
Text.putStrLn $ Text.pack progName <> " version: " <> Version.gitDescribeWithDate
|
Text.putStrLn $ Text.pack progName <> " version: " <> Version.gitDescribeWithDate version
|
||||||
Init -> do
|
Init -> do
|
||||||
exitError
|
exitError
|
||||||
( P.lines
|
( P.lines
|
||||||
@ -156,7 +157,7 @@ main = do
|
|||||||
)
|
)
|
||||||
Run (RunFromSymbol mainName) args -> do
|
Run (RunFromSymbol mainName) args -> do
|
||||||
getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, _, theCodebase) -> do
|
getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, _, theCodebase) -> do
|
||||||
RTI.withRuntime False RTI.OneOff Version.gitDescribeWithDate \runtime -> do
|
RTI.withRuntime False RTI.OneOff (Version.gitDescribeWithDate version) \runtime -> do
|
||||||
withArgs args (execute theCodebase runtime mainName) >>= \case
|
withArgs args (execute theCodebase runtime mainName) >>= \case
|
||||||
Left err -> exitError err
|
Left err -> exitError err
|
||||||
Right () -> pure ()
|
Right () -> pure ()
|
||||||
@ -175,6 +176,7 @@ main = do
|
|||||||
let serverUrl = Nothing
|
let serverUrl = Nothing
|
||||||
let startPath = Nothing
|
let startPath = Nothing
|
||||||
launch
|
launch
|
||||||
|
version
|
||||||
currentDir
|
currentDir
|
||||||
config
|
config
|
||||||
rt
|
rt
|
||||||
@ -201,6 +203,7 @@ main = do
|
|||||||
let serverUrl = Nothing
|
let serverUrl = Nothing
|
||||||
let startPath = Nothing
|
let startPath = Nothing
|
||||||
launch
|
launch
|
||||||
|
version
|
||||||
currentDir
|
currentDir
|
||||||
config
|
config
|
||||||
rt
|
rt
|
||||||
@ -244,7 +247,7 @@ main = do
|
|||||||
Left err -> exitError err
|
Left err -> exitError err
|
||||||
Right () -> pure ()
|
Right () -> pure ()
|
||||||
where
|
where
|
||||||
vmatch = v == Version.gitDescribeWithDate
|
vmatch = v == Version.gitDescribeWithDate version
|
||||||
ws s = P.wrap (P.text s)
|
ws s = P.wrap (P.text s)
|
||||||
ifile
|
ifile
|
||||||
| 'c' : 'u' : '.' : rest <- reverse file = reverse rest
|
| 'c' : 'u' : '.' : rest <- reverse file = reverse rest
|
||||||
@ -260,7 +263,7 @@ main = do
|
|||||||
P.indentN 4 $ P.text v,
|
P.indentN 4 $ P.text v,
|
||||||
"",
|
"",
|
||||||
"Your version",
|
"Your version",
|
||||||
P.indentN 4 $ P.text Version.gitDescribeWithDate,
|
P.indentN 4 $ P.text $ Version.gitDescribeWithDate version,
|
||||||
"",
|
"",
|
||||||
P.wrap $
|
P.wrap $
|
||||||
"The program was compiled from hash "
|
"The program was compiled from hash "
|
||||||
@ -279,7 +282,7 @@ main = do
|
|||||||
\that matches your version of Unison."
|
\that matches your version of Unison."
|
||||||
]
|
]
|
||||||
Transcript shouldFork shouldSaveCodebase mrtsStatsFp transcriptFiles -> do
|
Transcript shouldFork shouldSaveCodebase mrtsStatsFp transcriptFiles -> do
|
||||||
let action = runTranscripts Verbosity.Verbose renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption nrtp transcriptFiles
|
let action = runTranscripts version Verbosity.Verbose renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption nrtp transcriptFiles
|
||||||
case mrtsStatsFp of
|
case mrtsStatsFp of
|
||||||
Nothing -> action
|
Nothing -> action
|
||||||
Just fp -> recordRtsStats fp action
|
Just fp -> recordRtsStats fp action
|
||||||
@ -334,6 +337,7 @@ main = do
|
|||||||
PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..."
|
PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..."
|
||||||
|
|
||||||
launch
|
launch
|
||||||
|
version
|
||||||
currentDir
|
currentDir
|
||||||
config
|
config
|
||||||
runtime
|
runtime
|
||||||
@ -352,11 +356,11 @@ main = do
|
|||||||
-- (runtime, sandboxed runtime)
|
-- (runtime, sandboxed runtime)
|
||||||
withRuntimes :: FilePath -> RTI.RuntimeHost -> (Runtimes -> IO a) -> IO a
|
withRuntimes :: FilePath -> RTI.RuntimeHost -> (Runtimes -> IO a) -> IO a
|
||||||
withRuntimes nrtp mode action =
|
withRuntimes nrtp mode action =
|
||||||
RTI.withRuntime False mode Version.gitDescribeWithDate \runtime -> do
|
RTI.withRuntime False mode (Version.gitDescribeWithDate version) \runtime -> do
|
||||||
RTI.withRuntime True mode Version.gitDescribeWithDate \sbRuntime ->
|
RTI.withRuntime True mode (Version.gitDescribeWithDate version) \sbRuntime ->
|
||||||
action . (runtime,sbRuntime,)
|
action . (runtime,sbRuntime,)
|
||||||
-- startNativeRuntime saves the path to `unison-runtime`
|
-- startNativeRuntime saves the path to `unison-runtime`
|
||||||
=<< RTI.startNativeRuntime Version.gitDescribeWithDate nrtp
|
=<< RTI.startNativeRuntime (Version.gitDescribeWithDate version) nrtp
|
||||||
withConfig :: Maybe CodebasePathOption -> (Config -> IO a) -> IO a
|
withConfig :: Maybe CodebasePathOption -> (Config -> IO a) -> IO a
|
||||||
withConfig mCodePathOption action = do
|
withConfig mCodePathOption action = do
|
||||||
UnliftIO.bracket
|
UnliftIO.bracket
|
||||||
@ -371,9 +375,9 @@ main = do
|
|||||||
|
|
||||||
-- | Set user agent and configure TLS on global http client.
|
-- | Set user agent and configure TLS on global http client.
|
||||||
-- Note that the authorized http client is distinct from the global http client.
|
-- Note that the authorized http client is distinct from the global http client.
|
||||||
initHTTPClient :: IO ()
|
initHTTPClient :: Version -> IO ()
|
||||||
initHTTPClient = do
|
initHTTPClient version = do
|
||||||
let (ucmVersion, _date) = Version.gitDescribe
|
let (ucmVersion, _date) = Version.gitDescribe version
|
||||||
let userAgent = Text.encodeUtf8 $ "UCM/" <> ucmVersion
|
let userAgent = Text.encodeUtf8 $ "UCM/" <> ucmVersion
|
||||||
let addUserAgent req = do
|
let addUserAgent req = do
|
||||||
pure $ req {HTTP.requestHeaders = ("User-Agent", userAgent) : HTTP.requestHeaders req}
|
pure $ req {HTTP.requestHeaders = ("User-Agent", userAgent) : HTTP.requestHeaders req}
|
||||||
@ -405,18 +409,19 @@ prepareTranscriptDir verbosity shouldFork mCodePathOption shouldSaveCodebase = d
|
|||||||
pure tmp
|
pure tmp
|
||||||
|
|
||||||
runTranscripts' ::
|
runTranscripts' ::
|
||||||
|
Version ->
|
||||||
String ->
|
String ->
|
||||||
Maybe FilePath ->
|
Maybe FilePath ->
|
||||||
FilePath ->
|
FilePath ->
|
||||||
FilePath ->
|
FilePath ->
|
||||||
NonEmpty MarkdownFile ->
|
NonEmpty MarkdownFile ->
|
||||||
IO Bool
|
IO Bool
|
||||||
runTranscripts' progName mcodepath nativeRtp transcriptDir markdownFiles = do
|
runTranscripts' version progName mcodepath nativeRtp transcriptDir markdownFiles = do
|
||||||
currentDir <- getCurrentDirectory
|
currentDir <- getCurrentDirectory
|
||||||
configFilePath <- getConfigFilePath mcodepath
|
configFilePath <- getConfigFilePath mcodepath
|
||||||
-- We don't need to create a codebase through `getCodebaseOrExit` as we've already done so previously.
|
-- 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
|
and <$> getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, codebasePath, theCodebase) -> do
|
||||||
TR.withTranscriptRunner Verbosity.Verbose Version.gitDescribeWithDate nativeRtp (Just configFilePath) $ \runTranscript -> do
|
TR.withTranscriptRunner Verbosity.Verbose (Version.gitDescribeWithDate version) nativeRtp (Just configFilePath) $ \runTranscript -> do
|
||||||
for markdownFiles $ \(MarkdownFile fileName) -> do
|
for markdownFiles $ \(MarkdownFile fileName) -> do
|
||||||
transcriptSrc <- readUtf8 fileName
|
transcriptSrc <- readUtf8 fileName
|
||||||
result <- runTranscript fileName transcriptSrc (codebasePath, theCodebase)
|
result <- runTranscript fileName transcriptSrc (codebasePath, theCodebase)
|
||||||
@ -459,6 +464,7 @@ runTranscripts' progName mcodepath nativeRtp transcriptDir markdownFiles = do
|
|||||||
pure succeeded
|
pure succeeded
|
||||||
|
|
||||||
runTranscripts ::
|
runTranscripts ::
|
||||||
|
Version ->
|
||||||
Verbosity.Verbosity ->
|
Verbosity.Verbosity ->
|
||||||
UsageRenderer ->
|
UsageRenderer ->
|
||||||
ShouldForkCodebase ->
|
ShouldForkCodebase ->
|
||||||
@ -467,7 +473,7 @@ runTranscripts ::
|
|||||||
FilePath ->
|
FilePath ->
|
||||||
NonEmpty String ->
|
NonEmpty String ->
|
||||||
IO ()
|
IO ()
|
||||||
runTranscripts verbosity renderUsageInfo shouldFork shouldSaveTempCodebase mCodePathOption nativeRtp args = do
|
runTranscripts version verbosity renderUsageInfo shouldFork shouldSaveTempCodebase mCodePathOption nativeRtp args = do
|
||||||
markdownFiles <- case traverse (first (pure @[]) . markdownFile) args of
|
markdownFiles <- case traverse (first (pure @[]) . markdownFile) args of
|
||||||
Failure invalidArgs -> do
|
Failure invalidArgs -> do
|
||||||
PT.putPrettyLn $
|
PT.putPrettyLn $
|
||||||
@ -485,7 +491,7 @@ runTranscripts verbosity renderUsageInfo shouldFork shouldSaveTempCodebase mCode
|
|||||||
progName <- getProgName
|
progName <- getProgName
|
||||||
transcriptDir <- prepareTranscriptDir verbosity shouldFork mCodePathOption shouldSaveTempCodebase
|
transcriptDir <- prepareTranscriptDir verbosity shouldFork mCodePathOption shouldSaveTempCodebase
|
||||||
completed <-
|
completed <-
|
||||||
runTranscripts' progName (Just transcriptDir) nativeRtp transcriptDir markdownFiles
|
runTranscripts' version progName (Just transcriptDir) nativeRtp transcriptDir markdownFiles
|
||||||
case shouldSaveTempCodebase of
|
case shouldSaveTempCodebase of
|
||||||
DontSaveCodebase -> removeDirectoryRecursive transcriptDir
|
DontSaveCodebase -> removeDirectoryRecursive transcriptDir
|
||||||
SaveCodebase _ ->
|
SaveCodebase _ ->
|
||||||
@ -510,6 +516,7 @@ defaultInitialPath :: Path.Absolute
|
|||||||
defaultInitialPath = Path.absoluteEmpty
|
defaultInitialPath = Path.absoluteEmpty
|
||||||
|
|
||||||
launch ::
|
launch ::
|
||||||
|
Version ->
|
||||||
FilePath ->
|
FilePath ->
|
||||||
Config ->
|
Config ->
|
||||||
Rt.Runtime Symbol ->
|
Rt.Runtime Symbol ->
|
||||||
@ -524,12 +531,12 @@ launch ::
|
|||||||
(Path.Absolute -> STM ()) ->
|
(Path.Absolute -> STM ()) ->
|
||||||
CommandLine.ShouldWatchFiles ->
|
CommandLine.ShouldWatchFiles ->
|
||||||
IO ()
|
IO ()
|
||||||
launch dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl mayStartingPath initResult notifyRootChange notifyPathChange shouldWatchFiles = do
|
launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl mayStartingPath initResult notifyRootChange notifyPathChange shouldWatchFiles = do
|
||||||
showWelcomeHint <- Codebase.runTransaction codebase Queries.doProjectsExist
|
showWelcomeHint <- Codebase.runTransaction codebase Queries.doProjectsExist
|
||||||
let isNewCodebase = case initResult of
|
let isNewCodebase = case initResult of
|
||||||
CreatedCodebase -> NewlyCreatedCodebase
|
CreatedCodebase -> NewlyCreatedCodebase
|
||||||
OpenedCodebase -> PreviouslyCreatedCodebase
|
OpenedCodebase -> PreviouslyCreatedCodebase
|
||||||
(ucmVersion, _date) = Version.gitDescribe
|
(ucmVersion, _date) = Version.gitDescribe version
|
||||||
welcome = Welcome.welcome isNewCodebase ucmVersion showWelcomeHint
|
welcome = Welcome.welcome isNewCodebase ucmVersion showWelcomeHint
|
||||||
in CommandLine.main
|
in CommandLine.main
|
||||||
dir
|
dir
|
12
unison-cli/unison/Unison/Version.hs
Normal file
12
unison-cli/unison/Unison/Version.hs
Normal file
@ -0,0 +1,12 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
|
module Unison.Version where
|
||||||
|
|
||||||
|
import Data.Text (Text)
|
||||||
|
|
||||||
|
data Version = Version {gitDescribeWithDate :: Text, gitDescribe :: (GitRef, CommitDate)}
|
||||||
|
|
||||||
|
type CommitDate = Text
|
||||||
|
|
||||||
|
type GitRef = Text
|
@ -277,7 +277,7 @@ data TermEntry v a = TermEntry
|
|||||||
deriving (Eq, Ord, Show, Generic)
|
deriving (Eq, Ord, Show, Generic)
|
||||||
|
|
||||||
termEntryLabeledDependencies :: Ord v => TermEntry v a -> Set LD.LabeledDependency
|
termEntryLabeledDependencies :: Ord v => TermEntry v a -> Set LD.LabeledDependency
|
||||||
termEntryLabeledDependencies TermEntry {termEntryType, termEntryReferent, termEntryTag} =
|
termEntryLabeledDependencies TermEntry {termEntryType, termEntryReferent, termEntryTag, termEntryName} =
|
||||||
foldMap Type.labeledDependencies termEntryType
|
foldMap Type.labeledDependencies termEntryType
|
||||||
<> Set.singleton (LD.TermReferent (Cv.referent2to1UsingCT ct termEntryReferent))
|
<> Set.singleton (LD.TermReferent (Cv.referent2to1UsingCT ct termEntryReferent))
|
||||||
where
|
where
|
||||||
@ -285,7 +285,8 @@ termEntryLabeledDependencies TermEntry {termEntryType, termEntryReferent, termEn
|
|||||||
ct = case termEntryTag of
|
ct = case termEntryTag of
|
||||||
ServerTypes.Constructor ServerTypes.Ability -> V2Referent.EffectConstructor
|
ServerTypes.Constructor ServerTypes.Ability -> V2Referent.EffectConstructor
|
||||||
ServerTypes.Constructor ServerTypes.Data -> V2Referent.DataConstructor
|
ServerTypes.Constructor ServerTypes.Data -> V2Referent.DataConstructor
|
||||||
_ -> error "termEntryLabeledDependencies: not a constructor, but one was required"
|
ServerTypes.Doc -> V2Referent.DataConstructor
|
||||||
|
_ -> error $ "termEntryLabeledDependencies: Term is not a constructor, but the referent was a constructor. Tag: " <> show termEntryTag <> " Name: " <> show termEntryName <> " Referent: " <> show termEntryReferent
|
||||||
|
|
||||||
termEntryDisplayName :: TermEntry v a -> Text
|
termEntryDisplayName :: TermEntry v a -> Text
|
||||||
termEntryDisplayName = HQ'.toTextWith Name.toText . termEntryHQName
|
termEntryDisplayName = HQ'.toTextWith Name.toText . termEntryHQName
|
||||||
|
@ -21,6 +21,11 @@ to `Tests.check` and `Tests.checkEqual`).
|
|||||||
.> add
|
.> add
|
||||||
```
|
```
|
||||||
|
|
||||||
|
```ucm:hide
|
||||||
|
.> load unison-src/builtin-tests/link-tests.u
|
||||||
|
.> add
|
||||||
|
```
|
||||||
|
|
||||||
```ucm:hide
|
```ucm:hide
|
||||||
.> load unison-src/builtin-tests/math-tests.u
|
.> load unison-src/builtin-tests/math-tests.u
|
||||||
.> add
|
.> add
|
||||||
|
@ -20,6 +20,9 @@ io.tests = Tests.main do
|
|||||||
!io.test_isFileOpen
|
!io.test_isFileOpen
|
||||||
!io.test_ready
|
!io.test_ready
|
||||||
!io.test_now
|
!io.test_now
|
||||||
|
!io.test_monotonic
|
||||||
|
!io.test_processCPUTime
|
||||||
|
!io.test_threadCPUTime
|
||||||
!io.test_isSeekable
|
!io.test_isSeekable
|
||||||
!io.test_handlePosition
|
!io.test_handlePosition
|
||||||
!io.test_renameDirectory
|
!io.test_renameDirectory
|
||||||
@ -79,6 +82,29 @@ io.test_now = do
|
|||||||
else
|
else
|
||||||
Tests.fail "!now" "now is too small"
|
Tests.fail "!now" "now is too small"
|
||||||
|
|
||||||
|
io.test_threadCPUTime = do
|
||||||
|
match !threadCPUTime with
|
||||||
|
Duration s ns
|
||||||
|
| (s == +0) && (ns == 0) ->
|
||||||
|
Tests.pass "!threadCPUTime"
|
||||||
|
| otherwise ->
|
||||||
|
Tests.pass "!threadCPUTime"
|
||||||
|
|
||||||
|
io.test_processCPUTime = do
|
||||||
|
match !processCPUTime with
|
||||||
|
Duration s ns
|
||||||
|
| (s == +0) && (ns == 0) ->
|
||||||
|
Tests.pass "!processCPUTime"
|
||||||
|
| otherwise ->
|
||||||
|
Tests.pass "!processCPUTime"
|
||||||
|
|
||||||
|
io.test_monotonic = do
|
||||||
|
match !Clock.monotonic with
|
||||||
|
Duration s ns
|
||||||
|
| (s == +0) && (ns == 0) ->
|
||||||
|
Tests.pass "!Clock.monotonic"
|
||||||
|
| otherwise ->
|
||||||
|
Tests.pass "!Clock.monotonic"
|
||||||
|
|
||||||
io.test_createTempDirectory = do
|
io.test_createTempDirectory = do
|
||||||
tmp = (createTempDirectory (FilePath "prefix-"))
|
tmp = (createTempDirectory (FilePath "prefix-"))
|
||||||
|
@ -21,6 +21,11 @@ to `Tests.check` and `Tests.checkEqual`).
|
|||||||
.> add
|
.> add
|
||||||
```
|
```
|
||||||
|
|
||||||
|
```ucm:hide
|
||||||
|
.> load unison-src/builtin-tests/link-tests.u
|
||||||
|
.> add
|
||||||
|
```
|
||||||
|
|
||||||
```ucm:hide
|
```ucm:hide
|
||||||
.> load unison-src/builtin-tests/math-tests.u
|
.> load unison-src/builtin-tests/math-tests.u
|
||||||
.> add
|
.> add
|
||||||
@ -98,3 +103,17 @@ to `Tests.check` and `Tests.checkEqual`).
|
|||||||
```ucm
|
```ucm
|
||||||
.> run.native tests.jit.only
|
.> run.native tests.jit.only
|
||||||
```
|
```
|
||||||
|
|
||||||
|
```unison
|
||||||
|
foo = do
|
||||||
|
go : Nat ->{Exception} ()
|
||||||
|
go = cases
|
||||||
|
0 -> ()
|
||||||
|
n -> go (decrement n)
|
||||||
|
go 1000
|
||||||
|
```
|
||||||
|
|
||||||
|
```ucm
|
||||||
|
.> run.native foo
|
||||||
|
.> run.native foo
|
||||||
|
```
|
||||||
|
@ -17,3 +17,35 @@ to `Tests.check` and `Tests.checkEqual`).
|
|||||||
()
|
()
|
||||||
|
|
||||||
```
|
```
|
||||||
|
```unison
|
||||||
|
foo = do
|
||||||
|
go : Nat ->{Exception} ()
|
||||||
|
go = cases
|
||||||
|
0 -> ()
|
||||||
|
n -> go (decrement n)
|
||||||
|
go 1000
|
||||||
|
```
|
||||||
|
|
||||||
|
```ucm
|
||||||
|
|
||||||
|
Loading changes detected in scratch.u.
|
||||||
|
|
||||||
|
I found and typechecked these definitions in scratch.u. If you
|
||||||
|
do an `add` or `update`, here's how your codebase would
|
||||||
|
change:
|
||||||
|
|
||||||
|
⍟ These new definitions are ok to `add`:
|
||||||
|
|
||||||
|
foo : '{Exception} ()
|
||||||
|
|
||||||
|
```
|
||||||
|
```ucm
|
||||||
|
.> run.native foo
|
||||||
|
|
||||||
|
()
|
||||||
|
|
||||||
|
.> run.native foo
|
||||||
|
|
||||||
|
()
|
||||||
|
|
||||||
|
```
|
||||||
|
58
unison-src/builtin-tests/link-tests.u
Normal file
58
unison-src/builtin-tests/link-tests.u
Normal file
@ -0,0 +1,58 @@
|
|||||||
|
|
||||||
|
linkstuff.termlinks =
|
||||||
|
[ termLink data.Map.adjust
|
||||||
|
, termLink data.Map.alter
|
||||||
|
, termLink data.Map.contains
|
||||||
|
, termLink data.Map.delete
|
||||||
|
, termLink data.Map.difference
|
||||||
|
, termLink data.List.any
|
||||||
|
, termLink data.List.apply
|
||||||
|
, termLink data.List.compare
|
||||||
|
, termLink data.List.contains
|
||||||
|
, termLink data.List.count
|
||||||
|
, termLink data.List.diagonal
|
||||||
|
, termLink data.List.distinct
|
||||||
|
, termLink data.NatSet.alter
|
||||||
|
, termLink data.NatSet.any
|
||||||
|
, termLink data.NatSet.empty
|
||||||
|
, termLink data.NatSet.filter
|
||||||
|
, termLink data.Tuple.at1
|
||||||
|
, termLink data.Tuple.at2
|
||||||
|
, termLink data.Tuple.at3
|
||||||
|
, termLink data.Tuple.bimap
|
||||||
|
, termLink data.Tuple.mapLeft
|
||||||
|
, termLink data.graph.SCC.map
|
||||||
|
]
|
||||||
|
|
||||||
|
linkstuff.typelinks =
|
||||||
|
[ typeLink data.Map
|
||||||
|
, typeLink Nat
|
||||||
|
, typeLink Char
|
||||||
|
, typeLink data.List
|
||||||
|
, typeLink data.NatSet
|
||||||
|
, typeLink data.Tuple
|
||||||
|
]
|
||||||
|
|
||||||
|
linkstuff.tmlpairs =
|
||||||
|
flatMap (l -> map (r -> (l,r)) termlinks) termlinks
|
||||||
|
|
||||||
|
linkstuff.tylpairs =
|
||||||
|
flatMap (l -> map (r -> (l,r)) typelinks) typelinks
|
||||||
|
|
||||||
|
linkstuff.tests : '{Tests,IO} ()
|
||||||
|
linkstuff.tests = do
|
||||||
|
use Universal gteq
|
||||||
|
if all (cases (l,r) -> (l === r) || (l !== r)) tmlpairs
|
||||||
|
then pass "term link equality"
|
||||||
|
else fail "term link equality" ""
|
||||||
|
if all (cases (l,r) -> (l === r) || (l !== r)) tylpairs
|
||||||
|
then pass "type link equality"
|
||||||
|
else fail "type link equality" ""
|
||||||
|
|
||||||
|
if all (cases (l,r) -> gteq l r || gteq r l) tmlpairs
|
||||||
|
then pass "term link comparison"
|
||||||
|
else fail "term link comparison" ""
|
||||||
|
if all (cases (l,r) -> gteq l r || gteq r l) tylpairs
|
||||||
|
then pass "type link comparison"
|
||||||
|
else fail "type link comparison" ""
|
||||||
|
|
@ -95,7 +95,10 @@ serial.loadSelfContained name path =
|
|||||||
Right [] -> pass (name ++ " links validated")
|
Right [] -> pass (name ++ " links validated")
|
||||||
Right _ -> fail name "failed link validation"
|
Right _ -> fail name "failed link validation"
|
||||||
|
|
||||||
_ = cache_ deps
|
match cache_ deps with
|
||||||
|
[] -> ()
|
||||||
|
miss -> raiseFailure "code missing deps" miss
|
||||||
|
|
||||||
checkCached name deps
|
checkCached name deps
|
||||||
match Value.load v with
|
match Value.load v with
|
||||||
Left l -> raiseFailure "value missing deps" l
|
Left l -> raiseFailure "value missing deps" l
|
||||||
|
@ -17,6 +17,7 @@ tests = Tests.main do
|
|||||||
!array.tests
|
!array.tests
|
||||||
!codelookup.tests
|
!codelookup.tests
|
||||||
!sandbox.tests
|
!sandbox.tests
|
||||||
|
!linkstuff.tests
|
||||||
|
|
||||||
murmur.hash.tests = do
|
murmur.hash.tests = do
|
||||||
targets =
|
targets =
|
||||||
|
@ -5,7 +5,7 @@ Next, we'll download the jit project and generate a few Racket files from it.
|
|||||||
|
|
||||||
```ucm
|
```ucm
|
||||||
.> project.create-empty jit-setup
|
.> project.create-empty jit-setup
|
||||||
jit-setup/main> pull @unison/internal/releases/0.0.12 lib.jit
|
jit-setup/main> pull @unison/internal/releases/0.0.13 lib.jit
|
||||||
```
|
```
|
||||||
|
|
||||||
```unison
|
```unison
|
||||||
|
@ -20,9 +20,9 @@ Next, we'll download the jit project and generate a few Racket files from it.
|
|||||||
|
|
||||||
🎉 🥳 Happy coding!
|
🎉 🥳 Happy coding!
|
||||||
|
|
||||||
jit-setup/main> pull @unison/internal/releases/0.0.12 lib.jit
|
jit-setup/main> pull @unison/internal/releases/0.0.13 lib.jit
|
||||||
|
|
||||||
Downloaded 15048 entities.
|
Downloaded 15053 entities.
|
||||||
|
|
||||||
✅
|
✅
|
||||||
|
|
||||||
|
File diff suppressed because it is too large
Load Diff
@ -52,7 +52,7 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace
|
|||||||
41. Optional (type)
|
41. Optional (type)
|
||||||
42. Optional/ (2 terms)
|
42. Optional/ (2 terms)
|
||||||
43. Pattern (builtin type)
|
43. Pattern (builtin type)
|
||||||
44. Pattern/ (8 terms)
|
44. Pattern/ (9 terms)
|
||||||
45. Ref (builtin type)
|
45. Ref (builtin type)
|
||||||
46. Ref/ (2 terms)
|
46. Ref/ (2 terms)
|
||||||
47. Request (builtin type)
|
47. Request (builtin type)
|
||||||
|
@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge`
|
|||||||
|
|
||||||
.foo> ls
|
.foo> ls
|
||||||
|
|
||||||
1. builtin/ (455 terms, 71 types)
|
1. builtin/ (456 terms, 71 types)
|
||||||
|
|
||||||
```
|
```
|
||||||
And for a limited time, you can get even more builtin goodies:
|
And for a limited time, you can get even more builtin goodies:
|
||||||
@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies:
|
|||||||
|
|
||||||
.foo> ls
|
.foo> ls
|
||||||
|
|
||||||
1. builtin/ (627 terms, 89 types)
|
1. builtin/ (628 terms, 89 types)
|
||||||
|
|
||||||
```
|
```
|
||||||
More typically, you'd start out by pulling `base.
|
More typically, you'd start out by pulling `base.
|
||||||
|
@ -119,13 +119,13 @@ it's still in the `history` of the parent namespace and can be resurrected at an
|
|||||||
Note: The most recent namespace hash is immediately below this
|
Note: The most recent namespace hash is immediately below this
|
||||||
message.
|
message.
|
||||||
|
|
||||||
⊙ 1. #1qpabd7ooq
|
⊙ 1. #mqis95ft23
|
||||||
|
|
||||||
- Deletes:
|
- Deletes:
|
||||||
|
|
||||||
feature1.y
|
feature1.y
|
||||||
|
|
||||||
⊙ 2. #jhqb98218p
|
⊙ 2. #5ro9c9692q
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
@ -136,26 +136,26 @@ it's still in the `history` of the parent namespace and can be resurrected at an
|
|||||||
Original name New name(s)
|
Original name New name(s)
|
||||||
feature1.y master.y
|
feature1.y master.y
|
||||||
|
|
||||||
⊙ 3. #n25372gm2b
|
⊙ 3. #da33td9rni
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
feature1.y
|
feature1.y
|
||||||
|
|
||||||
⊙ 4. #b9s4c5ut48
|
⊙ 4. #ks6rftepdv
|
||||||
|
|
||||||
> Moves:
|
> Moves:
|
||||||
|
|
||||||
Original name New name
|
Original name New name
|
||||||
x master.x
|
x master.x
|
||||||
|
|
||||||
⊙ 5. #9uq9mhup43
|
⊙ 5. #dgcqc7jftr
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
x
|
x
|
||||||
|
|
||||||
□ 6. #8f47abto6r (start of history)
|
□ 6. #ms344fdodl (start of history)
|
||||||
|
|
||||||
```
|
```
|
||||||
To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`.
|
To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`.
|
||||||
|
@ -80,7 +80,7 @@ Should be able to move the term, type, and namespace, including its types, terms
|
|||||||
1. Bar (Nat)
|
1. Bar (Nat)
|
||||||
2. Bar (type)
|
2. Bar (type)
|
||||||
3. Bar/ (4 terms, 1 type)
|
3. Bar/ (4 terms, 1 type)
|
||||||
4. builtin/ (627 terms, 89 types)
|
4. builtin/ (628 terms, 89 types)
|
||||||
|
|
||||||
.> ls Bar
|
.> ls Bar
|
||||||
|
|
||||||
@ -145,7 +145,7 @@ bonk = 5
|
|||||||
|
|
||||||
.z> ls
|
.z> ls
|
||||||
|
|
||||||
1. builtin/ (455 terms, 71 types)
|
1. builtin/ (456 terms, 71 types)
|
||||||
2. zonk (Nat)
|
2. zonk (Nat)
|
||||||
|
|
||||||
```
|
```
|
||||||
@ -188,7 +188,7 @@ bonk.zonk = 5
|
|||||||
|
|
||||||
.a> ls
|
.a> ls
|
||||||
|
|
||||||
1. builtin/ (455 terms, 71 types)
|
1. builtin/ (456 terms, 71 types)
|
||||||
2. zonk/ (1 term)
|
2. zonk/ (1 term)
|
||||||
|
|
||||||
.a> view zonk.zonk
|
.a> view zonk.zonk
|
||||||
|
@ -277,7 +277,7 @@ I should be able to move the root into a sub-namespace
|
|||||||
|
|
||||||
.> ls
|
.> ls
|
||||||
|
|
||||||
1. root/ (1370 terms, 214 types)
|
1. root/ (1373 terms, 214 types)
|
||||||
|
|
||||||
.> history
|
.> history
|
||||||
|
|
||||||
@ -286,22 +286,22 @@ I should be able to move the root into a sub-namespace
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
□ 1. #p1ltr60tg9 (start of history)
|
□ 1. #vrn80pdffk (start of history)
|
||||||
|
|
||||||
```
|
```
|
||||||
```ucm
|
```ucm
|
||||||
.> ls .root.at.path
|
.> ls .root.at.path
|
||||||
|
|
||||||
1. existing/ (456 terms, 71 types)
|
1. existing/ (457 terms, 71 types)
|
||||||
2. happy/ (458 terms, 72 types)
|
2. happy/ (459 terms, 72 types)
|
||||||
3. history/ (456 terms, 71 types)
|
3. history/ (457 terms, 71 types)
|
||||||
|
|
||||||
.> history .root.at.path
|
.> history .root.at.path
|
||||||
|
|
||||||
Note: The most recent namespace hash is immediately below this
|
Note: The most recent namespace hash is immediately below this
|
||||||
message.
|
message.
|
||||||
|
|
||||||
⊙ 1. #nndiivp3ng
|
⊙ 1. #g3ri07hi09
|
||||||
|
|
||||||
- Deletes:
|
- Deletes:
|
||||||
|
|
||||||
@ -312,7 +312,7 @@ I should be able to move the root into a sub-namespace
|
|||||||
Original name New name
|
Original name New name
|
||||||
existing.a.termInA existing.b.termInA
|
existing.a.termInA existing.b.termInA
|
||||||
|
|
||||||
⊙ 2. #1he7dqonrt
|
⊙ 2. #ifjg1bj57v
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
@ -324,26 +324,26 @@ I should be able to move the root into a sub-namespace
|
|||||||
happy.b.termInA existing.a.termInA
|
happy.b.termInA existing.a.termInA
|
||||||
history.b.termInA existing.a.termInA
|
history.b.termInA existing.a.termInA
|
||||||
|
|
||||||
⊙ 3. #fbm4gr3975
|
⊙ 3. #bdn8f7vhg1
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
existing.a.termInA existing.b.termInB
|
existing.a.termInA existing.b.termInB
|
||||||
|
|
||||||
⊙ 4. #v7j1f8vgni
|
⊙ 4. #5dqmgnr0lt
|
||||||
|
|
||||||
> Moves:
|
> Moves:
|
||||||
|
|
||||||
Original name New name
|
Original name New name
|
||||||
history.a.termInA history.b.termInA
|
history.a.termInA history.b.termInA
|
||||||
|
|
||||||
⊙ 5. #ofsvuc0cgu
|
⊙ 5. #vd3d37rn3c
|
||||||
|
|
||||||
- Deletes:
|
- Deletes:
|
||||||
|
|
||||||
history.b.termInB
|
history.b.termInB
|
||||||
|
|
||||||
⊙ 6. #s3afu924g2
|
⊙ 6. #gi32sh566a
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
@ -354,13 +354,13 @@ I should be able to move the root into a sub-namespace
|
|||||||
Original name New name(s)
|
Original name New name(s)
|
||||||
happy.b.termInA history.a.termInA
|
happy.b.termInA history.a.termInA
|
||||||
|
|
||||||
⊙ 7. #0bb30gq2b1
|
⊙ 7. #u2bs53f2hl
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
history.a.termInA history.b.termInB
|
history.a.termInA history.b.termInB
|
||||||
|
|
||||||
⊙ 8. #aoclegh6j7
|
⊙ 8. #48hsm89mgl
|
||||||
|
|
||||||
> Moves:
|
> Moves:
|
||||||
|
|
||||||
@ -370,7 +370,7 @@ I should be able to move the root into a sub-namespace
|
|||||||
happy.a.T.T2 happy.b.T.T2
|
happy.a.T.T2 happy.b.T.T2
|
||||||
happy.a.termInA happy.b.termInA
|
happy.a.termInA happy.b.termInA
|
||||||
|
|
||||||
⊙ 9. #509sbqajct
|
⊙ 9. #pqd79g3q7l
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
@ -380,7 +380,7 @@ I should be able to move the root into a sub-namespace
|
|||||||
|
|
||||||
happy.a.T.T
|
happy.a.T.T
|
||||||
|
|
||||||
⊙ 10. #8erj1uau9u
|
⊙ 10. #allrjqq7ga
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
@ -392,7 +392,7 @@ I should be able to move the root into a sub-namespace
|
|||||||
|
|
||||||
⠇
|
⠇
|
||||||
|
|
||||||
⊙ 11. #v4nrp8uols
|
⊙ 11. #ohd0a9rim1
|
||||||
|
|
||||||
|
|
||||||
```
|
```
|
||||||
@ -414,26 +414,26 @@ I should be able to move a sub namespace _over_ the root.
|
|||||||
.> ls
|
.> ls
|
||||||
|
|
||||||
1. b/ (3 terms, 1 type)
|
1. b/ (3 terms, 1 type)
|
||||||
2. builtin/ (455 terms, 71 types)
|
2. builtin/ (456 terms, 71 types)
|
||||||
|
|
||||||
.> history
|
.> history
|
||||||
|
|
||||||
Note: The most recent namespace hash is immediately below this
|
Note: The most recent namespace hash is immediately below this
|
||||||
message.
|
message.
|
||||||
|
|
||||||
⊙ 1. #buu0h3vir1
|
⊙ 1. #lf3m1s2e7i
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
b.T b.T.T1 b.T.T2 b.termInA
|
b.T b.T.T1 b.T.T2 b.termInA
|
||||||
|
|
||||||
⊙ 2. #rck0cngerk
|
⊙ 2. #b1cg22v7s1
|
||||||
|
|
||||||
- Deletes:
|
- Deletes:
|
||||||
|
|
||||||
a.T a.T.T1 a.T.T2 a.termInA
|
a.T a.T.T1 a.T.T2 a.termInA
|
||||||
|
|
||||||
⊙ 3. #k6m6gfsvd6
|
⊙ 3. #r83v608ifd
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
@ -443,13 +443,13 @@ I should be able to move a sub namespace _over_ the root.
|
|||||||
|
|
||||||
a.T.T
|
a.T.T
|
||||||
|
|
||||||
⊙ 4. #2rvval9cn9
|
⊙ 4. #pmm6a0f6fj
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
a.T a.T.T a.termInA
|
a.T a.T.T a.termInA
|
||||||
|
|
||||||
□ 5. #schnold03v (start of history)
|
□ 5. #nmcjvlnbk1 (start of history)
|
||||||
|
|
||||||
```
|
```
|
||||||
```ucm
|
```ucm
|
||||||
|
@ -8,4 +8,5 @@ Some tests of pattern behavior.
|
|||||||
p1 = join [literal "blue", literal "frog"]
|
p1 = join [literal "blue", literal "frog"]
|
||||||
|
|
||||||
> Pattern.run (many p1) "bluefrogbluegoat"
|
> Pattern.run (many p1) "bluefrogbluegoat"
|
||||||
|
> Pattern.run (many.corrected p1) "bluefrogbluegoat"
|
||||||
```
|
```
|
||||||
|
@ -4,6 +4,7 @@ Some tests of pattern behavior.
|
|||||||
p1 = join [literal "blue", literal "frog"]
|
p1 = join [literal "blue", literal "frog"]
|
||||||
|
|
||||||
> Pattern.run (many p1) "bluefrogbluegoat"
|
> Pattern.run (many p1) "bluefrogbluegoat"
|
||||||
|
> Pattern.run (many.corrected p1) "bluefrogbluegoat"
|
||||||
```
|
```
|
||||||
|
|
||||||
```ucm
|
```ucm
|
||||||
@ -22,6 +23,10 @@ p1 = join [literal "blue", literal "frog"]
|
|||||||
`>`)... Ctrl+C cancels.
|
`>`)... Ctrl+C cancels.
|
||||||
|
|
||||||
3 | > Pattern.run (many p1) "bluefrogbluegoat"
|
3 | > Pattern.run (many p1) "bluefrogbluegoat"
|
||||||
|
⧩
|
||||||
|
Some ([], "goat")
|
||||||
|
|
||||||
|
4 | > Pattern.run (many.corrected p1) "bluefrogbluegoat"
|
||||||
⧩
|
⧩
|
||||||
Some ([], "bluegoat")
|
Some ([], "bluegoat")
|
||||||
|
|
||||||
|
@ -63,17 +63,17 @@ y = 2
|
|||||||
most recent, along with the command that got us there. Try:
|
most recent, along with the command that got us there. Try:
|
||||||
|
|
||||||
`fork 2 .old`
|
`fork 2 .old`
|
||||||
`fork #lbg8tf1sdh .old` to make an old namespace
|
`fork #mq4oqhiuuq .old` to make an old namespace
|
||||||
accessible again,
|
accessible again,
|
||||||
|
|
||||||
`reset-root #lbg8tf1sdh` to reset the root namespace and
|
`reset-root #mq4oqhiuuq` to reset the root namespace and
|
||||||
its history to that of the
|
its history to that of the
|
||||||
specified namespace.
|
specified namespace.
|
||||||
|
|
||||||
When Root Hash Action
|
When Root Hash Action
|
||||||
1. now #5gonu2p9gp add
|
1. now #1n5tjujeu7 add
|
||||||
2. now #lbg8tf1sdh add
|
2. now #mq4oqhiuuq add
|
||||||
3. now #schnold03v builtins.merge
|
3. now #nmcjvlnbk1 builtins.merge
|
||||||
4. #sg60bvjo91 history starts here
|
4. #sg60bvjo91 history starts here
|
||||||
|
|
||||||
Tip: Use `diff.namespace 1 7` to compare namespaces between
|
Tip: Use `diff.namespace 1 7` to compare namespaces between
|
||||||
|
@ -28,13 +28,13 @@ a = 5
|
|||||||
Note: The most recent namespace hash is immediately below this
|
Note: The most recent namespace hash is immediately below this
|
||||||
message.
|
message.
|
||||||
|
|
||||||
⊙ 1. #havp29or07
|
⊙ 1. #0nv4t3770d
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
a
|
a
|
||||||
|
|
||||||
□ 2. #schnold03v (start of history)
|
□ 2. #nmcjvlnbk1 (start of history)
|
||||||
|
|
||||||
.> reset 2
|
.> reset 2
|
||||||
|
|
||||||
@ -47,7 +47,7 @@ a = 5
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
□ 1. #schnold03v (start of history)
|
□ 1. #nmcjvlnbk1 (start of history)
|
||||||
|
|
||||||
```
|
```
|
||||||
```unison
|
```unison
|
||||||
@ -83,13 +83,13 @@ foo.a = 5
|
|||||||
Note: The most recent namespace hash is immediately below this
|
Note: The most recent namespace hash is immediately below this
|
||||||
message.
|
message.
|
||||||
|
|
||||||
⊙ 1. #i2199da947
|
⊙ 1. #3s91aop8k9
|
||||||
|
|
||||||
+ Adds / updates:
|
+ Adds / updates:
|
||||||
|
|
||||||
foo.a
|
foo.a
|
||||||
|
|
||||||
□ 2. #schnold03v (start of history)
|
□ 2. #nmcjvlnbk1 (start of history)
|
||||||
|
|
||||||
.> reset 1 foo
|
.> reset 1 foo
|
||||||
|
|
||||||
|
@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
□ 1. #iq58l8umv4 (start of history)
|
□ 1. #3pq2vvggng (start of history)
|
||||||
|
|
||||||
.> fork builtin builtin2
|
.> fork builtin builtin2
|
||||||
|
|
||||||
@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th
|
|||||||
Note: The most recent namespace hash is immediately below this
|
Note: The most recent namespace hash is immediately below this
|
||||||
message.
|
message.
|
||||||
|
|
||||||
⊙ 1. #cb1ngbi7os
|
⊙ 1. #4g884gq7lc
|
||||||
|
|
||||||
> Moves:
|
> Moves:
|
||||||
|
|
||||||
Original name New name
|
Original name New name
|
||||||
Nat.frobnicate Nat.+
|
Nat.frobnicate Nat.+
|
||||||
|
|
||||||
⊙ 2. #evasbqug8s
|
⊙ 2. #hnah4l7s0j
|
||||||
|
|
||||||
> Moves:
|
> Moves:
|
||||||
|
|
||||||
Original name New name
|
Original name New name
|
||||||
Nat.+ Nat.frobnicate
|
Nat.+ Nat.frobnicate
|
||||||
|
|
||||||
□ 3. #iq58l8umv4 (start of history)
|
□ 3. #3pq2vvggng (start of history)
|
||||||
|
|
||||||
```
|
```
|
||||||
If we merge that back into `builtin`, we get that same chain of history:
|
If we merge that back into `builtin`, we get that same chain of history:
|
||||||
@ -73,21 +73,21 @@ If we merge that back into `builtin`, we get that same chain of history:
|
|||||||
Note: The most recent namespace hash is immediately below this
|
Note: The most recent namespace hash is immediately below this
|
||||||
message.
|
message.
|
||||||
|
|
||||||
⊙ 1. #cb1ngbi7os
|
⊙ 1. #4g884gq7lc
|
||||||
|
|
||||||
> Moves:
|
> Moves:
|
||||||
|
|
||||||
Original name New name
|
Original name New name
|
||||||
Nat.frobnicate Nat.+
|
Nat.frobnicate Nat.+
|
||||||
|
|
||||||
⊙ 2. #evasbqug8s
|
⊙ 2. #hnah4l7s0j
|
||||||
|
|
||||||
> Moves:
|
> Moves:
|
||||||
|
|
||||||
Original name New name
|
Original name New name
|
||||||
Nat.+ Nat.frobnicate
|
Nat.+ Nat.frobnicate
|
||||||
|
|
||||||
□ 3. #iq58l8umv4 (start of history)
|
□ 3. #3pq2vvggng (start of history)
|
||||||
|
|
||||||
```
|
```
|
||||||
Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged:
|
Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged:
|
||||||
@ -108,7 +108,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
□ 1. #iq58l8umv4 (start of history)
|
□ 1. #3pq2vvggng (start of history)
|
||||||
|
|
||||||
```
|
```
|
||||||
The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect.
|
The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect.
|
||||||
@ -493,13 +493,13 @@ This checks to see that squashing correctly preserves deletions:
|
|||||||
Note: The most recent namespace hash is immediately below this
|
Note: The most recent namespace hash is immediately below this
|
||||||
message.
|
message.
|
||||||
|
|
||||||
⊙ 1. #272p6p79u5
|
⊙ 1. #jdptkosbfp
|
||||||
|
|
||||||
- Deletes:
|
- Deletes:
|
||||||
|
|
||||||
Nat.* Nat.+
|
Nat.* Nat.+
|
||||||
|
|
||||||
□ 2. #iq58l8umv4 (start of history)
|
□ 2. #3pq2vvggng (start of history)
|
||||||
|
|
||||||
```
|
```
|
||||||
Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history.
|
Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history.
|
||||||
|
@ -57,7 +57,7 @@ proj/main> upgrade old new
|
|||||||
|
|
||||||
proj/main> ls lib
|
proj/main> ls lib
|
||||||
|
|
||||||
1. builtin/ (455 terms, 71 types)
|
1. builtin/ (456 terms, 71 types)
|
||||||
2. new/ (1 term)
|
2. new/ (1 term)
|
||||||
|
|
||||||
proj/main> view thingy
|
proj/main> view thingy
|
||||||
|
Loading…
Reference in New Issue
Block a user