unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-21 07:17:25 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/trunk' into lsp/binding-annotations

Browse Source
This commit is contained in:
Chris Penner 2023-03-23 15:33:52 -06:00
commit 3a54bc5652
455 changed files with 20725 additions and 6619 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
.github/workflows/ci.yaml vendored
View File

@ -17,9 +17,19 @@ on:
- release/*
jobs:
ormolu:
runs-on: ubuntu-20.04
steps:
- uses: actions/checkout@v2
with:
path: unison
- uses: mrkkrp/ormolu-action@v10 # v10 uses ormolu 0.5.3.0
build:
name: ${{ matrix.os }}
runs-on: ${{ matrix.os }}
needs: ormolu
defaults:
run:
working-directory: unison
@ -101,7 +111,7 @@ jobs:
working-directory: ${{ github.workspace }}
run: |
mkdir stack && cd stack
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.7.5/stack-2.7.5-linux-x86_64.tar.gz | tar -xz
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.9.1/stack-2.9.1-linux-x86_64.tar.gz | tar -xz
echo "$PWD/stack-"* >> $GITHUB_PATH
- name: install stack (macOS)
@ -109,7 +119,7 @@ jobs:
if: runner.os == 'macOS'
run: |
mkdir stack && cd stack
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.7.5/stack-2.7.5-osx-x86_64.tar.gz | tar -xz
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.9.1/stack-2.9.1-osx-x86_64.tar.gz | tar -xz
echo "$PWD/stack-"* >> $GITHUB_PATH
- name: install stack (windows)
@ -117,7 +127,7 @@ jobs:
if: runner.os == 'Windows'
run: |
mkdir stack && cd stack
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.7.5/stack-2.7.5-windows-x86_64.tar.gz | tar -xz
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.9.1/stack-2.9.1-windows-x86_64.tar.gz | tar -xz
echo "$PWD/stack-"* >> $GITHUB_PATH
# One of the transcripts fails if the user's git name hasn't been set.

2
.github/workflows/haddocks.yaml vendored
View File

@ -62,7 +62,7 @@ jobs:
working-directory: ${{ github.workspace }}
run: |
mkdir stack && cd stack
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.7.5/stack-2.7.5-linux-x86_64.tar.gz | tar -xz
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.9.1/stack-2.9.1-linux-x86_64.tar.gz | tar -xz
echo "$PWD/stack-"* >> $GITHUB_PATH
# One of the transcripts fails if the user's git name hasn't been set.

8
.github/workflows/pre-release.yaml vendored
View File

@ -23,7 +23,7 @@ jobs:
working-directory: ${{ github.workspace }}
run: |
mkdir stack && cd stack
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.7.5/stack-2.7.5-linux-x86_64.tar.gz | tar -xz
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.9.1/stack-2.9.1-linux-x86_64.tar.gz | tar -xz
echo "$PWD/stack-"* >> $GITHUB_PATH
# One of the transcripts fails if the user's git name hasn't been set.
@ -61,7 +61,7 @@ jobs:
working-directory: ${{ github.workspace }}
run: |
mkdir stack && cd stack
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.7.5/stack-2.7.5-osx-x86_64.tar.gz | tar -xz
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.9.1/stack-2.9.1-osx-x86_64.tar.gz | tar -xz
echo "$PWD/stack-"* >> $GITHUB_PATH
# One of the transcripts fails if the user's git name hasn't been set.
@ -104,7 +104,7 @@ jobs:
if: runner.os == 'Windows'
run: |
mkdir stack && cd stack
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.7.5/stack-2.7.5-windows-x86_64.tar.gz | tar -xz
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.9.1/stack-2.9.1-windows-x86_64.tar.gz | tar -xz
echo "$PWD/stack-"* >> $GITHUB_PATH
- name: build
@ -118,7 +118,7 @@ jobs:
run: |
mkdir -p tmp\ui
mkdir -p release\ui
$UCM = .\stack\stack-2.7.5-windows-x86_64\stack.exe exec -- where unison
$UCM = .\stack\stack-2.9.1-windows-x86_64\stack.exe exec -- where unison
cp $UCM .\release\ucm.exe
Invoke-WebRequest -Uri https://github.com/unisonweb/unison-local-ui/releases/download/latest/unisonLocal.zip -OutFile tmp\unisonLocal.zip
Expand-Archive -Path tmp\unisonLocal.zip -DestinationPath release\ui

8
.github/workflows/release.yaml vendored
View File

@ -104,7 +104,7 @@ jobs:
working-directory: ${{ github.workspace }}
run: |
mkdir stack && cd stack
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.7.5/stack-2.7.5-linux-x86_64.tar.gz | tar -xz
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.9.1/stack-2.9.1-linux-x86_64.tar.gz | tar -xz
echo "$PWD/stack-"* >> $GITHUB_PATH
- name: build
@ -176,7 +176,7 @@ jobs:
working-directory: ${{ github.workspace }}
run: |
mkdir stack && cd stack
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.7.5/stack-2.7.5-osx-x86_64.tar.gz | tar -xz
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.9.1/stack-2.9.1-osx-x86_64.tar.gz | tar -xz
echo "$PWD/stack-"* >> $GITHUB_PATH
- name: remove ~/.stack/setup-exe-cache on macOS
@ -252,7 +252,7 @@ jobs:
working-directory: ${{ github.workspace }}
run: |
mkdir stack && cd stack
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.7.5/stack-2.7.5-windows-x86_64.tar.gz | tar -xz
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.9.1/stack-2.9.1-windows-x86_64.tar.gz | tar -xz
echo "$PWD/stack-"* >> $GITHUB_PATH
- name: build
@ -277,7 +277,7 @@ jobs:
run: |
mkdir -p tmp\ui
mkdir -p release\ui
$UCM = .\stack\stack-2.7.5-windows-x86_64\stack.exe exec -- where unison
$UCM = .\stack\stack-2.9.1-windows-x86_64\stack.exe exec -- where unison
cp $UCM .\release\ucm.exe
Invoke-WebRequest -Uri https://github.com/unisonweb/unison-local-ui/releases/download/latest/unisonLocal.zip -OutFile tmp\unisonLocal.zip
Expand-Archive -Path tmp\unisonLocal.zip -DestinationPath release\ui

5
.gitignore vendored
View File

@ -13,3 +13,8 @@ dist-newstyle
# GHC
*.hie
*.prof
# Mac developers
**/.DS_Store
/libb2.dylib

3
CONTRIBUTORS.markdown
View File

@ -72,3 +72,6 @@ The format for this list: name, GitHub handle
* Emil Hotkowski (@emilhotkowski)
* Jesse Looney (@jesselooney)
* Vlad Posmangiu Luchian (@cstml)
* Andrii Uvarov (@unorsk)
* Mario Bašić (@mabasic)
* Chris Krycho (@chriskrycho)

6
README.md
View File

@ -42,6 +42,8 @@ If these instructions don't work for you or are incomplete, please file an issue
The build uses [Stack](http://docs.haskellstack.org/). If you don't already have it installed, [follow the install instructions](http://docs.haskellstack.org/en/stable/README.html#how-to-install) for your platform. (Hint: `brew update && brew install stack`)
If you have not set up the Haskell toolchain before and are trying to contribute to Unison on an M1 Mac, we have [some tips specifically for you](docs/m1-mac-setup-tips.markdown).
```sh
$ git clone https://github.com/unisonweb/unison.git
$ cd unison
@ -49,7 +51,7 @@ $ stack --version # we'll want to know this version if you run into trouble
$ stack build --fast --test && stack exec unison
```
To run the Unison Local UI while building from source, you can use the `/dev-ui-install.sh` script. It will download the latest release of [unison-local-ui](https://github.com/unisonweb/unison-local-ui) and put it in the expected location for the unison executable created by `stack build`. When you start unison, you'll see a url where Unison Local UI is running.
To run the Unison Local UI while building from source, you can use the `/dev-ui-install.sh` script. It will download the latest release of [unison-local-ui](https://github.com/unisonweb/unison-local-ui) and put it in the expected location for the unison executable created by `stack build`. When you start unison, you'll see a url where Unison Local UI is running.
See [`development.markdown`](development.markdown) for a list of build commands you'll likely use during development.
@ -61,7 +63,7 @@ View Language Server setup instructions [here](docs/language-server.markdown).
Codebase Server
---------------
When `ucm` starts it starts a Codebase web server that is used by the
When `ucm` starts it starts a Codebase web server that is used by the
[Unison Local UI](https://github.com/unisonweb/unison-local-ui). It selects a random
port and a unique token that must be used when starting the UI to correctly
connect to the server.

49
chez-libs/readme.md
View File

@ -1,49 +0,0 @@
This directory contains libraries necessary for building and running
unison programs via Chez Scheme. At the moment, they need to be
manually installed in the expected location. The default location is
the `unisonlanguage` directory in the XDG data directory.
Specifically, the `unison` subdirectory should be (recursively) copied
to:
$XDG_DATA_DIRECTORY/unisonlanguage/scheme-libs
On unix systems, the XDG directory is ~/.local/share by default, ~
being the home directory. On Windows, this is instead the %APPDATA%
directory. See:
https://hackage.haskell.org/package/directory/docs/System-Directory.html#t:XdgDirectory
for more information.
UCM can also be told to look in another directory by setting the
`SchemeLibs.Static` item in the unison config file. If this path is
denoted by `$CUSTOM`, then the compiler commands will look in:
$CUSTOM/scheme-libs/
for the `unison/` directory containing the library files.
The compiler commands also expect Chez Scheme to be installed
separately, and for `scheme` to be callable on the user's path. For
information on how to install, see:
https://github.com/cisco/ChezScheme/blob/main/BUILDING
For more information on Chez Scheme in general, see:
https://cisco.github.io/ChezScheme/csug9.5/csug.html
There are two ways to run code via scheme. The first is to use
`run.native`, which compiles and immediately runs a given unison
definition. The second is `compile.native`, which produces a Chez
scheme `.boot` file with a specified name. The boot file can then be
used with the scheme binary to run the precompiled program, like so:
scheme -b ./my-program.boot
It is also possible to install the boot file in a particular
directory, and make a renamed copy of the scheme binary, which will
automatically execute the boot file with the corresponding name on
start up. For more information on how to accomplish that, see:
https://cisco.github.io/ChezScheme/csug9.5/use.html#./use:h8

130
chez-libs/unison/boot.ss
View File

@ -1,130 +0,0 @@
; This library implements various syntactic constructs and functions
; that are used in the compilation of unison (intermediate) source to
; scheme. The intent is to provide for writing scheme definitions that
; more directly match the source, so that the compiler doesn't need to
; emit all the code necessary to fix up the difference itself.
;
; Probably the best example of this is the define-unison macro, which
; looks similar to scheme's define, but the function being defined is
; allowed to be under/over applied similar to a unison function. It
; has an 'arity' at which computation happens, but the function
; automatically handles being applied to fewer or more arguments than
; that arity appropriately.
(library (unison boot)
(export
name
define-unison
func-wrap
handle
request
unison-force)
(import (chezscheme)
(unison cont))
; Helper function. Turns a list of syntax objects into a list-syntax object.
(meta define (list->syntax l) #`(#,@l))
; Concatenates
(meta define fun-sym
(case-lambda
[(pfx sfx) (string->symbol (string-append pfx "-" sfx))]
[(pfx ifx sfx)
(string->symbol (string-append pfx "-" ifx "-" sfx))]))
; Computes a symbol for automatically generated partial application
; cases, based on number of arguments applied. The partial
; application of `f` is (locally) named `f-partial-N`
(meta define (partial-symbol name m)
(fun-sym (symbol->string name) "partial" (number->string m)))
; As above, but takes a syntactic object representing the arguments
; rather than their count.
(meta define (partial-name name us)
(datum->syntax name (syntax->datum name)))
(define-syntax with-name
(syntax-rules ()
[(with-name name e) (let ([name e]) name)]))
; Builds partial application cases for unison functions. It seems
; most efficient to have a case for each posible under-application.
(meta define (build-partials name formals)
(let rec ([us formals] [acc '()])
(syntax-case us ()
[() (list->syntax (cons #`[() #,name] acc))]
[(a ... z)
(rec #'(a ...)
(cons
#`[(a ... z)
(with-name
#,(partial-name name us)
(lambda r (apply #,name a ... z r)))]
acc))])))
; Given an overall function name, a fast path name, and a list of arguments,
; builds the case-lambda body of a unison function that enables applying to
; arbitrary numbers of arguments.
(meta define (func-cases name fast args)
(syntax-case args ()
[() #`(case-lambda
[() (#,fast)]
[r (apply (#,fast) r)])]
[(a ... z)
#`(case-lambda
#,@(build-partials name #'(a ...))
[(a ... z) (#,fast a ... z)]
[(a ... z . r) (apply (#,fast a ... z) r)])]))
(meta define (func-wrap name args body)
#`(let ([fast-path (lambda (#,@args) #,@body)])
#,(func-cases name #'fast-path args)))
; function definition with slow/fast path. Slow path allows for
; under/overapplication. Fast path is exact application.
;
; The intent is for the scheme compiler to be able to recognize and
; optimize static, fast path calls itself, while still supporting
; unison-like automatic partial application and such.
(define-syntax (define-unison x)
(syntax-case x ()
[(define-unison (name a ...) e ...)
#`(define name
#,(func-wrap #'name #'(a ...) #'(e ...)))]))
; call-by-name bindings
(define-syntax name
(syntax-rules ()
((name ([v (f . args)] ...) body)
(let ([v (lambda r (apply f (append (list . args) r)))]
...)
body))))
; wrapper that more closely matches `handle` constructs
(define-syntax handle
(syntax-rules ()
[(handle [r ...] h e ...)
(prompt p (fluid-let ([r (cons p h)] ...) e ...))]))
; wrapper that more closely matches ability requests
(define-syntax request
(syntax-rules ()
[(request r t . args)
((cdr r) (list (quote r) t . args))]))
(define-record-type
data
(fields type-ref payload))
(define-syntax data-case
(syntax-rules ()
[(data-case scrut c ...)
(record-case (data-payload scrut) c ...)]))
; forces something that is expected to be a thunk, defined with
; e.g. `name` above. In some cases, we might have a normal value,
; so just do nothing in that case.
(define (unison-force x)
(if (procedure? x) (x) x))
)

35
chez-libs/unison/bytevector.ss
View File

@ -1,35 +0,0 @@
; This library implements missing bytevector functionality for unison
; builtins. The main missing bits are better support for immutable
; bytevectors. Chez does provide a way to make an immutable
; bytevector, but it copies its input, so implementing things that way
; would make many unncessary copies. This library instead implements
; functions on immutable bytevectors by directly freezing the newly
; created mutable vector. It also provides the freezing function,
; which is itself a unison builtin.
(library (unison bytevector)
(export
freeze-bv!
ibytevector-drop
ibytevector-take
u8-list->ibytevector)
(import (chezscheme))
(define (freeze-bv! bs)
(($primitive $bytevector-set-immutable!) bs)
bs)
(define (ibytevector-drop n bs)
(let* ([l (bytevector-length bs)]
[k (max 0 (- l n))]
[br (make-bytevector k)])
(bytevector-copy! bs n br 0 k)
(freeze-bv! br)))
(define (ibytevector-take n bs)
(let* ([sz (min n (bytevector-length bs))]
[br (make-bytevector sz)])
(bytevector-copy! bs 0 br 0 sz)
(freeze-bv! br)))
(define (u8-list->ibytevector l) (freeze-bv! (u8-list->bytevector l))))

47
chez-libs/unison/cont.ss
View File

@ -1,47 +0,0 @@
; This library is intended to contain the implementation of
; delimited continuations used in the semantics of abilities.
;
; Currently, it is a somewhat naive implementation based on call/cc.
; This has known issues that seem to still be in force even though a
; tweak has been applied that should fix certain space leaks. So, in
; the future it will likely need to be rewritten using some
; implementation specific machinery (possibly making use of
; continuation attachments as in the Racket implementation).
;
; Also, although the API includes prompts, they are currently ignored
; in `control` and `prompt` always uses the same prompt (0). This
; means that nesting handlers will not work in general, since requests
; will not be able to jump over an inner handler of unrelated
; abilities. It should be sufficient for testing simple examples in
; the mean time, though.
(library (unison cont)
(export prompt control)
(import (chezscheme))
(define mk (lambda (x) (raise "fell off end")))
(define (prompt-impl h)
((call/cc
(lambda (k)
(let ([ok mk])
(set! mk (lambda (x) (set! mk ok) (k x)))
; (h 0) <-- prompt = 0
(mk (let ([v (h 0)]) (lambda () v))))))))
(define-syntax prompt
(syntax-rules ()
[(prompt p e ...)
(prompt-impl (lambda (p) e ...))]))
(define (control-impl h)
(call/cc
(lambda (k)
(let* ([g (lambda () (prompt p (h k)))])
(mk g)))))
(define-syntax control
(syntax-rules ()
[(control p k e ...)
(control-impl (lambda (k) e ...))])))

43
chez-libs/unison/core.ss
View File

@ -1,43 +0,0 @@
(library (unison core)
(export
identity
describe-value
decode-value)
(import (chezscheme))
(define (identity x) x)
; Recovers the original function name from the partial
; application name.
(define (extract-name i)
(string->symbol ((i 'code) 'name)))
(define (describe-value x)
(let explain ([i (inspect/object x)])
(case (i 'type)
[(simple) (i 'value)]
[(variable) (explain (i 'ref))]
[(procedure)
(let explain-args ([j (- (i 'length) 1)] [args '()])
(if (< j 0)
(cons (extract-name i) args)
(explain-args
(- j 1)
(cons (explain (i 'ref j)) args))))])))
; partial, data, cont, lit
(define (decode-value x)
(let reify ([i (inspect/object x)])
(case (i 'type)
[(simple) (list 3 (i 'value))]
[(variable) (reify (i 'ref))]
[(procedure)
(let reify-args ([j (- (i 'length) 1)] [args '()])
(if (< j 0)
(cons* 0 (extract-name i) args)
(reify-args
(- j 1)
(cons (reify (i 'ref j)) args))))])))
)

205
chez-libs/unison/primops.ss
View File

@ -1,205 +0,0 @@
; This library implements pimitive operations that are used in
; builtins. There are two different sorts of primitive operations, but
; the difference is essentially irrelevant except for naming schemes.
;
; POps are part of a large enumeration of 'instructions' directly
; implemented in the Haskell runtime. These are referred to using the
; naming scheme `unison-POp-INST` where `INST` is the name of the
; instruction, which is (at the time of this writing) 4 letters.
;
; FOps are 'foreign' functons, which are allowed to be declared more
; flexibly in the Haskell runtime. Each such declaration associates a
; builtin to a Haskell function. For these, the naming shceme is
; `unison-FOp-NAME` where `NAME` is the name of the unison builtin
; associated to the declaration.
;
; Both POps and FOps are always called with exactly the right number
; of arguments, so they may be implemented as ordinary scheme
; definitions with a fixed number of arguments. By implementing the
; POp/FOp, you are expecting the associated unison function(s) to be
; implemented by code generation from the wrappers in
; Unison.Runtime.Builtin, so the POp/FOp implementation must
; take/return arguments that match what is expected in those wrappers.
(library (unison primops)
(export
; unison-FOp-Bytes.decodeNat16be
; unison-FOp-Bytes.decodeNat32be
; unison-FOp-Bytes.decodeNat64be
unison-FOp-Char.toText
; unison-FOp-Code.dependencies
; unison-FOp-Code.serialize
unison-FOp-IO.closeFile.impl.v3
unison-FOp-IO.openFile.impl.v3
unison-FOp-IO.putBytes.impl.v3
; unison-FOp-Text.fromUtf8.impl.v3
unison-FOp-Text.repeat
unison-FOp-Text.toUtf8
; unison-FOp-Value.serialize
unison-FOp-IO.stdHandle
unison-FOp-ImmutableByteArray.copyTo!
unison-FOp-ImmutableByteArray.read8
unison-FOp-MutableByteArray.freeze!
unison-FOp-MutableByteArray.write8
unison-FOp-Scope.bytearray
unison-POp-ADDN
unison-POp-ANDN
unison-POp-BLDS
unison-POp-CATS
unison-POp-CATT
unison-POp-CMPU
unison-POp-COMN
unison-POp-CONS
unison-POp-DECI
unison-POp-DIVN
unison-POp-DRPB
unison-POp-DRPS
unison-POp-EQLN
unison-POp-EQLT
unison-POp-EQLU
unison-POp-EROR
unison-POp-FTOT
unison-POp-IDXB
unison-POp-IDXS
unison-POp-IORN
unison-POp-ITOT
unison-POp-LEQN
; unison-POp-LKUP
unison-POp-MULN
unison-POp-NTOT
unison-POp-PAKT
unison-POp-SHLI
unison-POp-SHLN
unison-POp-SHRI
unison-POp-SHRN
unison-POp-SIZS
unison-POp-SIZT
unison-POp-SNOC
unison-POp-SUBN
unison-POp-TAKS
unison-POp-TAKT
unison-POp-TRCE
unison-POp-UPKT
unison-POp-VALU
unison-POp-VWLS
)
(import (chezscheme)
(unison core)
(unison string)
(unison bytevector))
; Core implemented primops, upon which primops-in-unison can be built.
(define (unison-POp-ADDN m n) (fx+ m n))
(define (unison-POp-ANDN m n) (fxlogand m n))
(define unison-POp-BLDS list)
(define (unison-POp-CATS l r) (append l r))
(define (unison-POp-CATT l r) (istring-append l r))
(define (unison-POp-CMPU l r) (equal? l r))
(define (unison-POp-COMN n) (fxlognot n))
(define (unison-POp-CONS x xs) (cons x xs))
(define (unison-POp-DECI n) (+ n 1))
(define (unison-POp-DIVN m n) (fxdiv m n))
(define (unison-POp-DRPB n bs) (ibytevector-drop n bs))
(define (unison-POp-DRPS n l)
(let ([m (max 0 (min n (length l)))]) (list-tail l m)))
(define (unison-POp-DRPT n t) (istring-drop n t))
(define (unison-POp-EQLN m n) (if (fx= m n) 1 0))
(define (unison-POp-EQLT s t) (if (string=? s t) 1 0))
(define (unison-POp-EQLU x y) (equal? x y))
(define (unison-POp-EROR fnm x) (raise fnm))
(define (unison-POp-FTOT f) (number->istring f))
(define (unison-POp-IDXB n bs) (bytevector-u8-ref bs n))
(define (unison-POp-IDXS n l) (list-ref l n))
(define (unison-POp-IORN m n) (fxlogior m n))
(define (unison-POp-ITOT i) (signed-number->istring i))
(define (unison-POp-LEQN m n) (if (fx< m n) 1 0))
(define (unison-POp-MULN m n) (* m n))
(define (unison-POp-NTOT m) (number->istring m))
(define (unison-POp-PAKB l) (u8-list->ibytevector l))
(define (unison-POp-PAKT l) (list->istring l))
(define (unison-POp-SHLI i k) (fxarithmetic-shift-left i k))
(define (unison-POp-SHLN n k) (fxarithmetic-shift-left n k))
(define (unison-POp-SHRI i k) (fxarithmetic-shift-right i k))
(define (unison-POp-SHRN n k) (fxarithmetic-shift-right n k))
(define (unison-POp-SIZS l) (length l))
(define (unison-POp-SIZT t) (string-length t))
(define (unison-POp-SNOC xs x) (append xs (list x)))
(define (unison-POp-SUBN m n) (fx- m n))
(define (unison-POp-TAKS n s) (list-head s n))
(define (unison-POp-TAKT n t) (istring-take n t))
(define (unison-POp-TRCE x) (display (describe-value x)))
(define (unison-POp-UPKT t) (string->list t))
(define (unison-POp-VWLS l)
(if (null? l)
(list 0)
(list 1 (car l) (cdr l))))
(define (unison-POp-VALU c) (decode-value c))
(define (unison-FOp-IO.putBytes.impl.v3 p bs)
(begin
(put-bytevector p bs)
(flush-output-port p)
(list 1 #f)))
(define (unison-FOp-Char.toText c) (istring c))
(define stdin (standard-input-port))
(define stdout (standard-output-port))
(define stderr (standard-error-port))
(define (unison-FOp-IO.stdHandle n)
(case n
[(0) stdin]
[(1) stdout]
[(2) stderr]))
(define (unison-FOp-Text.toUtf8 s)
(string->bytevector s utf-8-transcoder))
(define (unison-FOp-IO.closeFile.impl.v3 h)
(close-input-port h))
(define (unison-FOp-IO.openFile.impl.v3 fn mode)
(case mode
[(0) (open-file-input-port fn)]
[(1) (open-file-output-port fn)]
[(2) (open-file-output-port fn 'no-truncate)]
[else (open-file-input/output-port fn)]))
(define (unison-FOp-Text.repeat n t) (istring-repeat n t))
(define (catch-array thunk)
(with-exception-handler
(lambda (e) (list 0 '() "array index out of boudns" e))
thunk))
(define (unison-FOp-ImmutableByteArray.copyTo! dst doff src soff n)
(catch-array
(lambda ()
(bytevector-copy! src soff dst doff n)
(list 1))))
(define (unison-FOp-ImmutableByteArray.read8 arr i)
(catch-array
(lambda ()
(list 1 (bytevector-u8-ref arr i)))))
(define (unison-FOp-MutableByteArray.freeze! arr)
(freeze-bv! arr))
(define (unison-FOp-MutableByteArray.write8 arr i b)
(catch-array
(lambda ()
(bytevector-u8-set! arr i b)
(list 1))))
(define (unison-FOp-Scope.bytearray n) (make-bytevector n))
)

60
chez-libs/unison/string.ss
View File

@ -1,60 +0,0 @@
; This library wraps some chez functionality to provide immutable
; strings. There is a wrapper for making immutable strings in chez,
; but it copies its input, so relying on that would involve every
; string operation building a fresh mutable string, then making an
; immutable copy. This library instead directly freezes the newly
; created mutable strings.
(library (unison string)
(export
istring
istring-append
istring-drop
istring-take
istring-repeat
list->istring
make-istring
number->istring
signed-number->istring
utf8-bytevector->istring
utf-8-transcoder)
(import (chezscheme))
(define (freeze-s! s)
(($primitive $string-set-immutable!) s)
s)
(define istring (lambda l (freeze-s! (apply string l))))
(define (make-istring n c) (freeze-s! (make-string n c)))
(define (istring-repeat n s)
(let* ([k (string-length s)]
[t (make-string (* k n))])
(let loop ([i 0])
(if (< i n)
(begin
(string-copy! s 0 t (* i k) k)
(loop (+ i 1)))
(freeze-s! t)))))
(define istring-append (lambda l (freeze-s! (apply string-append l))))
(define (istring-drop n s) (freeze-s! (substring s n (- (string-length s) n))))
(define (number->istring n) (freeze-s! (number->string n)))
(define (signed-number->istring n)
(freeze-s!
(if (>= n 0)
(string-append "+" (number->string n))
(number->string n))))
(define (list->istring l) (freeze-s! (list->string l)))
(define (istring-take n s) (freeze-s! (substring s 0 n)))
(define utf-8-transcoder (make-transcoder (utf-8-codec)))
(define (utf8-bytevector->istring bs)
(freeze-s! (bytevector->string bs utf-8-transcoder))))

1
codebase2/codebase-sqlite-hashing-v2/package.yaml
View File

@ -15,6 +15,7 @@ dependencies:
- unison-codebase-sqlite
- unison-core
- unison-core1
- unison-hash
- unison-hashing-v2
- unison-prelude
- unison-sqlite

10
codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/HashHandle.hs
View File

@ -6,14 +6,14 @@ where
import qualified Data.Set as Set
import U.Codebase.Sqlite.HashHandle
import U.Util.Type (removeAllEffectVars)
import qualified Unison.Hashing.V2 as H2
import Unison.Hashing.V2.Convert2 (h2ToV2Reference, v2ToH2Type, v2ToH2TypeD)
import qualified Unison.Hashing.V2.Type as H2
v2HashHandle :: HashHandle
v2HashHandle =
HashHandle
{ toReference = h2ToV2Reference . H2.toReference . v2ToH2Type . removeAllEffectVars,
toReferenceMentions = Set.map h2ToV2Reference . H2.toReferenceMentions . v2ToH2Type . removeAllEffectVars,
toReferenceDecl = \h -> h2ToV2Reference . H2.toReference . v2ToH2TypeD h . removeAllEffectVars,
toReferenceDeclMentions = \h -> Set.map h2ToV2Reference . H2.toReferenceMentions . v2ToH2TypeD h . removeAllEffectVars
{ toReference = h2ToV2Reference . H2.typeToReference . v2ToH2Type . removeAllEffectVars,
toReferenceMentions = Set.map h2ToV2Reference . H2.typeToReferenceMentions . v2ToH2Type . removeAllEffectVars,
toReferenceDecl = \h -> h2ToV2Reference . H2.typeToReference . v2ToH2TypeD h . removeAllEffectVars,
toReferenceDeclMentions = \h -> Set.map h2ToV2Reference . H2.typeToReferenceMentions . v2ToH2TypeD h . removeAllEffectVars
}

50
codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs
View File

@ -11,50 +11,48 @@ import qualified U.Codebase.Reference as V2
import qualified U.Codebase.Term as V2 (TypeRef)
import qualified U.Codebase.Type as V2.Type
import qualified U.Core.ABT as ABT
import qualified U.Util.Hash as V2 (Hash)
import qualified Unison.Hashing.V2.Kind as H2
import qualified Unison.Hashing.V2.Reference as H2
import qualified Unison.Hashing.V2.Type as H2.Type
import Unison.Hash (Hash)
import qualified Unison.Hashing.V2 as H2
import Unison.Prelude
convertId :: V2.Hash -> V2.Id' (Maybe V2.Hash) -> H2.Id
convertId :: Hash -> V2.Id' (Maybe Hash) -> H2.ReferenceId
convertId defaultHash = \case
V2.Id m p -> H2.Id (fromMaybe defaultHash m) p
V2.Id m p -> H2.ReferenceId (fromMaybe defaultHash m) p
convertReference :: V2.Reference -> H2.Reference
convertReference = convertReference' (\(V2.Id a b) -> H2.Id a b)
convertReference = convertReference' (\(V2.Id a b) -> H2.ReferenceId a b)
convertReference' :: (V2.Id' hash -> H2.Id) -> V2.Reference' Text hash -> H2.Reference
convertReference' :: (V2.Id' hash -> H2.ReferenceId) -> V2.Reference' Text hash -> H2.Reference
convertReference' idConv = \case
V2.ReferenceBuiltin x -> H2.Builtin x
V2.ReferenceDerived x -> H2.DerivedId (idConv x)
V2.ReferenceBuiltin x -> H2.ReferenceBuiltin x
V2.ReferenceDerived x -> H2.ReferenceDerivedId (idConv x)
v2ToH2Type :: forall v. Ord v => V2.Type.TypeR V2.TypeRef v -> H2.Type.Type v ()
v2ToH2Type :: forall v. (Ord v) => V2.Type.TypeR V2.TypeRef v -> H2.Type v ()
v2ToH2Type = v2ToH2Type' convertReference
v2ToH2TypeD :: forall v. Ord v => V2.Hash -> V2.Type.TypeD v -> H2.Type.Type v ()
v2ToH2TypeD :: forall v. (Ord v) => Hash -> V2.Type.TypeD v -> H2.Type v ()
v2ToH2TypeD defaultHash = v2ToH2Type' (convertReference' (convertId defaultHash))
v2ToH2Type' :: forall r v. Ord v => (r -> H2.Reference) -> V2.Type.TypeR r v -> H2.Type.Type v ()
v2ToH2Type' :: forall r v. (Ord v) => (r -> H2.Reference) -> V2.Type.TypeR r v -> H2.Type v ()
v2ToH2Type' mkReference = ABT.transform convertF
where
convertF :: forall a. V2.Type.F' r a -> H2.Type.F a
convertF :: forall a. V2.Type.F' r a -> H2.TypeF a
convertF = \case
V2.Type.Ref x -> H2.Type.Ref (mkReference x)
V2.Type.Arrow a b -> H2.Type.Arrow a b
V2.Type.Ann a k -> H2.Type.Ann a (convertKind k)
V2.Type.App a b -> H2.Type.App a b
V2.Type.Effect a b -> H2.Type.Effect a b
V2.Type.Effects a -> H2.Type.Effects a
V2.Type.Forall a -> H2.Type.Forall a
V2.Type.IntroOuter a -> H2.Type.IntroOuter a
V2.Type.Ref x -> H2.TypeRef (mkReference x)
V2.Type.Arrow a b -> H2.TypeArrow a b
V2.Type.Ann a k -> H2.TypeAnn a (convertKind k)
V2.Type.App a b -> H2.TypeApp a b
V2.Type.Effect a b -> H2.TypeEffect a b
V2.Type.Effects a -> H2.TypeEffects a
V2.Type.Forall a -> H2.TypeForall a
V2.Type.IntroOuter a -> H2.TypeIntroOuter a
convertKind :: V2.Kind -> H2.Kind
convertKind = \case
V2.Star -> H2.Star
V2.Arrow a b -> H2.Arrow (convertKind a) (convertKind b)
V2.Star -> H2.KindStar
V2.Arrow a b -> H2.KindArrow (convertKind a) (convertKind b)
h2ToV2Reference :: H2.Reference -> V2.Reference
h2ToV2Reference = \case
H2.Builtin txt -> V2.ReferenceBuiltin txt
H2.DerivedId (H2.Id x y) -> V2.ReferenceDerived (V2.Id x y)
H2.ReferenceBuiltin txt -> V2.ReferenceBuiltin txt
H2.ReferenceDerivedId (H2.ReferenceId x y) -> V2.ReferenceDerived (V2.Id x y)

1
codebase2/codebase-sqlite-hashing-v2/unison-codebase-sqlite-hashing-v2.cabal
View File

@ -59,6 +59,7 @@ library
, unison-codebase-sqlite
, unison-core
, unison-core1
, unison-hash
, unison-hashing-v2
, unison-prelude
, unison-sqlite

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs
View File

@ -7,7 +7,7 @@ import qualified U.Codebase.Reference as C
import U.Codebase.Sqlite.Symbol (Symbol)
import qualified U.Codebase.Term as C.Term
import qualified U.Codebase.Type as C.Type
import U.Util.Hash (Hash)
import Unison.Hash (Hash)
import Unison.Prelude
data HashHandle = HashHandle

4
codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalizeObject.hs
View File

@ -122,7 +122,7 @@ type LocalizeBranchState =
)
-- Run a computation that localizes a branch object, returning the local ids recorded within.
runLocalizeBranch :: Monad m => StateT LocalizeBranchState m a -> m (BranchLocalIds, a)
runLocalizeBranch :: (Monad m) => StateT LocalizeBranchState m a -> m (BranchLocalIds, a)
runLocalizeBranch action = do
(result, (localTexts, localDefns, localPatches, localChildren)) <- State.runStateT action (mempty @LocalizeBranchState)
let branchLocalIds :: BranchLocalIds
@ -143,7 +143,7 @@ type LocalizePatchState =
)
-- Run a computation that localizes a patch object, returning the local ids recorded within.
runLocalizePatch :: Monad m => StateT LocalizePatchState m a -> m (PatchLocalIds, a)
runLocalizePatch :: (Monad m) => StateT LocalizePatchState m a -> m (PatchLocalIds, a)
runLocalizePatch action = do
(result, (localTexts, localHashes, localDefns)) <- State.runStateT action (mempty @LocalizePatchState)
let patchLocalIds :: PatchLocalIds

36
codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs
View File

@ -5,7 +5,7 @@ import qualified Data.List.NonEmpty as NEL
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text
import Unison.Prelude
import Unison.Sqlite (FromField (..), FromRow (..), SQLData (..), ToField (..), ToRow (..), field)
import Unison.Sqlite
type ReversedSegments = NonEmpty Text
@ -28,19 +28,43 @@ instance FromField (ConstructorType) where
data NamedRef ref = NamedRef {reversedSegments :: ReversedSegments, ref :: ref}
deriving stock (Show, Functor, Foldable, Traversable)
instance ToRow ref => ToRow (NamedRef ref) where
instance (ToRow ref) => ToRow (NamedRef ref) where
toRow (NamedRef {reversedSegments = segments, ref}) =
[toField reversedName] <> toRow ref
where
reversedName = Text.intercalate "." . toList $ segments
reversedName =
segments
& toList
& Text.intercalate "."
& (<> ".") -- Add trailing dot, see notes on scoped_term_name_lookup schema
instance FromRow ref => FromRow (NamedRef ref) where
instance (FromRow ref) => FromRow (NamedRef ref) where
fromRow = do
reversedSegments <- NonEmpty.fromList . Text.splitOn "." <$> field
reversedSegments <-
field <&> \f ->
f
& Text.init -- Drop trailing dot, see notes on scoped_term_name_lookup schema
& Text.splitOn "."
& NonEmpty.fromList
ref <- fromRow
pure (NamedRef {reversedSegments, ref})
toRowWithNamespace :: ToRow ref => NamedRef ref -> [SQLData]
toRowWithNamespace :: (ToRow ref) => NamedRef ref -> [SQLData]
toRowWithNamespace nr = toRow nr <> [SQLText namespace]
where
namespace = Text.intercalate "." . reverse . NEL.tail . reversedSegments $ nr
-- | The new 'scoped' name lookup format is different from the old version.
--
-- Specifically, the scoped format adds the 'lastNameSegment' as well as adding a trailing '.' to the db format
-- of both the namespace and reversed_name.
--
-- Converts a NamedRef to SQLData of the form:
-- [reversedName, namespace, lastNameSegment] <> ref fields...
namedRefToScopedRow :: (ToRow ref) => NamedRef ref -> [SQLData]
namedRefToScopedRow (NamedRef {reversedSegments = revSegments, ref}) =
toRow $ (SQLText reversedName, SQLText namespace, SQLText lastNameSegment) :. ref
where
reversedName = (Text.intercalate "." . toList $ revSegments) <> "."
namespace = (Text.intercalate "." . reverse . NEL.tail $ revSegments) <> "."
lastNameSegment = NEL.head revSegments

65
codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs
View File

@ -67,9 +67,10 @@ module U.Codebase.Sqlite.Operations
termsMentioningType,
-- ** name lookup index
updateNameIndex,
rootNamesByPath,
NamesByPath (..),
checkBranchHashNameLookupExists,
buildNameLookupForBranchHash,
-- * reflog
getReflog,
@ -163,9 +164,9 @@ import qualified U.Codebase.TypeEdit as C
import qualified U.Codebase.TypeEdit as C.TypeEdit
import U.Codebase.WatchKind (WatchKind)
import qualified U.Util.Base32Hex as Base32Hex
import qualified U.Util.Hash as H
import qualified U.Util.Hash32 as Hash32
import qualified U.Util.Serialization as S
import qualified Unison.Hash as H
import qualified Unison.Hash32 as Hash32
import Unison.NameSegment (NameSegment (NameSegment))
import qualified Unison.NameSegment as NameSegment
import Unison.Prelude
@ -544,7 +545,8 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) =
Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) ->
Transaction (Map NameSegment (C.Causal Transaction CausalHash BranchHash (C.Branch.Branch Transaction)))
doChildren = Map.bitraverse (fmap NameSegment . Q.expectText) \(boId, chId) ->
C.Causal <$> Q.expectCausalHash chId
C.Causal
<$> Q.expectCausalHash chId
<*> expectValueHashByCausalHashId chId
<*> headParents chId
<*> pure (expectBranch boId)
@ -572,7 +574,8 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) =
Db.CausalHashId ->
Transaction (C.Causal Transaction CausalHash BranchHash (C.Branch.Branch Transaction))
loadCausal chId = do
C.Causal <$> Q.expectCausalHash chId
C.Causal
<$> Q.expectCausalHash chId
<*> expectValueHashByCausalHashId chId
<*> headParents chId
<*> pure (loadValue chId)
@ -771,7 +774,7 @@ expectDbBranch id =
(mergePatches patches patches')
(mergeChildren children children')
mergeChildren ::
Ord ns =>
(Ord ns) =>
Map ns (Db.BranchObjectId, Db.CausalHashId) ->
Map ns S.BranchDiff.ChildOp ->
Map ns (Db.BranchObjectId, Db.CausalHashId)
@ -794,7 +797,7 @@ expectDbBranch id =
S.BranchDiff.ChildAddReplace id -> id
S.BranchDiff.ChildRemove -> error "diff tries to remove a nonexistent child"
mergePatches ::
Ord ns =>
(Ord ns) =>
Map ns Db.PatchObjectId ->
Map ns S.BranchDiff.PatchOp ->
Map ns Db.PatchObjectId
@ -826,7 +829,7 @@ expectDbBranch id =
S.Branch.Diff.RemoveDef -> error "diff tries to remove a nonexistent definition"
S.Branch.Diff.AlterDefMetadata _md -> error "diff tries to change metadata for a nonexistent definition"
mergeDefnOp ::
Ord r =>
(Ord r) =>
Map r S.MetadataSet.DbMetadataSet ->
Map r S.BranchDiff.DefinitionOp ->
Map r S.MetadataSet.DbMetadataSet
@ -872,7 +875,10 @@ saveDbBranchUnderHashId hh bhId@(Db.unBranchHashId -> hashId) stats branch = do
let (localBranchIds, localBranch) = LocalizeObject.localizeBranch branch
when debug $
traceM $
"saveBranchObject\n\tid = " ++ show bhId ++ "\n\tli = " ++ show localBranchIds
"saveBranchObject\n\tid = "
++ show bhId
++ "\n\tli = "
++ show localBranchIds
++ "\n\tlBranch = "
++ show localBranch
let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full localBranchIds localBranch
@ -1067,19 +1073,37 @@ derivedDependencies cid = do
cids <- traverse s2cReferenceId sids
pure $ Set.fromList cids
-- | Given lists of names to add and remove, update the index accordingly.
updateNameIndex ::
-- | Apply a set of name updates to an existing index.
buildNameLookupForBranchHash ::
-- The existing name lookup index to copy before applying the diff.
-- If Nothing, run the diff against an empty index.
-- If Just, the name lookup must exist or an error will be thrown.
Maybe BranchHash ->
BranchHash ->
-- | (add terms, remove terms)
([S.NamedRef (C.Referent, Maybe C.ConstructorType)], [S.NamedRef C.Referent]) ->
-- | (add types, remove types)
([S.NamedRef C.Reference], [S.NamedRef C.Reference]) ->
Transaction ()
updateNameIndex (newTermNames, removedTermNames) (newTypeNames, removedTypeNames) = do
Q.ensureNameLookupTables
Q.removeTermNames ((fmap c2sTextReferent <$> removedTermNames))
Q.removeTypeNames ((fmap c2sTextReference <$> removedTypeNames))
Q.insertTermNames (fmap (c2sTextReferent *** fmap c2sConstructorType) <$> newTermNames)
Q.insertTypeNames (fmap c2sTextReference <$> newTypeNames)
buildNameLookupForBranchHash mayExistingBranchIndex newBranchHash (newTermNames, removedTermNames) (newTypeNames, removedTypeNames) = do
newBranchHashId <- Q.saveBranchHash newBranchHash
Q.trackNewBranchHashNameLookup newBranchHashId
case mayExistingBranchIndex of
Nothing -> pure ()
Just existingBranchIndex -> do
unlessM (checkBranchHashNameLookupExists existingBranchIndex) $ error "buildNameLookupForBranchHash: existingBranchIndex was provided, but no index was found for that branch hash."
existingBranchHashId <- Q.saveBranchHash existingBranchIndex
Q.copyScopedNameLookup existingBranchHashId newBranchHashId
Q.removeScopedTermNames newBranchHashId ((fmap c2sTextReferent <$> removedTermNames))
Q.removeScopedTypeNames newBranchHashId ((fmap c2sTextReference <$> removedTypeNames))
Q.insertScopedTermNames newBranchHashId (fmap (c2sTextReferent *** fmap c2sConstructorType) <$> newTermNames)
Q.insertScopedTypeNames newBranchHashId (fmap c2sTextReference <$> newTypeNames)
-- | Check whether we've already got an index for a given causal hash.
checkBranchHashNameLookupExists :: BranchHash -> Transaction Bool
checkBranchHashNameLookupExists bh = do
bhId <- Q.saveBranchHash bh
Q.checkBranchHashNameLookupExists bhId
data NamesByPath = NamesByPath
{ termNamesInPath :: [S.NamedRef (C.Referent, Maybe C.ConstructorType)],
@ -1087,13 +1111,16 @@ data NamesByPath = NamesByPath
}
-- | Get all the term and type names for the root namespace from the lookup table.
-- Requires that an index for this branch hash already exists, which is currently
-- only true on Share.
rootNamesByPath ::
-- | A relative namespace string, e.g. Just "base.List"
Maybe Text ->
Transaction NamesByPath
rootNamesByPath path = do
termNamesInPath <- Q.rootTermNamesByPath path
typeNamesInPath <- Q.rootTypeNamesByPath path
bhId <- Q.expectNamespaceRootBranchHashId
termNamesInPath <- Q.termNamesWithinNamespace bhId path
typeNamesInPath <- Q.typeNamesWithinNamespace bhId path
pure $
NamesByPath
{ termNamesInPath = convertTerms <$> termNamesInPath,

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/Orphans.hs
View File

@ -12,7 +12,7 @@ import U.Codebase.Sqlite.DbId
import U.Codebase.WatchKind (WatchKind)
import qualified U.Codebase.WatchKind as WatchKind
import U.Util.Base32Hex
import qualified U.Util.Hash as Hash
import qualified Unison.Hash as Hash
import Unison.Prelude
import Unison.Sqlite

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs
View File

@ -59,7 +59,7 @@ applyPatchDiffs =
addRemove add del src =
Map.unionWith (<>) add (Map.differenceWith remove src del)
remove :: Ord b => Set b -> Set b -> Maybe (Set b)
remove :: (Ord b) => Set b -> Set b -> Maybe (Set b)
remove src del =
let diff = Set.difference src del
in if Set.null diff then Nothing else Just diff

263
codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs
View File

@ -62,6 +62,7 @@ module U.Codebase.Sqlite.Queries
loadNamespaceRoot,
setNamespaceRoot,
expectNamespaceRoot,
expectNamespaceRootBranchHashId,
-- * namespace_statistics table
saveNamespaceStats,
@ -115,6 +116,7 @@ module U.Codebase.Sqlite.Queries
countWatches,
getCausalsWithoutBranchObjects,
removeHashObjectsByHashingVersion,
fixScopedNameLookupTables,
-- ** type index
addToTypeIndex,
@ -133,15 +135,16 @@ module U.Codebase.Sqlite.Queries
causalHashIdByBase32Prefix,
-- * Name Lookup
ensureNameLookupTables,
copyScopedNameLookup,
dropNameLookupTables,
insertTermNames,
insertTypeNames,
removeTermNames,
removeTypeNames,
rootTermNamesByPath,
rootTypeNamesByPath,
getNamespaceDefinitionCount,
insertScopedTermNames,
insertScopedTypeNames,
removeScopedTermNames,
removeScopedTypeNames,
termNamesWithinNamespace,
typeNamesWithinNamespace,
checkBranchHashNameLookupExists,
trackNewBranchHashNameLookup,
-- * Reflog
appendReflog,
@ -270,13 +273,13 @@ import qualified U.Codebase.Term as C.Term
import qualified U.Codebase.Type as C.Type
import U.Codebase.WatchKind (WatchKind)
import qualified U.Core.ABT as ABT
import U.Util.Hash (Hash)
import qualified U.Util.Hash as Hash
import U.Util.Hash32 (Hash32)
import qualified U.Util.Hash32 as Hash32
import U.Util.Hash32.Orphans.Sqlite ()
import qualified U.Util.Serialization as S
import qualified U.Util.Term as TermUtil
import Unison.Hash (Hash)
import qualified Unison.Hash as Hash
import Unison.Hash32 (Hash32)
import qualified Unison.Hash32 as Hash32
import Unison.Hash32.Orphans.Sqlite ()
import Unison.Prelude
import Unison.Sqlite
import qualified Unison.Util.Alternative as Alternative
@ -285,7 +288,7 @@ import qualified Unison.Util.Lens as Lens
-- * main squeeze
currentSchemaVersion :: SchemaVersion
currentSchemaVersion = 7
currentSchemaVersion = 9
createSchema :: Transaction ()
createSchema = do
@ -294,6 +297,7 @@ createSchema = do
addTempEntityTables
addNamespaceStatsTables
addReflogTable
fixScopedNameLookupTables
where
insertSchemaVersionSql =
[here|
@ -312,6 +316,10 @@ addReflogTable :: Transaction ()
addReflogTable =
executeFile [hereFile|unison/sql/002-reflog-table.sql|]
fixScopedNameLookupTables :: Transaction ()
fixScopedNameLookupTables =
executeFile [hereFile|unison/sql/004-fix-scoped-name-lookup-tables.sql|]
executeFile :: String -> Transaction ()
executeFile =
traverse_ (execute_ . fromString) . filter (not . null) . List.splitOn ";"
@ -1082,6 +1090,11 @@ loadCausalParentsByHash hash =
|]
(Only hash)
expectNamespaceRootBranchHashId :: Transaction BranchHashId
expectNamespaceRootBranchHashId = do
chId <- expectNamespaceRoot
expectCausalValueHashId chId
expectNamespaceRoot :: Transaction CausalHashId
expectNamespaceRoot =
queryOneCol_ loadNamespaceRootSql
@ -1584,81 +1597,96 @@ dropNameLookupTables = do
DROP TABLE IF EXISTS type_name_lookup
|]
-- | Ensure the name lookup tables exist.
ensureNameLookupTables :: Transaction ()
ensureNameLookupTables = do
execute_
[here|
CREATE TABLE IF NOT EXISTS term_name_lookup (
-- The name of the term: E.g. map.List.base
reversed_name TEXT NOT NULL,
-- The namespace containing this term, not reversed: E.g. base.List
namespace TEXT NOT NULL,
referent_builtin TEXT NULL,
referent_component_hash TEXT NULL,
referent_component_index INTEGER NULL,
referent_constructor_index INTEGER NULL,
referent_constructor_type INTEGER NULL,
PRIMARY KEY (reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index)
)
|]
execute_
[here|
CREATE INDEX IF NOT EXISTS term_names_by_namespace ON term_name_lookup(namespace)
|]
-- Don't need this index at the moment, but will likely be useful later.
-- execute_
-- [here|
-- CREATE INDEX IF NOT EXISTS term_name_by_referent_lookup ON term_name_lookup(referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index)
-- |]
execute_
[here|
CREATE TABLE IF NOT EXISTS type_name_lookup (
-- The name of the term: E.g. List.base
reversed_name TEXT NOT NULL,
-- The namespace containing this term, not reversed: E.g. base.List
namespace TEXT NOT NULL,
reference_builtin TEXT NULL,
reference_component_hash INTEGER NULL,
reference_component_index INTEGER NULL,
PRIMARY KEY (reversed_name, reference_builtin, reference_component_hash, reference_component_index)
);
|]
execute_
[here|
CREATE INDEX IF NOT EXISTS type_names_by_namespace ON type_name_lookup(namespace)
|]
-- | Copies existing name lookup rows but replaces their branch hash id;
-- This is a low-level operation used as part of deriving a new name lookup index
-- from an existing one as performantly as possible.
copyScopedNameLookup :: BranchHashId -> BranchHashId -> Transaction ()
copyScopedNameLookup fromBHId toBHId = do
execute termsCopySql (toBHId, fromBHId)
execute typesCopySql (toBHId, fromBHId)
where
termsCopySql =
[here|
INSERT INTO scoped_term_name_lookup(root_branch_hash_id, reversed_name, last_name_segment, namespace, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type)
SELECT ?, reversed_name, last_name_segment, namespace, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type
FROM scoped_term_name_lookup
WHERE root_branch_hash_id = ?
|]
typesCopySql =
[here|
INSERT INTO scoped_type_name_lookup(root_branch_hash_id, reversed_name, last_name_segment, namespace, reference_builtin, reference_component_hash, reference_component_index)
SELECT ?, reversed_name, last_name_segment, namespace, reference_builtin, reference_component_hash, reference_component_index
FROM scoped_type_name_lookup
WHERE root_branch_hash_id = ?
|]
-- Don't need this index at the moment, but will likely be useful later.
-- execute_
-- [here|
-- CREATE INDEX IF NOT EXISTS type_name_by_reference_lookup ON type_name_lookup(reference_builtin, reference_object_id, reference_component_index);
-- |]
-- | Inserts a new record into the name_lookups table
trackNewBranchHashNameLookup :: BranchHashId -> Transaction ()
trackNewBranchHashNameLookup bhId = do
execute sql (Only bhId)
where
sql =
[here|
INSERT INTO name_lookups (root_branch_hash_id)
VALUES (?)
|]
-- | Check if we've already got an index for the desired root branch hash.
checkBranchHashNameLookupExists :: BranchHashId -> Transaction Bool
checkBranchHashNameLookupExists hashId = do
queryOneCol sql (Only hashId)
where
sql =
[here|
SELECT EXISTS (
SELECT 1
FROM name_lookups
WHERE root_branch_hash_id = ?
LIMIT 1
)
|]
-- | Insert the given set of term names into the name lookup table
insertTermNames :: [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)] -> Transaction ()
insertTermNames names = do
executeMany sql (NamedRef.toRowWithNamespace . fmap refToRow <$> names)
insertScopedTermNames :: BranchHashId -> [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)] -> Transaction ()
insertScopedTermNames bhId names = do
executeMany sql (namedRefToRow <$> names)
where
namedRefToRow :: NamedRef (S.Referent.TextReferent, Maybe NamedRef.ConstructorType) -> (Only BranchHashId :. [SQLData])
namedRefToRow namedRef =
namedRef
& fmap refToRow
& NamedRef.namedRefToScopedRow
& \nr -> (Only bhId :. nr)
refToRow :: (Referent.TextReferent, Maybe NamedRef.ConstructorType) -> (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))
refToRow (ref, ct) = ref :. Only ct
sql =
[here|
INSERT INTO term_name_lookup (reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type, namespace)
VALUES (?, ?, ?, ?, ?, ?, ?)
ON CONFLICT DO NOTHING
INSERT INTO scoped_term_name_lookup (root_branch_hash_id, reversed_name, namespace, last_name_segment, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type)
VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)
|]
-- | Remove the given set of term names into the name lookup table
removeTermNames :: [NamedRef Referent.TextReferent] -> Transaction ()
removeTermNames names = do
executeMany sql names
-- | Insert the given set of type names into the name lookup table
insertScopedTypeNames :: BranchHashId -> [NamedRef (Reference.TextReference)] -> Transaction ()
insertScopedTypeNames bhId names =
executeMany sql ((Only bhId :.) . NamedRef.namedRefToScopedRow <$> names)
where
sql =
[here|
DELETE FROM term_name_lookup
INSERT INTO scoped_type_name_lookup (root_branch_hash_id, reversed_name, namespace, last_name_segment, reference_builtin, reference_component_hash, reference_component_index)
VALUES (?, ?, ?, ?, ?, ?, ?)
|]
-- | Remove the given set of term names into the name lookup table
removeScopedTermNames :: BranchHashId -> [NamedRef Referent.TextReferent] -> Transaction ()
removeScopedTermNames bhId names = do
executeMany sql ((Only bhId :.) <$> names)
where
sql =
[here|
DELETE FROM scoped_term_name_lookup
WHERE
reversed_name IS ?
root_branch_hash_id IS ?
AND reversed_name IS ?
AND referent_builtin IS ?
AND referent_component_hash IS ?
AND referent_component_index IS ?
@ -1666,15 +1694,16 @@ removeTermNames names = do
|]
-- | Remove the given set of term names into the name lookup table
removeTypeNames :: [NamedRef (Reference.TextReference)] -> Transaction ()
removeTypeNames names = do
executeMany sql names
removeScopedTypeNames :: BranchHashId -> [NamedRef (Reference.TextReference)] -> Transaction ()
removeScopedTypeNames bhId names = do
executeMany sql ((Only bhId :.) <$> names)
where
sql =
[here|
DELETE FROM type_name_lookup
DELETE FROM scoped_type_name_lookup
WHERE
reversed_name IS ?
root_branch_hash_id IS ?
AND reversed_name IS ?
AND reference_builtin IS ?
AND reference_component_hash IS ?
AND reference_component_index IS ?
@ -1721,66 +1750,40 @@ likeEscape escapeChar pat =
| c == escapeChar -> Text.pack [escapeChar, escapeChar]
| otherwise -> Text.singleton c
-- | Gets the count of all definitions within the given namespace.
-- NOTE: This requires a working name lookup index.
getNamespaceDefinitionCount :: Text -> Transaction Int
getNamespaceDefinitionCount namespace = do
let subnamespace = globEscape namespace <> ".*"
queryOneCol sql (subnamespace, namespace, subnamespace, namespace)
where
sql =
[here|
SELECT COUNT(*) FROM (
SELECT 1 FROM term_name_lookup WHERE namespace GLOB ? OR namespace = ?
UNION ALL
SELECT 1 FROM type_name_lookup WHERE namespace GLOB ? OR namespace = ?
)
|]
-- | Insert the given set of type names into the name lookup table
insertTypeNames :: [NamedRef (Reference.TextReference)] -> Transaction ()
insertTypeNames names =
executeMany sql (NamedRef.toRowWithNamespace <$> names)
where
sql =
[here|
INSERT INTO type_name_lookup (reversed_name, reference_builtin, reference_component_hash, reference_component_index, namespace)
VALUES (?, ?, ?, ?, ?)
ON CONFLICT DO NOTHING
|]
-- | Get the list of a term names in the root namespace according to the name lookup index
rootTermNamesByPath :: Maybe Text -> Transaction [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)]
rootTermNamesByPath mayNamespace = do
let (namespace, subnamespace) = case mayNamespace of
Nothing -> ("", "*")
Just namespace -> (namespace, globEscape namespace <> ".*")
results :: [NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- queryListRow sql (subnamespace, namespace, subnamespace, namespace)
termNamesWithinNamespace :: BranchHashId -> Maybe Text -> Transaction [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)]
termNamesWithinNamespace bhId mayNamespace = do
let namespaceGlob = case mayNamespace of
Nothing -> "*"
Just namespace -> globEscape namespace <> ".*"
results :: [NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- queryListRow sql (bhId, namespaceGlob)
pure (fmap unRow <$> results)
where
unRow (a :. Only b) = (a, b)
sql =
[here|
SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type FROM term_name_lookup
WHERE (namespace GLOB ? OR namespace = ?)
ORDER BY (namespace GLOB ? OR namespace = ?) DESC
SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type FROM scoped_term_name_lookup
WHERE
root_branch_hash_id = ?
AND namespace GLOB ?
|]
-- | Get the list of a type names in the root namespace according to the name lookup index
rootTypeNamesByPath :: Maybe Text -> Transaction [NamedRef Reference.TextReference]
rootTypeNamesByPath mayNamespace = do
let (namespace, subnamespace) = case mayNamespace of
Nothing -> ("", "*")
Just namespace -> (namespace, globEscape namespace <> ".*")
results :: [NamedRef Reference.TextReference] <- queryListRow sql (subnamespace, namespace, subnamespace, namespace)
typeNamesWithinNamespace :: BranchHashId -> Maybe Text -> Transaction [NamedRef Reference.TextReference]
typeNamesWithinNamespace bhId mayNamespace = do
let namespaceGlob = case mayNamespace of
Nothing -> "*"
Just namespace -> globEscape namespace <> ".*"
results :: [NamedRef Reference.TextReference] <- queryListRow sql (bhId, namespaceGlob)
pure results
where
sql =
[here|
SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index FROM type_name_lookup
WHERE namespace GLOB ? OR namespace = ?
ORDER BY (namespace GLOB ? OR namespace = ?) DESC
|]
SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index FROM scoped_type_name_lookup
WHERE
root_branch_hash_id = ?
AND namespace GLOB ?
|]
-- | @before x y@ returns whether or not @x@ occurred before @y@, i.e. @x@ is an ancestor of @y@.
before :: CausalHashId -> CausalHashId -> Transaction Bool
@ -2130,7 +2133,7 @@ saveDeclComponent hh@HashHandle {toReferenceDecl, toReferenceDeclMentions} maybe
pure oId
-- | implementation detail of {s,w}2c*Term* & s2cDecl
localIdsToLookups :: Monad m => (t -> m Text) -> (d -> m Hash) -> LocalIds' t d -> m (LocalTextId -> Text, LocalDefnId -> Hash)
localIdsToLookups :: (Monad m) => (t -> m Text) -> (d -> m Hash) -> LocalIds' t d -> m (LocalTextId -> Text, LocalDefnId -> Hash)
localIdsToLookups loadText loadHash localIds = do
texts <- traverse loadText $ LocalIds.textLookup localIds
hashes <- traverse loadHash $ LocalIds.defnLookup localIds
@ -2174,7 +2177,7 @@ localIdsToTypeRefLookup localIds = do
c2sDecl ::
forall m t d.
Monad m =>
(Monad m) =>
(Text -> m t) ->
(Hash -> m d) ->
C.Decl Symbol ->
@ -2210,7 +2213,7 @@ c2sDecl saveText saveDefn (C.Decl.DataDeclaration dt m b cts) = do
-- | implementation detail of c2{s,w}Term
-- The Type is optional, because we don't store them for watch expression results.
c2xTerm :: forall m t d. Monad m => (Text -> m t) -> (Hash -> m d) -> C.Term Symbol -> Maybe (C.Term.Type Symbol) -> m (LocalIds' t d, S.Term.Term, Maybe (S.Term.Type))
c2xTerm :: forall m t d. (Monad m) => (Text -> m t) -> (Hash -> m d) -> C.Term Symbol -> Maybe (C.Term.Type Symbol) -> m (LocalIds' t d, S.Term.Term, Maybe (S.Term.Type))
c2xTerm saveText saveDefn tm tp =
done =<< (runWriterT . flip evalStateT mempty) do
sterm <- ABT.transformM go tm

4
codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs
View File

@ -65,9 +65,9 @@ referenceFromRow' = liftA3 mkRef field field field
where
str = "(" ++ show t ++ ", " ++ show h ++ ", " ++ show i ++ ")"
instance ToField h => ToRow (Id' h) where
instance (ToField h) => ToRow (Id' h) where
toRow = \case
Id h i -> toRow (Only h) ++ toRow (Only i)
instance FromField h => FromRow (Id' h) where
instance (FromField h) => FromRow (Id' h) where
fromRow = Id <$> field <*> field

202
codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs
View File

@ -1,10 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module U.Codebase.Sqlite.Serialization where
@ -44,9 +38,9 @@ import qualified U.Codebase.Term as Term
import qualified U.Codebase.Type as Type
import qualified U.Core.ABT as ABT
import qualified U.Util.Base32Hex as Base32Hex
import U.Util.Hash32 (Hash32)
import qualified U.Util.Hash32 as Hash32
import U.Util.Serialization hiding (debug)
import Unison.Hash32 (Hash32)
import qualified Unison.Hash32 as Hash32
import Unison.Prelude
import qualified Unison.Util.Monoid as Monoid
import Prelude hiding (getChar, putChar)
@ -121,47 +115,47 @@ putLocalIdsWith putText putDefn LocalIds {textLookup, defnLookup} = do
putFoldable putText textLookup
putFoldable putDefn defnLookup
getLocalIds :: MonadGet m => m LocalIds
getLocalIds :: (MonadGet m) => m LocalIds
getLocalIds = getLocalIdsWith getVarInt getVarInt
getWatchLocalIds :: MonadGet m => m WatchLocalIds
getWatchLocalIds :: (MonadGet m) => m WatchLocalIds
getWatchLocalIds = getLocalIdsWith getVarInt getVarInt
getLocalIdsWith :: MonadGet m => m t -> m d -> m (LocalIds' t d)
getLocalIdsWith :: (MonadGet m) => m t -> m d -> m (LocalIds' t d)
getLocalIdsWith getText getDefn =
LocalIds <$> getVector getText <*> getVector getDefn
putUnit :: Applicative m => () -> m ()
putUnit :: (Applicative m) => () -> m ()
putUnit _ = pure ()
getUnit :: Applicative m => m ()
getUnit :: (Applicative m) => m ()
getUnit = pure ()
putWatchResultFormat :: MonadPut m => TermFormat.WatchResultFormat -> m ()
putWatchResultFormat :: (MonadPut m) => TermFormat.WatchResultFormat -> m ()
putWatchResultFormat = \case
TermFormat.WatchResult ids t -> do
putWord8 0
putLocalIds ids
putTerm t
getWatchResultFormat :: MonadGet m => m TermFormat.WatchResultFormat
getWatchResultFormat :: (MonadGet m) => m TermFormat.WatchResultFormat
getWatchResultFormat =
getWord8 >>= \case
0 -> TermFormat.WatchResult <$> getWatchLocalIds <*> getTerm
other -> unknownTag "getWatchResultFormat" other
putTermFormat :: MonadPut m => TermFormat.TermFormat -> m ()
putTermFormat :: (MonadPut m) => TermFormat.TermFormat -> m ()
putTermFormat = \case
TermFormat.Term c -> putWord8 0 *> putTermComponent c
getTermFormat :: MonadGet m => m TermFormat.TermFormat
getTermFormat :: (MonadGet m) => m TermFormat.TermFormat
getTermFormat =
getWord8 >>= \case
0 -> TermFormat.Term <$> getTermComponent
other -> unknownTag "getTermFormat" other
putTermComponent ::
MonadPut m =>
(MonadPut m) =>
TermFormat.LocallyIndexedComponent ->
m ()
putTermComponent t | debug && trace ("putTermComponent " ++ show t) False = undefined
@ -172,11 +166,11 @@ putTermComponent (TermFormat.LocallyIndexedComponent v) =
)
v
putTerm :: MonadPut m => TermFormat.Term -> m ()
putTerm :: (MonadPut m) => TermFormat.Term -> m ()
putTerm _t | debug && trace "putTerm" False = undefined
putTerm t = putABT putSymbol putUnit putF t
where
putF :: MonadPut m => (a -> m ()) -> TermFormat.F a -> m ()
putF :: (MonadPut m) => (a -> m ()) -> TermFormat.F a -> m ()
putF putChild = \case
Term.Int n ->
putWord8 0 *> putInt n
@ -222,10 +216,10 @@ putTerm t = putABT putSymbol putUnit putF t
putWord8 20 *> putReferent' putRecursiveReference putReference r
Term.TypeLink r ->
putWord8 21 *> putReference r
putMatchCase :: MonadPut m => (a -> m ()) -> Term.MatchCase LocalTextId TermFormat.TypeRef a -> m ()
putMatchCase :: (MonadPut m) => (a -> m ()) -> Term.MatchCase LocalTextId TermFormat.TypeRef a -> m ()
putMatchCase putChild (Term.MatchCase pat guard body) =
putPattern pat *> putMaybe putChild guard *> putChild body
putPattern :: MonadPut m => Term.Pattern LocalTextId TermFormat.TypeRef -> m ()
putPattern :: (MonadPut m) => Term.Pattern LocalTextId TermFormat.TypeRef -> m ()
putPattern p = case p of
Term.PUnbound -> putWord8 0
Term.PVar -> putWord8 1
@ -255,23 +249,23 @@ putTerm t = putABT putSymbol putUnit putF t
*> putPattern r
Term.PText t -> putWord8 12 *> putVarInt t
Term.PChar c -> putWord8 13 *> putChar c
putSeqOp :: MonadPut m => Term.SeqOp -> m ()
putSeqOp :: (MonadPut m) => Term.SeqOp -> m ()
putSeqOp Term.PCons = putWord8 0
putSeqOp Term.PSnoc = putWord8 1
putSeqOp Term.PConcat = putWord8 2
getTermComponent :: MonadGet m => m TermFormat.LocallyIndexedComponent
getTermComponent :: (MonadGet m) => m TermFormat.LocallyIndexedComponent
getTermComponent =
TermFormat.LocallyIndexedComponent
<$> getFramedArray (getTuple3 getLocalIds (getFramed getTerm) getTType)
getTermAndType :: MonadGet m => m (TermFormat.Term, TermFormat.Type)
getTermAndType :: (MonadGet m) => m (TermFormat.Term, TermFormat.Type)
getTermAndType = (,) <$> getFramed getTerm <*> getTType
getTerm :: MonadGet m => m TermFormat.Term
getTerm :: (MonadGet m) => m TermFormat.Term
getTerm = getABT getSymbol getUnit getF
where
getF :: MonadGet m => m a -> m (TermFormat.F a)
getF :: (MonadGet m) => m a -> m (TermFormat.F a)
getF getChild =
getWord8 >>= \case
0 -> Term.Int <$> getInt
@ -302,13 +296,13 @@ getTerm = getABT getSymbol getUnit getF
21 -> Term.TypeLink <$> getReference
tag -> unknownTag "getTerm" tag
where
getReferent :: MonadGet m => m (Referent' TermFormat.TermRef TermFormat.TypeRef)
getReferent :: (MonadGet m) => m (Referent' TermFormat.TermRef TermFormat.TypeRef)
getReferent =
getWord8 >>= \case
0 -> Referent.Ref <$> getRecursiveReference
1 -> Referent.Con <$> getReference <*> getVarInt
x -> unknownTag "getTermComponent" x
getPattern :: MonadGet m => m (Term.Pattern LocalTextId TermFormat.TypeRef)
getPattern :: (MonadGet m) => m (Term.Pattern LocalTextId TermFormat.TypeRef)
getPattern =
getWord8 >>= \case
0 -> pure Term.PUnbound
@ -336,7 +330,7 @@ getTerm = getABT getSymbol getUnit getF
13 -> Term.PChar <$> getChar
x -> unknownTag "Pattern" x
where
getSeqOp :: MonadGet m => m Term.SeqOp
getSeqOp :: (MonadGet m) => m Term.SeqOp
getSeqOp =
getWord8 >>= \case
0 -> pure Term.PCons
@ -344,28 +338,28 @@ getTerm = getABT getSymbol getUnit getF
2 -> pure Term.PConcat
tag -> unknownTag "SeqOp" tag
lookupTermElement :: MonadGet m => Reference.Pos -> m (LocalIds, TermFormat.Term, TermFormat.Type)
lookupTermElement :: (MonadGet m) => Reference.Pos -> m (LocalIds, TermFormat.Term, TermFormat.Type)
lookupTermElement i =
getWord8 >>= \case
0 -> unsafeFramedArrayLookup (getTuple3 getLocalIds (getFramed getTerm) getTType) $ fromIntegral i
tag -> unknownTag "lookupTermElement" tag
lookupTermElementDiscardingType :: MonadGet m => Reference.Pos -> m (LocalIds, TermFormat.Term)
lookupTermElementDiscardingType :: (MonadGet m) => Reference.Pos -> m (LocalIds, TermFormat.Term)
lookupTermElementDiscardingType i =
getWord8 >>= \case
0 -> unsafeFramedArrayLookup ((,) <$> getLocalIds <*> getFramed getTerm) $ fromIntegral i
tag -> unknownTag "lookupTermElementDiscardingType" tag
lookupTermElementDiscardingTerm :: MonadGet m => Reference.Pos -> m (LocalIds, TermFormat.Type)
lookupTermElementDiscardingTerm :: (MonadGet m) => Reference.Pos -> m (LocalIds, TermFormat.Type)
lookupTermElementDiscardingTerm i =
getWord8 >>= \case
0 -> unsafeFramedArrayLookup ((,) <$> getLocalIds <* skipFramed <*> getTType) $ fromIntegral i
tag -> unknownTag "lookupTermElementDiscardingTerm" tag
getTType :: MonadGet m => m TermFormat.Type
getTType :: (MonadGet m) => m TermFormat.Type
getTType = getType getReference
getType :: forall m r. MonadGet m => m r -> m (Type.TypeR r Symbol)
getType :: forall m r. (MonadGet m) => m r -> m (Type.TypeR r Symbol)
getType getReference = getABT getSymbol getUnit go
where
go :: m x -> m (Type.F' r x)
@ -380,19 +374,19 @@ getType getReference = getABT getSymbol getUnit go
6 -> Type.Forall <$> getChild
7 -> Type.IntroOuter <$> getChild
tag -> unknownTag "getType" tag
getKind :: MonadGet m => m Kind
getKind :: (MonadGet m) => m Kind
getKind =
getWord8 >>= \case
0 -> pure Kind.Star
1 -> Kind.Arrow <$> getKind <*> getKind
tag -> unknownTag "getKind" tag
putDeclFormat :: MonadPut m => DeclFormat.DeclFormat -> m ()
putDeclFormat :: (MonadPut m) => DeclFormat.DeclFormat -> m ()
putDeclFormat = \case
DeclFormat.Decl c -> putWord8 0 *> putDeclComponent c
where
-- These use a framed array for randomer access
putDeclComponent :: MonadPut m => DeclFormat.LocallyIndexedComponent -> m ()
putDeclComponent :: (MonadPut m) => DeclFormat.LocallyIndexedComponent -> m ()
putDeclComponent t | debug && trace ("putDeclComponent " ++ show t) False = undefined
putDeclComponent (DeclFormat.LocallyIndexedComponent v) =
putFramedArray (putPair putLocalIds putDeclElement) v
@ -407,18 +401,18 @@ putDeclFormat = \case
putModifier Decl.Structural = putWord8 0
putModifier (Decl.Unique t) = putWord8 1 *> putText t
getDeclFormat :: MonadGet m => m DeclFormat.DeclFormat
getDeclFormat :: (MonadGet m) => m DeclFormat.DeclFormat
getDeclFormat =
getWord8 >>= \case
0 -> DeclFormat.Decl <$> getDeclComponent
other -> unknownTag "DeclFormat" other
where
getDeclComponent :: MonadGet m => m DeclFormat.LocallyIndexedComponent
getDeclComponent :: (MonadGet m) => m DeclFormat.LocallyIndexedComponent
getDeclComponent =
DeclFormat.LocallyIndexedComponent
<$> getFramedArray (getPair getLocalIds getDeclElement)
getDeclElement :: MonadGet m => m (DeclFormat.Decl Symbol)
getDeclElement :: (MonadGet m) => m (DeclFormat.Decl Symbol)
getDeclElement =
Decl.DataDeclaration
<$> getDeclType
@ -438,13 +432,13 @@ getDeclElement =
other -> unknownTag "DeclModifier" other
lookupDeclElement ::
MonadGet m => Reference.Pos -> m (LocalIds, DeclFormat.Decl Symbol)
(MonadGet m) => Reference.Pos -> m (LocalIds, DeclFormat.Decl Symbol)
lookupDeclElement i =
getWord8 >>= \case
0 -> unsafeFramedArrayLookup (getPair getLocalIds getDeclElement) $ fromIntegral i
other -> unknownTag "lookupDeclElement" other
putBranchFormat :: MonadPut m => BranchFormat.BranchFormat -> m ()
putBranchFormat :: (MonadPut m) => BranchFormat.BranchFormat -> m ()
putBranchFormat b | debug && trace ("putBranchFormat " ++ show b) False = undefined
putBranchFormat b = case b of
BranchFormat.Full li b -> do
@ -486,14 +480,14 @@ putBranchFormat b = case b of
BranchDiff.ChildRemove -> putWord8 0
BranchDiff.ChildAddReplace b -> putWord8 1 *> putVarInt b
putBranchLocalIds :: MonadPut m => BranchFormat.BranchLocalIds -> m ()
putBranchLocalIds :: (MonadPut m) => BranchFormat.BranchLocalIds -> m ()
putBranchLocalIds (BranchFormat.LocalIds ts os ps cs) = do
putFoldable putVarInt ts
putFoldable putVarInt os
putFoldable putVarInt ps
putFoldable (putPair putVarInt putVarInt) cs
putPatchFormat :: MonadPut m => PatchFormat.PatchFormat -> m ()
putPatchFormat :: (MonadPut m) => PatchFormat.PatchFormat -> m ()
putPatchFormat = \case
PatchFormat.Full ids p -> do
putWord8 0
@ -505,71 +499,71 @@ putPatchFormat = \case
putPatchLocalIds ids
putPatchDiff p
getPatchFormat :: MonadGet m => m PatchFormat.PatchFormat
getPatchFormat :: (MonadGet m) => m PatchFormat.PatchFormat
getPatchFormat =
getWord8 >>= \case
0 -> PatchFormat.Full <$> getPatchLocalIds <*> getPatchFull
1 -> PatchFormat.Diff <$> getVarInt <*> getPatchLocalIds <*> getPatchDiff
x -> unknownTag "getPatchFormat" x
where
getPatchFull :: MonadGet m => m PatchFull.LocalPatch
getPatchFull :: (MonadGet m) => m PatchFull.LocalPatch
getPatchFull =
PatchFull.Patch
<$> getMap getReferent (getSet getTermEdit)
<*> getMap getReference (getSet getTypeEdit)
getPatchDiff :: MonadGet m => m PatchDiff.LocalPatchDiff
getPatchDiff :: (MonadGet m) => m PatchDiff.LocalPatchDiff
getPatchDiff =
PatchDiff.PatchDiff
<$> getMap getReferent (getSet getTermEdit)
<*> getMap getReference (getSet getTypeEdit)
<*> getMap getReferent (getSet getTermEdit)
<*> getMap getReference (getSet getTypeEdit)
getTermEdit :: MonadGet m => m TermEdit.LocalTermEdit
getTermEdit :: (MonadGet m) => m TermEdit.LocalTermEdit
getTermEdit =
getWord8 >>= \case
0 -> pure TermEdit.Deprecate
1 -> TermEdit.Replace <$> getReferent <*> getTyping
x -> unknownTag "getTermEdit" x
getTyping :: MonadGet m => m TermEdit.Typing
getTyping :: (MonadGet m) => m TermEdit.Typing
getTyping =
getWord8 >>= \case
0 -> pure TermEdit.Same
1 -> pure TermEdit.Subtype
2 -> pure TermEdit.Different
x -> unknownTag "getTyping" x
getTypeEdit :: MonadGet m => m TypeEdit.LocalTypeEdit
getTypeEdit :: (MonadGet m) => m TypeEdit.LocalTypeEdit
getTypeEdit =
getWord8 >>= \case
0 -> pure TypeEdit.Deprecate
1 -> TypeEdit.Replace <$> getReference
x -> unknownTag "getTypeEdit" x
getPatchLocalIds :: MonadGet m => m PatchFormat.PatchLocalIds
getPatchLocalIds :: (MonadGet m) => m PatchFormat.PatchLocalIds
getPatchLocalIds =
PatchFormat.LocalIds
<$> getVector getVarInt
<*> getVector getVarInt
<*> getVector getVarInt
putPatchFull :: MonadPut m => PatchFull.LocalPatch -> m ()
putPatchFull :: (MonadPut m) => PatchFull.LocalPatch -> m ()
putPatchFull (PatchFull.Patch termEdits typeEdits) = do
putMap putReferent (putFoldable putTermEdit) termEdits
putMap putReference (putFoldable putTypeEdit) typeEdits
putPatchDiff :: MonadPut m => PatchDiff.LocalPatchDiff -> m ()
putPatchDiff :: (MonadPut m) => PatchDiff.LocalPatchDiff -> m ()
putPatchDiff (PatchDiff.PatchDiff atm atp rtm rtp) = do
putMap putReferent (putFoldable putTermEdit) atm
putMap putReference (putFoldable putTypeEdit) atp
putMap putReferent (putFoldable putTermEdit) rtm
putMap putReference (putFoldable putTypeEdit) rtp
putPatchLocalIds :: MonadPut m => PatchFormat.PatchLocalIds -> m ()
putPatchLocalIds :: (MonadPut m) => PatchFormat.PatchLocalIds -> m ()
putPatchLocalIds (PatchFormat.LocalIds ts hs os) = do
putFoldable putVarInt ts
putFoldable putVarInt hs
putFoldable putVarInt os
putTermEdit :: MonadPut m => TermEdit.LocalTermEdit -> m ()
putTermEdit :: (MonadPut m) => TermEdit.LocalTermEdit -> m ()
putTermEdit TermEdit.Deprecate = putWord8 0
putTermEdit (TermEdit.Replace r t) = putWord8 1 *> putReferent r *> putTyping t
where
@ -577,29 +571,29 @@ putTermEdit (TermEdit.Replace r t) = putWord8 1 *> putReferent r *> putTyping t
putTyping TermEdit.Subtype = putWord8 1
putTyping TermEdit.Different = putWord8 2
putTypeEdit :: MonadPut m => TypeEdit.LocalTypeEdit -> m ()
putTypeEdit :: (MonadPut m) => TypeEdit.LocalTypeEdit -> m ()
putTypeEdit TypeEdit.Deprecate = putWord8 0
putTypeEdit (TypeEdit.Replace r) = putWord8 1 *> putReference r
getBranchFormat :: MonadGet m => m BranchFormat.BranchFormat
getBranchFormat :: (MonadGet m) => m BranchFormat.BranchFormat
getBranchFormat =
getWord8 >>= \case
0 -> getBranchFull
1 -> getBranchDiff
x -> unknownTag "getBranchFormat" x
where
getBranchFull :: MonadGet m => m BranchFormat.BranchFormat
getBranchFull :: (MonadGet m) => m BranchFormat.BranchFormat
getBranchFull =
BranchFormat.Full <$> getBranchLocalIds <*> getLocalBranch
where
getLocalBranch :: MonadGet m => m BranchFull.LocalBranch
getLocalBranch :: (MonadGet m) => m BranchFull.LocalBranch
getLocalBranch =
BranchFull.Branch
<$> getMap getVarInt (getMap getReferent getMetadataSetFormat)
<*> getMap getVarInt (getMap getReference getMetadataSetFormat)
<*> getMap getVarInt getVarInt
<*> getMap getVarInt getVarInt
getMetadataSetFormat :: MonadGet m => m BranchFull.LocalMetadataSet
getMetadataSetFormat :: (MonadGet m) => m BranchFull.LocalMetadataSet
getMetadataSetFormat =
getWord8 >>= \case
0 -> BranchFull.Inline <$> getSet getReference
@ -610,14 +604,14 @@ getBranchFormat =
<*> getBranchLocalIds
<*> getLocalBranchDiff
where
getLocalBranchDiff :: MonadGet m => m BranchDiff.LocalDiff
getLocalBranchDiff :: (MonadGet m) => m BranchDiff.LocalDiff
getLocalBranchDiff =
BranchDiff.Diff
<$> getMap getVarInt (getMap getReferent getDiffOp)
<*> getMap getVarInt (getMap getReference getDiffOp)
<*> getMap getVarInt getPatchOp
<*> getMap getVarInt getChildOp
getDiffOp :: MonadGet m => m BranchDiff.LocalDefinitionOp
getDiffOp :: (MonadGet m) => m BranchDiff.LocalDefinitionOp
getDiffOp =
getWord8 >>= \case
0 -> pure BranchDiff.RemoveDef
@ -628,20 +622,20 @@ getBranchFormat =
adds <- getMap get (pure True)
-- and removes:
addToExistingMap get (pure False) adds
getPatchOp :: MonadGet m => m BranchDiff.LocalPatchOp
getPatchOp :: (MonadGet m) => m BranchDiff.LocalPatchOp
getPatchOp =
getWord8 >>= \case
0 -> pure BranchDiff.PatchRemove
1 -> BranchDiff.PatchAddReplace <$> getVarInt
x -> unknownTag "getPatchOp" x
getChildOp :: MonadGet m => m BranchDiff.LocalChildOp
getChildOp :: (MonadGet m) => m BranchDiff.LocalChildOp
getChildOp =
getWord8 >>= \case
0 -> pure BranchDiff.ChildRemove
1 -> BranchDiff.ChildAddReplace <$> getVarInt
x -> unknownTag "getChildOp" x
getBranchLocalIds :: MonadGet m => m BranchFormat.BranchLocalIds
getBranchLocalIds :: (MonadGet m) => m BranchFormat.BranchLocalIds
getBranchLocalIds =
BranchFormat.LocalIds
<$> getVector getVarInt
@ -649,7 +643,7 @@ getBranchLocalIds =
<*> getVector getVarInt
<*> getVector (getPair getVarInt getVarInt)
decomposeTermFormat :: MonadGet m => m TermFormat.SyncTermFormat
decomposeTermFormat :: (MonadGet m) => m TermFormat.SyncTermFormat
decomposeTermFormat =
getWord8 >>= \case
0 ->
@ -658,7 +652,7 @@ decomposeTermFormat =
<$> decomposeComponent
tag -> error $ "todo: unknown term format tag " ++ show tag
decomposeDeclFormat :: MonadGet m => m DeclFormat.SyncDeclFormat
decomposeDeclFormat :: (MonadGet m) => m DeclFormat.SyncDeclFormat
decomposeDeclFormat =
getWord8 >>= \case
0 ->
@ -667,7 +661,7 @@ decomposeDeclFormat =
<$> decomposeComponent
tag -> error $ "todo: unknown term format tag " ++ show tag
decomposeComponent :: MonadGet m => m (Vector (LocalIds, BS.ByteString))
decomposeComponent :: (MonadGet m) => m (Vector (LocalIds, BS.ByteString))
decomposeComponent = do
offsets <- getList (getVarInt @_ @Int)
componentBytes <- getByteString (last offsets)
@ -677,60 +671,60 @@ decomposeComponent = do
split = (,) <$> getLocalIds <*> getRemainingByteString
Monoid.foldMapM get1 (zip offsets (tail offsets))
recomposeTermFormat :: MonadPut m => TermFormat.SyncTermFormat -> m ()
recomposeTermFormat :: (MonadPut m) => TermFormat.SyncTermFormat -> m ()
recomposeTermFormat = \case
TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent x) ->
putWord8 0 >> recomposeComponent x
recomposeDeclFormat :: MonadPut m => DeclFormat.SyncDeclFormat -> m ()
recomposeDeclFormat :: (MonadPut m) => DeclFormat.SyncDeclFormat -> m ()
recomposeDeclFormat = \case
DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent x) ->
putWord8 0 >> recomposeComponent x
recomposeComponent :: MonadPut m => Vector (LocalIds, BS.ByteString) -> m ()
recomposeComponent :: (MonadPut m) => Vector (LocalIds, BS.ByteString) -> m ()
recomposeComponent = putFramedArray \(localIds, bytes) -> do
putLocalIds localIds
putByteString bytes
decomposeWatchFormat :: MonadGet m => m TermFormat.SyncWatchResultFormat
decomposeWatchFormat :: (MonadGet m) => m TermFormat.SyncWatchResultFormat
decomposeWatchFormat =
getWord8 >>= \case
0 -> TermFormat.SyncWatchResult <$> getWatchLocalIds <*> getRemainingByteString
x -> unknownTag "decomposeWatchFormat" x
recomposeWatchFormat :: MonadPut m => TermFormat.SyncWatchResultFormat -> m ()
recomposeWatchFormat :: (MonadPut m) => TermFormat.SyncWatchResultFormat -> m ()
recomposeWatchFormat (TermFormat.SyncWatchResult wli bs) =
putWord8 0 *> putLocalIds wli *> putByteString bs
decomposePatchFormat :: MonadGet m => m PatchFormat.SyncPatchFormat
decomposePatchFormat :: (MonadGet m) => m PatchFormat.SyncPatchFormat
decomposePatchFormat =
getWord8 >>= \case
0 -> PatchFormat.SyncFull <$> getPatchLocalIds <*> getRemainingByteString
1 -> PatchFormat.SyncDiff <$> getVarInt <*> getPatchLocalIds <*> getRemainingByteString
x -> unknownTag "decomposePatchFormat" x
recomposePatchFormat :: MonadPut m => PatchFormat.SyncPatchFormat -> m ()
recomposePatchFormat :: (MonadPut m) => PatchFormat.SyncPatchFormat -> m ()
recomposePatchFormat = \case
PatchFormat.SyncFull li bs ->
putWord8 0 *> putPatchLocalIds li *> putByteString bs
PatchFormat.SyncDiff id li bs ->
putWord8 1 *> putVarInt id *> putPatchLocalIds li *> putByteString bs
decomposeBranchFormat :: MonadGet m => m BranchFormat.SyncBranchFormat
decomposeBranchFormat :: (MonadGet m) => m BranchFormat.SyncBranchFormat
decomposeBranchFormat =
getWord8 >>= \case
0 -> BranchFormat.SyncFull <$> getBranchLocalIds <*> getRemainingByteString
1 -> BranchFormat.SyncDiff <$> getVarInt <*> getBranchLocalIds <*> getRemainingByteString
x -> unknownTag "decomposeBranchFormat" x
recomposeBranchFormat :: MonadPut m => BranchFormat.SyncBranchFormat -> m ()
recomposeBranchFormat :: (MonadPut m) => BranchFormat.SyncBranchFormat -> m ()
recomposeBranchFormat = \case
BranchFormat.SyncFull li bs ->
putWord8 0 *> putBranchLocalIds li *> putByteString bs
BranchFormat.SyncDiff id li bs ->
putWord8 1 *> putVarInt id *> putBranchLocalIds li *> putByteString bs
putTempEntity :: MonadPut m => TempEntity -> m ()
putTempEntity :: (MonadPut m) => TempEntity -> m ()
putTempEntity = \case
Entity.TC tc -> case tc of
TermFormat.SyncTerm term ->
@ -790,10 +784,10 @@ putTempEntity = \case
putLocalIdsWith putText putHash32 localIds
putFramedByteString bytes
getHash32 :: MonadGet m => m Hash32
getHash32 :: (MonadGet m) => m Hash32
getHash32 = Hash32.UnsafeFromBase32Hex . Base32Hex.UnsafeFromText <$> getText
getTempTermFormat :: MonadGet m => m TempEntity.TempTermFormat
getTempTermFormat :: (MonadGet m) => m TempEntity.TempTermFormat
getTempTermFormat =
getWord8 >>= \case
0 ->
@ -805,7 +799,7 @@ getTempTermFormat =
)
tag -> unknownTag "getTempTermFormat" tag
getTempDeclFormat :: MonadGet m => m TempEntity.TempDeclFormat
getTempDeclFormat :: (MonadGet m) => m TempEntity.TempDeclFormat
getTempDeclFormat =
getWord8 >>= \case
0 ->
@ -817,7 +811,7 @@ getTempDeclFormat =
)
tag -> unknownTag "getTempDeclFormat" tag
getTempPatchFormat :: MonadGet m => m TempEntity.TempPatchFormat
getTempPatchFormat :: (MonadGet m) => m TempEntity.TempPatchFormat
getTempPatchFormat =
getWord8 >>= \case
0 -> PatchFormat.SyncFull <$> getPatchLocalIds <*> getFramedByteString
@ -830,7 +824,7 @@ getTempPatchFormat =
<*> getVector getHash32
<*> getVector getHash32
getTempNamespaceFormat :: MonadGet m => m TempEntity.TempNamespaceFormat
getTempNamespaceFormat :: (MonadGet m) => m TempEntity.TempNamespaceFormat
getTempNamespaceFormat =
getWord8 >>= \case
0 -> BranchFormat.SyncFull <$> getBranchLocalIds <*> getFramedByteString
@ -844,16 +838,16 @@ getTempNamespaceFormat =
<*> getVector getHash32
<*> getVector (getPair getHash32 getHash32)
getTempCausalFormat :: MonadGet m => m TempEntity.TempCausalFormat
getTempCausalFormat :: (MonadGet m) => m TempEntity.TempCausalFormat
getTempCausalFormat =
Causal.SyncCausalFormat
<$> getHash32
<*> getVector getHash32
getSymbol :: MonadGet m => m Symbol
getSymbol :: (MonadGet m) => m Symbol
getSymbol = Symbol <$> getVarInt <*> getText
putSymbol :: MonadPut m => Symbol -> m ()
putSymbol :: (MonadPut m) => Symbol -> m ()
putSymbol (Symbol n t) = putVarInt n >> putText t
putReferent ::
@ -871,7 +865,7 @@ putReferent ::
m ()
putReferent = putReferent' putReference putReference
putReferent' :: MonadPut m => (r1 -> m ()) -> (r2 -> m ()) -> Referent' r1 r2 -> m ()
putReferent' :: (MonadPut m) => (r1 -> m ()) -> (r2 -> m ()) -> Referent' r1 r2 -> m ()
putReferent' putRefRef putConRef = \case
Referent.Ref r -> do
putWord8 0
@ -891,7 +885,7 @@ putReference = \case
ReferenceDerived (Reference.Id r index) ->
putWord8 1 *> putVarInt r *> putVarInt index
getReferent' :: MonadGet m => m r1 -> m r2 -> m (Referent' r1 r2)
getReferent' :: (MonadGet m) => m r1 -> m r2 -> m (Referent' r1 r2)
getReferent' getRefRef getConRef =
getWord8 >>= \case
0 -> Referent.Ref <$> getRefRef
@ -940,39 +934,39 @@ getRecursiveReference =
1 -> ReferenceDerived <$> (Reference.Id <$> getMaybe getVarInt <*> getVarInt)
x -> unknownTag "getRecursiveReference" x
putInt :: MonadPut m => Int64 -> m ()
putInt :: (MonadPut m) => Int64 -> m ()
putInt = serializeBE
getInt :: MonadGet m => m Int64
getInt :: (MonadGet m) => m Int64
getInt = deserializeBE
putNat :: MonadPut m => Word64 -> m ()
putNat :: (MonadPut m) => Word64 -> m ()
putNat = serializeBE
getNat :: MonadGet m => m Word64
getNat :: (MonadGet m) => m Word64
getNat = deserializeBE
putFloat :: MonadPut m => Double -> m ()
putFloat :: (MonadPut m) => Double -> m ()
putFloat = serializeBE
getFloat :: MonadGet m => m Double
getFloat :: (MonadGet m) => m Double
getFloat = deserializeBE
putBoolean :: MonadPut m => Bool -> m ()
putBoolean :: (MonadPut m) => Bool -> m ()
putBoolean False = putWord8 0
putBoolean True = putWord8 1
getBoolean :: MonadGet m => m Bool
getBoolean :: (MonadGet m) => m Bool
getBoolean =
getWord8 >>= \case
0 -> pure False
1 -> pure True
x -> unknownTag "Boolean" x
putTType :: MonadPut m => TermFormat.Type -> m ()
putTType :: (MonadPut m) => TermFormat.Type -> m ()
putTType = putType putReference putSymbol
putDType :: MonadPut m => DeclFormat.Type Symbol -> m ()
putDType :: (MonadPut m) => DeclFormat.Type Symbol -> m ()
putDType = putType putRecursiveReference putSymbol
putType ::
@ -994,23 +988,23 @@ putType putReference putVar = putABT putVar putUnit go
Type.Effects es -> putWord8 5 *> putFoldable putChild es
Type.Forall body -> putWord8 6 *> putChild body
Type.IntroOuter body -> putWord8 7 *> putChild body
putKind :: MonadPut m => Kind -> m ()
putKind :: (MonadPut m) => Kind -> m ()
putKind k = case k of
Kind.Star -> putWord8 0
Kind.Arrow i o -> putWord8 1 *> putKind i *> putKind o
putChar :: MonadPut m => Char -> m ()
putChar :: (MonadPut m) => Char -> m ()
putChar = serialize . VarInt . fromEnum
getChar :: MonadGet m => m Char
getChar :: (MonadGet m) => m Char
getChar = toEnum . unVarInt <$> deserialize
putMaybe :: MonadPut m => (a -> m ()) -> Maybe a -> m ()
putMaybe :: (MonadPut m) => (a -> m ()) -> Maybe a -> m ()
putMaybe putA = \case
Nothing -> putWord8 0
Just a -> putWord8 1 *> putA a
getMaybe :: MonadGet m => m a -> m (Maybe a)
getMaybe :: (MonadGet m) => m a -> m (Maybe a)
getMaybe getA =
getWord8 >>= \tag -> case tag of
0 -> pure Nothing

3
codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs
View File

@ -195,7 +195,8 @@ trySync hh runSrc runDest tCache hCache oCache cCache = \case
localIds' <- traverse syncLocalIds localIds
-- reassemble and save the reindexed term
let bytes' =
runPutS . S.recomposeDeclFormat
runPutS
. S.recomposeDeclFormat
. DeclFormat.SyncDecl
. DeclFormat.SyncLocallyIndexedComponent
$ Vector.zip localIds' declBytes

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs
View File

@ -7,7 +7,7 @@ import qualified U.Codebase.Sqlite.Entity as Entity
import U.Codebase.Sqlite.LocalIds (LocalIds')
import qualified U.Codebase.Sqlite.Patch.Format as Patch
import qualified U.Codebase.Sqlite.Term.Format as Term
import U.Util.Hash32 (Hash32)
import Unison.Hash32 (Hash32)
import Unison.Prelude
-- |

3
codebase2/codebase-sqlite/package.yaml
View File

@ -29,10 +29,11 @@ dependencies:
- unison-codebase
- unison-codebase-sync
- unison-core
- unison-hash
- unison-hash-orphans-sqlite
- unison-prelude
- unison-sqlite
- unison-util-base32hex
- unison-util-base32hex-orphans-sqlite
- unison-util-cache
- unison-util-serialization
- unison-util-term

120
codebase2/codebase-sqlite/sql/004-fix-scoped-name-lookup-tables.sql Normal file
View File

@ -0,0 +1,120 @@
ALTER TABLE scoped_term_name_lookup
RENAME TO scoped_term_name_lookup_old;
ALTER TABLE scoped_type_name_lookup
RENAME TO scoped_type_name_lookup_old;
-- Drop all existing indexes because we'll re-create them on the new table.
DROP INDEX scoped_term_names_by_namespace_and_last_name_segment;
DROP INDEX scoped_term_name_by_referent_lookup;
DROP INDEX scoped_term_names_by_namespace;
DROP INDEX scoped_type_names_by_namespace_and_last_name_segment;
DROP INDEX scoped_type_name_by_reference_lookup;
DROP INDEX scoped_type_names_by_namespace;
-- Create the new tables.
CREATE TABLE scoped_term_name_lookup (
root_branch_hash_id INTEGER NOT NULL REFERENCES name_lookups(root_branch_hash_id) ON DELETE CASCADE,
-- The name of the term in reversed form, with a trailing '.':
-- E.g. map.List.base.
--
-- The trailing '.' is helpful when performing suffix queries where we may not know
-- whether the suffix is complete or not, e.g. we could suffix search using any of the
-- following globs and it would still find 'map.List.base.':
-- map.List.base.*
-- map.List.*
-- map.*
reversed_name TEXT NOT NULL,
-- The last name segment of the name. This is used when looking up names for
-- suffixification when building PPEs.
-- E.g. for the name 'base.List.map' this would be 'map'
last_name_segment TEXT NOT NULL,
-- The namespace containing this definition, not reversed, with a trailing '.'
-- The trailing '.' simplifies GLOB queries, so that 'base.*' matches both things in
-- 'base' and 'base.List', but not 'base1', which allows us to avoid an OR in our where
-- clauses which in turn helps the sqlite query planner use indexes more effectively.
--
-- example value: 'base.List.'
namespace TEXT NOT NULL,
referent_builtin TEXT NULL,
referent_component_hash TEXT NULL,
referent_component_index INTEGER NULL,
referent_constructor_index INTEGER NULL,
referent_constructor_type INTEGER NULL,
PRIMARY KEY (root_branch_hash_id, reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index)
);
-- This index allows finding all names we need to consider within a given namespace for
-- suffixification of a name.
-- It may seem strange to use last_name_segment rather than a suffix search over reversed_name name here
-- but SQLite will only optimize for a single prefix-glob at once, so we can't glob search
-- over both namespace and reversed_name, but we can EXACT match on last_name_segment and
-- then glob search on the namespace prefix, and have SQLite do the final glob search on
-- reversed_name over rows with a matching last segment without using an index and should be plenty fast.
CREATE INDEX scoped_term_names_by_namespace_and_last_name_segment ON scoped_term_name_lookup(root_branch_hash_id, last_name_segment, namespace);
-- This index allows us to find all names with a given ref within a specific namespace
CREATE INDEX scoped_term_name_by_referent_lookup ON scoped_term_name_lookup(root_branch_hash_id, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, namespace);
-- Allows fetching ALL names within a specific namespace prefix. We currently use this to
-- pretty-print on share, but will be replaced with a more precise set of queries soon.
CREATE INDEX scoped_term_names_by_namespace ON scoped_term_name_lookup(root_branch_hash_id, namespace);
CREATE TABLE scoped_type_name_lookup (
root_branch_hash_id INTEGER NOT NULL REFERENCES name_lookups(root_branch_hash_id) ON DELETE CASCADE,
-- The name of the term: E.g. List.base
reversed_name TEXT NOT NULL,
-- The last name segment of the name. This is used when looking up names for
-- suffixification when building PPEs.
-- E.g. for the name 'base.List.map' this would be 'map'
last_name_segment TEXT NOT NULL,
-- The namespace containing this definition, not reversed, with a trailing '.'
-- The trailing '.' simplifies GLOB queries, so that 'base.*' matches both things in
-- 'base' and 'base.List', but not 'base1', which allows us to avoid an OR in our where
-- clauses which in turn helps the sqlite query planner use indexes more effectively.
--
-- example value: 'base.List.'
namespace TEXT NOT NULL,
reference_builtin TEXT NULL,
reference_component_hash INTEGER NULL,
reference_component_index INTEGER NULL,
PRIMARY KEY (root_branch_hash_id, reversed_name, reference_builtin, reference_component_hash, reference_component_index)
);
-- This index allows finding all names we need to consider within a given namespace for
-- suffixification of a name.
-- It may seem strange to use last_name_segment rather than a suffix search over reversed_name name here
-- but SQLite will only optimize for a single prefix-glob at once, so we can't glob search
-- over both namespace and reversed_name, but we can EXACT match on last_name_segment and
-- then glob search on the namespace prefix, and have SQLite do the final glob search on
-- reversed_name over rows with a matching last segment without using an index and should be plenty fast.
CREATE INDEX scoped_type_names_by_namespace_and_last_name_segment ON scoped_type_name_lookup(root_branch_hash_id, last_name_segment, namespace);
-- This index allows us to find all names with a given ref within a specific namespace.
CREATE INDEX scoped_type_name_by_reference_lookup ON scoped_type_name_lookup(root_branch_hash_id, reference_builtin, reference_component_hash, reference_component_index, namespace);
-- Allows fetching ALL names within a specific namespace prefix. We currently use this to
-- pretty-print on share, but will be replaced with a more precise set of queries soon.
CREATE INDEX scoped_type_names_by_namespace ON scoped_type_name_lookup(root_branch_hash_id, namespace);
-- Copy the old tables over to the new ones
INSERT INTO scoped_term_name_lookup (root_branch_hash_id, reversed_name, last_name_segment, namespace, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type)
SELECT root_branch_hash_id, reversed_name, last_name_segment, namespace, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type
FROM scoped_term_name_lookup_old;
INSERT INTO scoped_type_name_lookup (root_branch_hash_id, reversed_name, last_name_segment, namespace, reference_builtin, reference_component_hash, reference_component_index)
SELECT root_branch_hash_id, reversed_name, last_name_segment, namespace, reference_builtin, reference_component_hash, reference_component_index
FROM scoped_type_name_lookup_old;
-- Remove the old tables
DROP TABLE scoped_term_name_lookup_old;
DROP TABLE scoped_type_name_lookup_old
-- Semicolons intentionally omitted

98
codebase2/codebase-sqlite/sql/create.sql
View File

@ -229,7 +229,103 @@ CREATE INDEX dependents_by_dependency ON dependents_index (
CREATE INDEX dependencies_by_dependent ON dependents_index (
dependent_object_id,
dependent_component_index
)
);
-- This table allows us to look up which branch hashes have a name lookup.
CREATE TABLE name_lookups (
root_branch_hash_id INTEGER PRIMARY KEY REFERENCES hash(id) ON DELETE CASCADE
);
CREATE TABLE scoped_term_name_lookup (
root_branch_hash_id INTEGER NOT NULL REFERENCES hash(id) ON DELETE CASCADE,
-- The name of the term in reversed form, with a trailing '.':
-- E.g. map.List.base.
--
-- The trailing '.' is helpful when performing suffix queries where we may not know
-- whether the suffix is complete or not, e.g. we could suffix search using any of the
-- following globs and it would still find 'map.List.base.':
-- map.List.base.*
-- map.List.*
-- map.*
reversed_name TEXT NOT NULL,
-- The last name segment of the name. This is used when looking up names for
-- suffixification when building PPEs.
-- E.g. for the name 'base.List.map' this would be 'map'
last_name_segment TEXT NOT NULL,
-- The namespace containing this definition, not reversed, with a trailing '.'
-- The trailing '.' simplifies GLOB queries, so that 'base.*' matches both things in
-- 'base' and 'base.List', but not 'base1', which allows us to avoid an OR in our where
-- clauses which in turn helps the sqlite query planner use indexes more effectively.
--
-- example value: 'base.List.'
namespace TEXT NOT NULL,
referent_builtin TEXT NULL,
referent_component_hash TEXT NULL,
referent_component_index INTEGER NULL,
referent_constructor_index INTEGER NULL,
referent_constructor_type INTEGER NULL,
PRIMARY KEY (root_branch_hash_id, reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index)
);
-- This index allows finding all names we need to consider within a given namespace for
-- suffixification of a name.
-- It may seem strange to use last_name_segment rather than a suffix search over reversed_name name her
-- but SQLite will only optimize for a single prefix-glob at once, so we can't glob search
-- over both namespace and reversed_name, but we can EXACT match on last_name_segment and
-- then glob search on the namespace prefix, and have SQLite do the final glob search on
-- reversed_name over rows with a matching last segment without using an index and should be plenty fast.
CREATE INDEX scoped_term_names_by_namespace_and_last_name_segment ON scoped_term_name_lookup(root_branch_hash_id, last_name_segment, namespace);
-- This index allows us to find all names with a given ref within a specific namespace
CREATE INDEX scoped_term_name_by_referent_lookup ON scoped_term_name_lookup(root_branch_hash_id, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, namespace);
-- Allows fetching ALL names within a specific namespace prefix. We currently use this to
-- pretty-print on share, but will be replaced with a more precise set of queries soon.
CREATE INDEX scoped_term_names_by_namespace ON scoped_term_name_lookup(root_branch_hash_id, namespace);
CREATE TABLE scoped_type_name_lookup (
root_branch_hash_id INTEGER NOT NULL REFERENCES hash(id),
-- The name of the term: E.g. List.base
reversed_name TEXT NOT NULL,
-- The last name segment of the name. This is used when looking up names for
-- suffixification when building PPEs.
-- E.g. for the name 'base.List.map' this would be 'map'
last_name_segment TEXT NOT NULL,
-- The namespace containing this definition, not reversed, with a trailing '.'
-- The trailing '.' simplifies GLOB queries, so that 'base.*' matches both things in
-- 'base' and 'base.List', but not 'base1', which allows us to avoid an OR in our where
-- clauses which in turn helps the sqlite query planner use indexes more effectively.
--
-- example value: 'base.List.'
namespace TEXT NOT NULL,
reference_builtin TEXT NULL,
reference_component_hash INTEGER NULL,
reference_component_index INTEGER NULL,
PRIMARY KEY (reversed_name, reference_builtin, reference_component_hash, reference_component_index)
);
-- This index allows finding all names we need to consider within a given namespace for
-- suffixification of a name.
-- It may seem strange to use last_name_segment rather than a suffix search over reversed_name name here
-- but SQLite will only optimize for a single prefix-glob at once, so we can't glob search
-- over both namespace and reversed_name, but we can EXACT match on last_name_segment and
-- then glob search on the namespace prefix, and have SQLite do the final glob search on
-- reversed_name over rows with a matching last segment without using an index and should be plenty fast.
CREATE INDEX scoped_type_names_by_namespace_and_last_name_segment ON scoped_type_name_lookup(root_branch_hash_id, last_name_segment, namespace);
-- This index allows us to find all names with a given ref within a specific namespace.
CREATE INDEX scoped_type_name_by_reference_lookup ON scoped_type_name_lookup(root_branch_hash_id, reference_builtin, reference_component_hash, reference_component_index, namespace);
-- Allows fetching ALL names within a specific namespace prefix. We currently use this to
-- pretty-print on share, but will be replaced with a more precise set of queries soon.
CREATE INDEX scoped_type_names_by_namespace ON scoped_type_name_lookup(root_branch_hash_id, namespace)
-- Semicolon intentionally omitted, for the same reason
-- semicolons in comments will blow up codebase initialization.

6
codebase2/codebase-sqlite/unison-codebase-sqlite.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
-- This file has been generated from package.yaml by hpack version 0.35.0.
--
-- see: https://github.com/sol/hpack
@ -13,6 +13,7 @@ extra-source-files:
sql/001-temp-entity-tables.sql
sql/002-reflog-table.sql
sql/003-namespace-statistics.sql
sql/004-fix-scoped-name-lookup-tables.sql
sql/create.sql
source-repository head
@ -106,10 +107,11 @@ library
, unison-codebase
, unison-codebase-sync
, unison-core
, unison-hash
, unison-hash-orphans-sqlite
, unison-prelude
, unison-sqlite
, unison-util-base32hex
, unison-util-base32hex-orphans-sqlite
, unison-util-cache
, unison-util-serialization
, unison-util-term

11
codebase2/codebase/U/Codebase/Branch/Type.hs
View File

@ -57,7 +57,8 @@ data Patch = Patch
instance Show (Branch m) where
show b =
"Branch { terms = " ++ show (fmap Map.keys (terms b))
"Branch { terms = "
++ show (fmap Map.keys (terms b))
++ ", types = "
++ show (fmap Map.keys (types b))
++ ", patches = "
@ -90,7 +91,7 @@ hasDefinitions (NamespaceStats numTerms numTypes _numPatches) =
childAt :: NameSegment -> Branch m -> Maybe (CausalBranch m)
childAt ns (Branch {children}) = Map.lookup ns children
hoist :: Functor n => (forall x. m x -> n x) -> Branch m -> Branch n
hoist :: (Functor n) => (forall x. m x -> n x) -> Branch m -> Branch n
hoist f Branch {..} =
Branch
{ terms = (fmap . fmap) f terms,
@ -100,7 +101,7 @@ hoist f Branch {..} =
fmap (fmap (hoist f) . Causal.hoist f) children
}
hoistCausalBranch :: Functor n => (forall x. m x -> n x) -> CausalBranch m -> CausalBranch n
hoistCausalBranch :: (Functor n) => (forall x. m x -> n x) -> CausalBranch m -> CausalBranch n
hoistCausalBranch f cb =
cb
& Causal.hoist f
@ -110,14 +111,14 @@ hoistCausalBranch f cb =
-- provided branch.
--
-- If only name is specified, metadata will be returned for all terms at that name.
termMetadata :: Monad m => Branch m -> NameSegment -> Maybe Referent -> m [Map MetadataValue MetadataType]
termMetadata :: (Monad m) => Branch m -> NameSegment -> Maybe Referent -> m [Map MetadataValue MetadataType]
termMetadata Branch {terms} = metadataHelper terms
-- | Returns all the metadata value references that are attached to a type with the provided name in the
-- provided branch.
--
-- If only name is specified, metadata will be returned for all types at that name.
typeMetadata :: Monad m => Branch m -> NameSegment -> Maybe Reference -> m [Map MetadataValue MetadataType]
typeMetadata :: (Monad m) => Branch m -> NameSegment -> Maybe Reference -> m [Map MetadataValue MetadataType]
typeMetadata Branch {types} = metadataHelper types
metadataHelper :: (Monad m, Ord ref) => Map NameSegment (Map ref (m MdValues)) -> NameSegment -> Maybe ref -> m [Map MetadataValue MetadataType]

2
codebase2/codebase/U/Codebase/Causal.hs
View File

@ -18,7 +18,7 @@ data Causal m hc he e = Causal
}
deriving (Functor)
hoist :: Functor n => (forall x. m x -> n x) -> Causal m hc he e -> Causal n hc he e
hoist :: (Functor n) => (forall x. m x -> n x) -> Causal m hc he e -> Causal n hc he e
hoist f (Causal {..}) =
Causal
{ parents = parents & fmap f & (fmap . fmap) (hoist f),

10
codebase2/codebase/U/Codebase/Decl.hs
View File

@ -1,16 +1,10 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-}
module U.Codebase.Decl where
import Data.Set (Set)
import Data.Text (Text)
import Data.Word (Word64)
import U.Codebase.Reference (Reference')
import U.Codebase.Type (TypeR)
import qualified U.Codebase.Type as Type
import U.Util.Hash (Hash)
import Unison.Hash (Hash)
import Unison.Prelude
type ConstructorId = Word64

14
codebase2/codebase/U/Codebase/Reference.hs
View File

@ -1,21 +1,13 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeSynonymInstances #-}
module U.Codebase.Reference where
import Control.Lens (Bifunctor (..), Lens, Prism, Traversal, lens, prism)
import Data.Bifoldable (Bifoldable (..))
import Data.Bitraversable (Bitraversable (..))
import Data.Text (Text)
import Data.Word (Word64)
import U.Codebase.ShortHash (ShortHash)
import qualified U.Codebase.ShortHash as SH
import U.Util.Hash (Hash)
import qualified U.Util.Hash as Hash
import Unison.Hash (Hash)
import qualified Unison.Hash as Hash
import Unison.Prelude
-- | This is the canonical representation of Reference
type Reference = Reference' Text Hash

7
codebase2/codebase/U/Codebase/Referent.hs
View File

@ -1,9 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeSynonymInstances #-}
module U.Codebase.Referent where
@ -17,7 +12,7 @@ import U.Codebase.Reference (Reference, Reference')
import qualified U.Codebase.Reference as Reference
import U.Codebase.ShortHash (ShortHash)
import qualified U.Codebase.ShortHash as SH
import U.Util.Hash (Hash)
import Unison.Hash (Hash)
import Unison.Prelude
data ConstructorType

24
codebase2/codebase/U/Codebase/Term.hs
View File

@ -1,35 +1,15 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ViewPatterns #-}
module U.Codebase.Term where
import qualified Control.Monad.Writer as Writer
import qualified Data.Foldable as Foldable
import Data.Int (Int64)
import Data.Sequence (Seq)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Word (Word64)
import GHC.Generics (Generic, Generic1)
import U.Codebase.Reference (Reference, Reference')
import U.Codebase.Referent (Referent')
import U.Codebase.Type (TypeR)
import qualified U.Codebase.Type as Type
import qualified U.Core.ABT as ABT
import U.Util.Hash (Hash)
import Unison.Hash (Hash)
import Unison.Prelude
type ConstructorId = Word64

23
codebase2/codebase/U/Codebase/Type.hs
View File

@ -1,27 +1,14 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ViewPatterns #-}
module U.Codebase.Type where
import qualified Control.Monad.Writer.Strict as Writer
import Data.Bifunctor (Bifunctor (bimap))
import Data.Functor (($>))
import qualified Data.Maybe as Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import U.Codebase.Kind (Kind)
import U.Codebase.Reference (Reference, Reference')
import qualified U.Core.ABT as ABT
import U.Util.Hash (Hash)
import Unison.Hash (Hash)
import Unison.Prelude
import Unsafe.Coerce (unsafeCoerce)
-- | For standalone types, like those in Term.Ann
@ -51,17 +38,17 @@ type TypeD v = ABT.Term FD v ()
type TypeR r v = ABT.Term (F' r) v ()
rmap :: Ord v => (r -> r') -> ABT.Term (F' r) v a -> ABT.Term (F' r') v a
rmap :: (Ord v) => (r -> r') -> ABT.Term (F' r) v a -> ABT.Term (F' r') v a
rmap f = ABT.transform \case
Ref r -> Ref (f r)
x -> unsafeCoerce x
typeD2T :: Ord v => Hash -> TypeD v -> TypeT v
typeD2T :: (Ord v) => Hash -> TypeD v -> TypeT v
typeD2T h = rmap $ bimap id $ Maybe.fromMaybe h
dependencies :: (Ord v, Ord r) => ABT.Term (F' r) v a -> Set r
dependencies = Writer.execWriter . ABT.visit' f
where
f :: Ord r => F' r a -> Writer.Writer (Set r) (F' r a)
f :: (Ord r) => F' r a -> Writer.Writer (Set r) (F' r a)
f t@(Ref r) = Writer.tell (Set.singleton r) $> t
f t = pure t

3
codebase2/codebase/package.yaml
View File

@ -4,8 +4,10 @@ github: unisonweb/unison
default-extensions:
- ApplicativeDo
- BlockArguments
- DeriveFoldable
- DeriveFunctor
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- DoAndIfThenElse
- FlexibleContexts
@ -32,6 +34,7 @@ dependencies:
- mtl
- text
- unison-core
- unison-hash
- unison-util-base32hex
- unison-prelude
- time

3
codebase2/codebase/unison-codebase.cabal
View File

@ -34,8 +34,10 @@ library
default-extensions:
ApplicativeDo
BlockArguments
DeriveFoldable
DeriveFunctor
DeriveGeneric
DeriveTraversable
DerivingStrategies
DoAndIfThenElse
FlexibleContexts
@ -56,6 +58,7 @@ library
, text
, time
, unison-core
, unison-hash
, unison-prelude
, unison-util-base32hex
default-language: Haskell2010

2
codebase2/core/U/Codebase/HashTags.hs
View File

@ -1,6 +1,6 @@
module U.Codebase.HashTags where
import U.Util.Hash (Hash)
import Unison.Hash (Hash)
newtype BranchHash = BranchHash {unBranchHash :: Hash} deriving (Eq, Ord)

36
codebase2/core/U/Core/ABT.hs
View File

@ -8,8 +8,10 @@ import Data.Functor.Identity (Identity (runIdentity))
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Debug.RecoverRTTI as RTTI
import GHC.Generics (Generic)
import U.Core.ABT.Var (Var (freshIn))
import qualified Unison.Debug as Debug
import Prelude hiding (abs, cycle)
data ABT f v r
@ -24,7 +26,7 @@ data ABT f v r
data Term f v a = Term {freeVars :: Set v, annotation :: a, out :: ABT f v (Term f v a)}
deriving (Functor, Foldable, Generic, Traversable)
instance (Foldable f, Functor f, forall a. Eq a => Eq (f a), Var v) => Eq (Term f v a) where
instance (Foldable f, Functor f, forall a. (Eq a) => Eq (f a), Var v) => Eq (Term f v a) where
-- alpha equivalence, works by renaming any aligned Abs ctors to use a common fresh variable
t1 == t2 = go (out t1) (out t2)
where
@ -41,10 +43,10 @@ instance (Foldable f, Functor f, forall a. Eq a => Eq (f a), Var v) => Eq (Term
go _ _ = False
instance
( forall a. Eq a => Eq (f a),
( forall a. (Eq a) => Eq (f a),
Foldable f,
Functor f,
forall a. Ord a => Ord (f a),
forall a. (Ord a) => Ord (f a),
Var v
) =>
Ord (Term f v a)
@ -68,15 +70,19 @@ instance
tag (Abs _ _) = 2
tag (Cycle _) = 3
instance (forall a. Show a => Show (f a), Show v) => Show (Term f v a) where
-- annotations not shown
showsPrec p (Term _ _ out) = case out of
Var v -> showParen (p >= 9) $ \x -> "Var " ++ show v ++ x
Cycle body -> ("Cycle " ++) . showsPrec p body
Abs v body -> showParen True $ (show v ++) . showString ". " . showsPrec p body
Tm f -> showsPrec p f
instance (forall a. (Show a) => Show (f a), Show v) => Show (Term f v a) where
showsPrec p (Term _ ann out) = case out of
Var v -> showParen (p >= 9) $ \x -> showAnn ++ "Var " ++ show v ++ x
Cycle body -> (\s -> showAnn ++ "Cycle " ++ s) . showsPrec p body
Abs v body -> showParen True $ (\s -> showAnn ++ show v ++ s) . showString ". " . showsPrec p body
Tm f -> (showAnn ++) . showsPrec p f
where
showAnn =
if Debug.shouldDebug Debug.Annotations
then "(" ++ RTTI.anythingToString ann ++ ")"
else ""
amap :: Functor f => (a -> a') -> Term f v a -> Term f v a'
amap :: (Functor f) => (a -> a') -> Term f v a -> Term f v a'
amap = fmap
vmap :: (Functor f, Foldable f, Ord v') => (v -> v') -> Term f v a -> Term f v' a
@ -87,7 +93,7 @@ vmap f (Term _ a out) = case out of
Abs v body -> abs a (f v) (vmap f body)
cata ::
Functor f =>
(Functor f) =>
(a -> ABT f v x -> x) ->
Term f v a ->
x
@ -96,7 +102,7 @@ cata abtAlg =
in go
para ::
Functor f =>
(Functor f) =>
(a -> ABT f v (Term f v a, x) -> x) ->
Term f v a ->
x
@ -126,7 +132,7 @@ transformM f t = case out t of
Tm subterms -> tm (annotation t) <$> (traverse (transformM f) =<< f subterms)
Cycle body -> cycle (annotation t) <$> (transformM f body)
abs :: Ord v => a -> v -> Term f v a -> Term f v a
abs :: (Ord v) => a -> v -> Term f v a -> Term f v a
abs a v body = Term (Set.delete v (freeVars body)) a (Abs v body)
var :: a -> v -> Term f v a
@ -228,7 +234,7 @@ unabs (Term _ _ (Abs hd body)) =
unabs t = ([], t)
-- | Produce a variable which is free in both terms
freshInBoth :: Var v => Term f v a -> Term f v a -> v -> v
freshInBoth :: (Var v) => Term f v a -> Term f v a -> v -> v
freshInBoth t1 t2 = freshIn $ Set.union (freeVars t1) (freeVars t2)
substsInheritAnnotation ::

2
codebase2/core/U/Core/ABT/Var.hs
View File

@ -6,5 +6,5 @@ import Data.Set (Set)
--
-- * `Set.notMember (freshIn vs v) vs`:
-- `freshIn` returns a variable not used in the `Set`
class Ord v => Var v where
class (Ord v) => Var v where
freshIn :: Set v -> v -> v

8
codebase2/core/Unison/Util/Alphabetical.hs
View File

@ -14,7 +14,7 @@ import Data.Text (Text)
-- This need not coincide with the `Ord` instance for a type, which
-- is often an efficient yet arbitrary ordering that's used for
-- stashing the values in maps and sets.
class Eq n => Alphabetical n where
class (Eq n) => Alphabetical n where
compareAlphabetical :: n -> n -> Ordering
instance Alphabetical Text where
@ -26,11 +26,11 @@ newtype OrderAlphabetically a = OrderAlphabetically a deriving (Functor, Travers
instance (Eq a, Alphabetical a) => Ord (OrderAlphabetically a) where
compare (OrderAlphabetically a) (OrderAlphabetically b) = compareAlphabetical a b
instance Alphabetical a => Alphabetical [a] where
instance (Alphabetical a) => Alphabetical [a] where
compareAlphabetical a1s a2s = compare (OrderAlphabetically <$> a1s) (OrderAlphabetically <$> a2s)
instance Alphabetical a => Alphabetical (List.NonEmpty a) where
instance (Alphabetical a) => Alphabetical (List.NonEmpty a) where
compareAlphabetical a1s a2s = compare (OrderAlphabetically <$> a1s) (OrderAlphabetically <$> a2s)
instance Alphabetical a => Alphabetical (Maybe a) where
instance (Alphabetical a) => Alphabetical (Maybe a) where
compareAlphabetical a1s a2s = compare (OrderAlphabetically <$> a1s) (OrderAlphabetically <$> a2s)

2
codebase2/core/package.yaml
View File

@ -13,6 +13,8 @@ dependencies:
- rfc5051
- text
- vector
- recover-rtti
- unison-hash
- unison-prelude
- unison-util-base32hex

2
codebase2/core/unison-core.cabal
View File

@ -52,8 +52,10 @@ library
build-depends:
base
, containers
, recover-rtti
, rfc5051
, text
, unison-hash
, unison-prelude
, unison-util-base32hex
, vector

58
codebase2/util-serialization/U/Util/Serialization.hs
View File

@ -40,9 +40,9 @@ import UnliftIO (MonadIO, liftIO)
import UnliftIO.Directory (createDirectoryIfMissing, doesFileExist)
import Prelude hiding (readFile, writeFile)
type Get a = forall m. MonadGet m => m a
type Get a = forall m. (MonadGet m) => m a
type Put a = forall m. MonadPut m => a -> m ()
type Put a = forall m. (MonadPut m) => a -> m ()
-- todo: do we use this?
data Format a = Format
@ -57,12 +57,12 @@ getFromBytes :: Get a -> ByteString -> Maybe a
getFromBytes getA bytes =
case runGetS getA bytes of Left _ -> Nothing; Right a -> Just a
getFromFile :: MonadIO m => Get a -> FilePath -> m (Maybe a)
getFromFile :: (MonadIO m) => Get a -> FilePath -> m (Maybe a)
getFromFile getA file = do
b <- doesFileExist file
if b then getFromBytes getA <$> liftIO (readFile file) else pure Nothing
getFromFile' :: MonadIO m => Get a -> FilePath -> m (Either String a)
getFromFile' :: (MonadIO m) => Get a -> FilePath -> m (Either String a)
getFromFile' getA file = do
b <- doesFileExist file
if b
@ -72,7 +72,7 @@ getFromFile' getA file = do
putBytes :: Put a -> a -> ByteString
putBytes put a = runPutS (put a)
putWithParentDirs :: MonadIO m => Put a -> FilePath -> a -> m ()
putWithParentDirs :: (MonadIO m) => Put a -> FilePath -> a -> m ()
putWithParentDirs putA file a = do
createDirectoryIfMissing True (takeDirectory file)
liftIO . writeFile file $ putBytes putA a
@ -97,28 +97,28 @@ getVarInt = getWord8 >>= getVarInt
{-# INLINE getVarInt #-}
{-# INLINE getVarInt #-}
putText :: MonadPut m => Text -> m ()
putText :: (MonadPut m) => Text -> m ()
putText text = do
let bs = encodeUtf8 text
putVarInt $ BS.length bs
putByteString bs
getText :: MonadGet m => m Text
getText :: (MonadGet m) => m Text
getText = do
len <- getVarInt
bs <- BS.copy <$> getBytes len
pure $ decodeUtf8 bs
skipText :: MonadGet m => m ()
skipText :: (MonadGet m) => m ()
skipText = skip =<< getVarInt
putShortText :: MonadPut m => ShortText -> m ()
putShortText :: (MonadPut m) => ShortText -> m ()
putShortText text = do
let sbs = TS.toShortByteString text
putVarInt $ BSS.length sbs
putShortByteString sbs
getShortText :: MonadGet m => m ShortText
getShortText :: (MonadGet m) => m ShortText
getShortText = do
len <- getVarInt
sbs <- getShortByteString len
@ -126,12 +126,12 @@ getShortText = do
-- | the `binary` package has a native version of this,
-- which may be more efficient by a constant factor
putShortByteString :: MonadPut m => ShortByteString -> m ()
putShortByteString :: (MonadPut m) => ShortByteString -> m ()
putShortByteString = putByteString . BSS.fromShort
-- | the `binary` package has a native version of this,
-- which may be more efficient by a constant factor
getShortByteString :: MonadGet m => Int -> m ShortByteString
getShortByteString :: (MonadGet m) => Int -> m ShortByteString
getShortByteString len = BSS.toShort <$> getByteString len
putFoldable ::
@ -140,17 +140,17 @@ putFoldable putA as = do
putVarInt (length as)
traverse_ putA as
getList :: MonadGet m => m a -> m [a]
getList :: (MonadGet m) => m a -> m [a]
getList getA = do
length <- getVarInt
replicateM length getA
getVector :: MonadGet m => m a -> m (Vector a)
getVector :: (MonadGet m) => m a -> m (Vector a)
getVector getA = do
length <- getVarInt
Vector.replicateM length getA
getSequence :: MonadGet m => m a -> m (Seq a)
getSequence :: (MonadGet m) => m a -> m (Seq a)
getSequence getA = do
length <- getVarInt
Seq.replicateM length getA
@ -161,7 +161,7 @@ getSet getA = do
-- avoid materializing intermediate list
foldM (\s ma -> Set.insert <$> ma <*> pure s) mempty (replicate length getA)
putMap :: MonadPut m => (a -> m ()) -> (b -> m ()) -> Map a b -> m ()
putMap :: (MonadPut m) => (a -> m ()) -> (b -> m ()) -> Map a b -> m ()
putMap putA putB m = putFoldable (putPair putA putB) (Map.toList m)
addToExistingMap :: (MonadGet m, Ord a) => m a -> m b -> Map a b -> m (Map a b)
@ -176,22 +176,22 @@ addToExistingMap getA getB map = do
getMap :: (MonadGet m, Ord a) => m a -> m b -> m (Map a b)
getMap getA getB = addToExistingMap getA getB mempty
getFramedByteString :: MonadGet m => m ByteString
getFramedByteString :: (MonadGet m) => m ByteString
getFramedByteString = getVarInt >>= getByteString
getRemainingByteString :: MonadGet m => m ByteString
getRemainingByteString :: (MonadGet m) => m ByteString
getRemainingByteString = fromIntegral <$> remaining >>= getByteString
getFramed :: MonadGet m => Get a -> m a
getFramed :: (MonadGet m) => Get a -> m a
getFramed get =
getFramedByteString >>= either fail pure . runGetS get
putFramedByteString :: MonadPut m => ByteString -> m ()
putFramedByteString :: (MonadPut m) => ByteString -> m ()
putFramedByteString bs = do
putVarInt (BS.length bs)
putByteString bs
putFramed :: MonadPut m => Put a -> a -> m ()
putFramed :: (MonadPut m) => Put a -> a -> m ()
putFramed put a = do
-- 1. figure out the length `len` of serialized `a`
-- 2. Put the length `len`
@ -201,7 +201,7 @@ putFramed put a = do
putVarInt (BS.length bs)
putByteString bs
skipFramed :: MonadGet m => m ()
skipFramed :: (MonadGet m) => m ()
skipFramed = do
len <- getVarInt
skip len
@ -214,7 +214,7 @@ putFramedArray put (toList -> as) = do
putFoldable putVarInt offsets
traverse_ putByteString bss
getFramedArray :: MonadGet m => m a -> m (Vector a)
getFramedArray :: (MonadGet m) => m a -> m (Vector a)
getFramedArray getA = do
offsets :: [Int] <- getList getVarInt
let count = length offsets - 1
@ -223,7 +223,7 @@ getFramedArray getA = do
-- | Look up a 0-based index in a framed array, O(num array elements),
-- because it reads the start indices for all elements first.
-- This could be skipped if the indices had a fixed size instead of varint
lookupFramedArray :: MonadGet m => m a -> Int -> m (Maybe a)
lookupFramedArray :: (MonadGet m) => m a -> Int -> m (Maybe a)
lookupFramedArray getA index = do
offsets <- getVector getVarInt
if index > Vector.length offsets - 1
@ -232,20 +232,20 @@ lookupFramedArray getA index = do
skip (Vector.unsafeIndex offsets index)
Just <$> getA
lengthFramedArray :: MonadGet m => m Word64
lengthFramedArray :: (MonadGet m) => m Word64
lengthFramedArray = (\offsetsLen -> offsetsLen - 1) <$> getVarInt
unsafeFramedArrayLookup :: MonadGet m => m a -> Int -> m a
unsafeFramedArrayLookup :: (MonadGet m) => m a -> Int -> m a
unsafeFramedArrayLookup getA index = do
offsets <- getVector getVarInt
skip (Vector.unsafeIndex offsets index)
getA
putPair :: MonadPut m => (a -> m ()) -> (b -> m ()) -> (a, b) -> m ()
putPair :: (MonadPut m) => (a -> m ()) -> (b -> m ()) -> (a, b) -> m ()
putPair putA putB (a, b) = putA a *> putB b
getPair :: MonadGet m => m a -> m b -> m (a, b)
getPair :: (MonadGet m) => m a -> m b -> m (a, b)
getPair = liftA2 (,)
getTuple3 :: MonadGet m => m a -> m b -> m c -> m (a, b, c)
getTuple3 :: (MonadGet m) => m a -> m b -> m c -> m (a, b, c)
getTuple3 = liftA3 (,,)

4
codebase2/util-term/U/Util/Term.hs
View File

@ -11,14 +11,14 @@ import U.Codebase.Term (F' (..), MatchCase (..), Pattern (..))
import qualified U.Codebase.Term as Term
import qualified U.Core.ABT as ABT
text :: Ord v => ABT.Term (Term.F' text termRef typeRef termLink typeLink vt) v a -> [text]
text :: (Ord v) => ABT.Term (Term.F' text termRef typeRef termLink typeLink vt) v a -> [text]
text =
execWriter . ABT.visit_ \case
Text t -> tell [t]
_ -> pure ()
dependencies ::
Ord v =>
(Ord v) =>
ABT.Term (Term.F' text termRef typeRef termLink typeLink vt) v a ->
([termRef], [typeRef], [termLink], [typeLink])
dependencies =

12
codebase2/util-term/U/Util/Type.hs
View File

@ -13,13 +13,13 @@ import qualified U.Core.ABT.Var as ABT
-- * Constructors
effect :: Ord v => [TypeR r v] -> TypeR r v -> TypeR r v
effect :: (Ord v) => [TypeR r v] -> TypeR r v -> TypeR r v
effect es (Effect1' fs t) =
let es' = (es >>= flattenEffects) ++ flattenEffects fs
in ABT.tm () (Effect (ABT.tm () (Effects es')) t)
effect es t = ABT.tm () (Effect (ABT.tm () (Effects es)) t)
effects :: Ord v => [TypeR r v] -> TypeR r v
effects :: (Ord v) => [TypeR r v] -> TypeR r v
effects es = ABT.tm () (Effects $ es >>= flattenEffects)
-- * Modification
@ -28,7 +28,7 @@ effects es = ABT.tm () (Effects $ es >>= flattenEffects)
-- Used for type-based search, we apply this transformation to both the
-- indexed type and the query type, so the user can supply `a -> b` that will
-- match `a ->{e} b` (but not `a ->{IO} b`).
removeAllEffectVars :: ABT.Var v => TypeR r v -> TypeR r v
removeAllEffectVars :: (ABT.Var v) => TypeR r v -> TypeR r v
removeAllEffectVars t =
let allEffectVars = foldMap go (ABT.subterms t)
go (Effects' vs) = Set.fromList [v | Var' v <- vs]
@ -38,7 +38,7 @@ removeAllEffectVars t =
in generalize vs (removeEffectVars allEffectVars tu)
-- Remove free effect variables from the type that are in the set
removeEffectVars :: ABT.Var v => Set v -> TypeR r v -> TypeR r v
removeEffectVars :: (ABT.Var v) => Set v -> TypeR r v -> TypeR r v
removeEffectVars removals t =
let z = effects []
t' = ABT.substsInheritAnnotation ((,z) <$> Set.toList removals) t
@ -58,7 +58,7 @@ flattenEffects (Effects' es) = es >>= flattenEffects
flattenEffects es = [es]
-- | Bind the given variables with an outer `forall`, if they are used in `t`.
generalize :: Ord v => [v] -> TypeR r v -> TypeR r v
generalize :: (Ord v) => [v] -> TypeR r v -> TypeR r v
generalize vs t = foldr f t vs
where
f v t = if Set.member v (ABT.freeVars t) then forall v t else t
@ -80,7 +80,7 @@ pattern Effect1' e t <- ABT.Tm' (Effect e t)
pattern Ref' :: r -> TypeR r v
pattern Ref' r <- ABT.Tm' (Ref r)
forall :: Ord v => v -> TypeR r v -> TypeR r v
forall :: (Ord v) => v -> TypeR r v -> TypeR r v
forall v body = ABT.tm () (Forall (ABT.abs () v body))
unforall' :: TypeR r v -> ([v], TypeR r v)

31
development.markdown
View File

@ -16,6 +16,37 @@ To get cracking with Unison:
On startup, Unison prints a url for the codebase UI. If you did step 3 above, then visiting that URL in a browser will give you a nice interface to your codebase.
## Autoformatting your code with Ormolu
We use 0.5.3.0 of Ormolu and CI will fail if your code isn't properly formatted. You can add the following to `.git/hooks/pre-commit` to make sure all your commits get formatted (this assumes you've got [`rg`](https://github.com/BurntSushi/ripgrep) installed and on your path):
```
#!/bin/bash
set -e
if [[ -z "${SKIP_FORMATTING}" ]]; then
git diff --cached --name-only | rg '.hs$' | xargs -n1 ormolu --ghc-opt '-XBangPatterns' --ghc-opt '-XCPP' --ghc-opt '-XPatternSynonyms' -i
git add $(git diff --cached --name-only)
fi
```
If you've got an existing PR that somehow hasn't been formatted correctly, you can install the correct version of Ormolu locally, then do:
```
ormolu --mode inplace $(find . -name '*.hs')
```
Also note that you can always wrap a comment around some code you don't want Ormolu to touch, using:
```
{- ORMOLU_DISABLE -}
dontFormatMe = do blah
blah
blah
{- ORMOLU_ENABLE -}
```
## Running Tests
* `stack test --fast` builds and runs most test suites, see below for exceptions to this (e.g. transcript tests).

98
docs/adding-builtins.markdown
View File

@ -44,7 +44,6 @@ namespace. However, we will also add the value:
```haskell
Rename' "MVar" "io2.MVar"
```
because this is a type to be used with the new IO functions, which are
currently nested under the `io2` namespace. With both of these added
to the list, running `builtins.merge` should have a `builtin.io2.MVar`
@ -76,25 +75,28 @@ add declarations similar to:
```haskell
B "MVar.new" $ forall1 "a" (\a -> a --> io (mvar a))
Rename "MVar.new" "io2.MVar.new"
B "MVar.take" $ forall1 "a" (\a -> mvar a --> ioe a)
B "MVar.take" $ forall1 "a" (\a -> mvar a --> iof a)
Rename "MVar.take" "io2.MVar.take"
```
The `forall1`, `io`, `ioe` and `-->` functions are local definitions
in `Unison.Builtin` for assistance in writing the types. `ioe`
The `forall1`, `io`, `iof` and `-->` functions are local definitions
in `Unison.Builtin` for assistance in writing the types. `iof`
indicates that an error result may be returned, while `io` should
always succeed. `mvar` can be defined locally using some other
always succeed. Note that when the `{IO}` ability appears as a type
parameter rather than the return type of a function, you will need to
use `iot` instead.
`mvar` can be defined locally using some other
helpers in scope:
```haskell
mvar :: Var v => Type v -> Type v
mvar :: Type -> Type
mvar a = Type.ref () Type.mvarRef `app` a
```
For the actual `MVar` implementation, we'll be doing many definitions
followed by renames, so it'll be factored into a list of the name and
type, together with a function that generates the declaration and the
rename.
type, and we can then call the `moveUnder` helper to generate the `B`
declaration and the `Rename`.
## Builtin function implementation -- new runtime
@ -111,41 +113,45 @@ in `Unison.Runtime.Builtin`, in a definition `declareForeigns`. We
can declare our builtins there by adding:
```haskell
declareForeign "MVar.new" mvar'new
declareForeign Tracked "MVar.new" boxDirect
. mkForeign $ \(c :: Closure) -> newMVar c
declareForeign "MVar.take" mvar'take
. mkForeignIOE $ \(mv :: MVar Closure) -> takeMVar mv
declareForeign Tracked "MVar.take" boxToEFBox
. mkForeignIOF $ \(mv :: MVar Closure) -> takeMVar mv
```
These lines do multiple things at once. The first argument to
`declareForeign` must match the name from `Unison.Builtin`, as this
is how they are associated. The second argument is wrapper code
that actually defines the unison function that will be called, and
the definitions for these two cases will be shown later. The last
argument is the actual Haskell implementation of the operation.
However, the format for foreign functions is somewhat more limited
than 'any Haskell function,' so the `mkForeign` and `mkForeignIOE`
helpers assist in wrapping Haskell functions correctly. The latter
will catch some exceptions and yield them as explicit results.
`declareForeign` determines whether the function should be explicitly
tracked by the Unison Cloud sandboxing functionality or not. As a
general guideline, functions in `{IO}` are `Tracked`, and pure
functions are `Untracked`. The second argument must match the name
from `Unison.Builtin`, as this is how they are associated. The third
argument is wrapper code that defines the conversion from the Haskell
runtim calling convention into Unison, and the definitions for these
two cases will be shown later. The last argument is the actual Haskell
implementation of the operation. However, the format for foreign
functions is somewhat more limited than 'any Haskell function,' so the
`mkForeign` and `mkForeignIOF` helpers assist in wrapping Haskell
functions correctly. The latter will catch some exceptions and yield
them as explicit results.
The wrapper code for these two operations looks like:
```haskell
mvar'new :: ForeignOp
mvar'new instr
= ([BX],)
. TAbs init
$ TFOp instr [init]
-- a -> b
boxDirect :: ForeignOp
boxDirect instr =
([BX],)
. TAbs arg
$ TFOp instr [arg]
where
[init] = freshes 1
arg = fresh1
mvar'take :: ForeignOp
mvar'take instr
= ([BX],)
. TAbs mv
$ io'error'result'direct instr [mv] ior e r
-- a -> Either Failure b
boxToEFBox :: ForeignOp
boxToEFBox =
inBx arg result $
outIoFailBox stack1 stack2 stack3 any fail result
where
[mv,ior,e,r] = freshes 4
(arg, result, stack1, stack2, stack3, any, fail) = fresh
```
The breakdown of what is happening here is as follows:
@ -161,23 +167,25 @@ The breakdown of what is happening here is as follows:
currently be taking all boxed arguments, because there is no way
to talk about unboxed values in the surface syntax where they are
called.
- `TAbs init` abstracts the argument variable, which we got from
`freshes'` at the bottom. Multiple arguments may be abstracted with
e.g. `TAbss [x,y,z]`
- `io'error'result'direct` is a helper function for calling the
instruction and wrapping up a possible error result. The first
argument is the identifier to call, the list is the arguments,
and the last three arguments are variables used in the common
result handling code.
- `TAbs arg` abstracts the argument variable, which we got from
`fresh1'` at the bottom. Multiple arguments may be abstracted with
e.g. `TAbss [x,y,z]`. You can call `fresh` to instantiate a tuple of
fresh variables of a certain arity.
- `inBx` and `outIoFailBox` are helper functions for calling the
instruction and wrapping up a possible error result.
- `TFOp` simply calls the instruction with the assumption that the
result value is acceptable for directly returning. `MVar` values
will be represented directly by their Haskell values wrapped into
a closure, so the `mvar'new` code doesn't need to do any
a closure, so the `boxDirect` code doesn't need to do any
processing of the results of its foreign function.
Other builtins use slightly different implementations, so looking at
other parts of the file may be instructive, depending on what is being
added.
The names of the helpers generally follow a form of form of Hungarian
notation, e.g. `boxToEFBox` means "boxed value to either a failure or
a boxed value", i.e. `a -> Either a b`.
However, not all helpers are named consistently at the moment, and
different builtins use slightly different implementations, so looking
at other parts of the file may be instructive, depending on what is
being added.
At first, our declarations will cause an error, because some of the
automatic machinery for creating builtin 'foreign' functions does not

26
docs/configuration.md
View File

@ -5,6 +5,7 @@
* [`UNISON_DEBUG`](#unison_debug)
* [`UNISON_PAGER`](#unison_pager)
* [`UNISON_LSP_PORT`](#unison_lsp_port)
* [`UNISON_LSP_ENABLED`](#unison_lsp_enabled)
* [`UNISON_SHARE_HOST`](#unison_share_host)
* [`UNISON_SHARE_ACCESS_TOKEN`](#unison_share_access_token)
* [Local Codebase Server](#local-codebase-server)
@ -50,6 +51,31 @@ E.g.
$ UNISON_LSP_PORT=8080 ucm
```
### `UNISON_LSP_ENABLED`
Allows explicitly enabling or disabling the LSP server.
Acceptable values are 'true' or 'false'
Note for Windows users: Due to an outstanding issue with GHC's IO manager on Windows, the LSP is **disabled by default** on Windows machines.
Enabling the LSP on windows can cause UCM to hang on exit and may require the process to be killed by the operating system or via Ctrl-C.
Note that this doesn't pose any risk of codebase corruption or cause any known issues, it's simply an annoyance.
If you accept this annoyance, you can enable the LSP server on Windows by exporting the `UNISON_LSP_ENABLED=true` environment variable.
You can set this persistently in powershell using:
```powershell
[System.Environment]::SetEnvironmentVariable('UNISON_LSP_ENABLED','true')
```
See [this issue](https://github.com/unisonweb/unison/issues/3487) for more details.
E.g.
```sh
$ UNISON_LSP_ENABLED=true ucm
```
### `UNISON_SHARE_HOST`
Allows selecting the location for the default Share server.

112
docs/language-server.markdown
View File

@ -20,9 +20,40 @@ Currently the only supported configuration is to connect to the LSP via a specif
By default the LSP is hosted at `127.0.0.1:5757`, but you can change the port using `UNISON_LSP_PORT=1234`.
Note for Windows users: Due to an outstanding issue with GHC's IO manager on Windows, the LSP is **disabled by default** on Windows machines.
Enabling the LSP on windows can cause UCM to hang on exit and may require the process to be killed by the operating system or via Ctrl-C.
Note that this doesn't pose any risk of codebase corruption or cause any known issues, it's simply an annoyance.
If you accept this annoyance, you can enable the LSP server on Windows by exporting the `UNISON_LSP_ENABLED=true` environment variable.
You can set this persistently in powershell using:
```powershell
[System.Environment]::SetEnvironmentVariable('UNISON_LSP_ENABLED','true')
```
See [this issue](https://github.com/unisonweb/unison/issues/3487) for more details.
### NeoVim
Before configuring the LSP, install the Vim plugin for filetype detection and syntax highlighting.
For [Packer](https://github.com/wbthomason/packer.nvim) you can install the package as follow:
```lua
-- You may need to increase the git clone timeout setting in Packer!
use {
"unisonweb/unison",
branch = "trunk",
rtp = "/editor-support/vim"
}
```
or [Plug](https://github.com/junegunn/vim-plug):
```vim
Plug 'unisonweb/unison', { 'branch': 'trunk', 'rtp': 'editor-support/vim' }
```
Configuration for [coc-nvim](https://github.com/neoclide/coc.nvim), enter the following in the relevant place of your CocConfig
```
@ -36,12 +67,93 @@ Configuration for [coc-nvim](https://github.com/neoclide/coc.nvim), enter the fo
}
```
For [lspconfig](https://github.com/neovim/nvim-lspconfig) with optional autocomplete [nvim-cmp](https://github.com/hrsh7th/nvim-cmp) for LSP
[cmp-nvim-lsp](https://github.com/hrsh7th/cmp-nvim-lsp), you can use the following setup function(s):
```lua
-- This function is for configuring a buffer when an LSP is attached
local on_attach = function(client, bufnr)
-- Always show the signcolumn, otherwise it would shift the text each time
-- diagnostics appear/become resolved
vim.o.signcolumn = 'yes'
-- Update the cursor hover location every 1/4 of a second
vim.o.updatetime = 250
-- Disable appending of the error text at the offending line
vim.diagnostic.config({virtual_text=false})
-- Enable a floating window containing the error text when hovering over an error
vim.api.nvim_create_autocmd("CursorHold", {
buffer = bufnr,
callback = function()
local opts = {
focusable = false,
close_events = { "BufLeave", "CursorMoved", "InsertEnter", "FocusLost" },
border = 'rounded',
source = 'always',
prefix = ' ',
scope = 'cursor',
}
vim.diagnostic.open_float(nil, opts)
end
})
-- This setting is to display hover information about the symbol under the cursor
vim.keymap.set('n', 'K', vim.lsp.buf.hover)
end
-- Setup the Unison LSP
require('lspconfig')['unison'].setup{
on_attach = on_attach,
}
```
```lua
-- This is NVim Autocompletion support
local cmp = require 'cmp'
-- This function sets up autocompletion
cmp.setup {
-- This mapping affects the autocompletion choices menu
mapping = cmp.mapping.preset.insert(),
-- This table names the sources for autocompletion
sources = {
{ name = 'nvim_lsp' },
},
}
```
Note that you'll need to start UCM _before_ you try connecting to it in your editor or your editor might give up.
### VSCode
Simply install the [Unison Language VSCode extension](https://marketplace.visualstudio.com/items?itemName=unison-lang.unison).
### Helix Editor
To `~/.config/helix/languages.toml` append this code:
```toml
[[language]]
name = "unison"
scope = "source.unison"
injection-regex = "unison"
file-types = ["u"]
shebangs = []
roots = []
auto-format = false
comment-token = "--"
indent = { tab-width = 4, unit = " " }
language-server = { command = "ncat", args = ["localhost", "5757"] }
```
or follow the instructions for Unison in "[How to install the default language servers](https://github.com/helix-editor/helix/wiki/How-to-install-the-default-language-servers#unison)" wiki page.
### Other Editors

164
docs/m1-mac-setup-tips.markdown Normal file
View File

@ -0,0 +1,164 @@
# M1 Mac Haskell toolchain setup
If you are a newcomer to the Haskell ecosystem trying to set up your dev environment on a Mac M1 computer, welcome, you can do this! The tips in this document provide one way to get a working development setup, but are not the only path forward. If you haven't downloaded the Haskell toolchain before, our recommendation is to use GHCup. We've found that issues can arise if you mix ARM native binaries with x86 binaries to be run with Rosetta. If you're a veteran Haskell developer, much of this won't apply to you as it's likely you already have a working development environment.
Here is a working set of versions you can use to build the Unison executable:
GHC version: 8.10.7
Stack version: 2.9.1
Cabal version 3.6.2.0
Haskell language server version: 1.7.0.0
The GHC version for the project can be confirmed by looking at the `resolver` key in this project's `stack.yaml`.
## Newcomer setup tips
[Install GHCup using the instructions on their website.](https://www.haskell.org/ghcup/) Once it's installed make sure `ghcup` is on your path.
```
export PATH="$HOME/.ghcup/bin:$PATH"
```
GHCup has a nice ui for setting Haskell toolchain versions for the project. Enter `ghcup tui` to open it up and follow the instructions for installing and setting the versions there. GHCup will try to download M1 native binaries for the versions given.
Check your clang version. For [hand-wavey reasons](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/301) we recommend you use llvm version 12. See troubleshooting note below about changing your LLVM if your version is different.
```shell
$ clang --version
Homebrew clang version 12.0.1
Target: arm64-apple-darwin20.2.0
Thread model: posix
InstalledDir: /opt/homebrew/opt/llvm@12/bin
```
At the end of the process you should see something like the following for executable locations and versions.
```shell
$ which ghcup
~/.ghcup/bin/ghcup
$ ghcup --version
The GHCup Haskell installer, version 0.1.19.0
```
```bash
$ which stack
~/.ghcup/bin/stack
$ stack --version
Version 2.9.1, Git revision 13c9c8772a6dce093dbeacc08bb5877bdb6cfc2e (dirty) (155 commits) aarch64
```
```shell
$ which ghc
~/.ghcup/bin/ghc
$ ghc --version
The Glorious Glasgow Haskell Compilation System, version 8.10.7
```
Check which GHC version Stack thinks it's using too, for good measure:
```shell
$ stack ghc -- --version
The Glorious Glasgow Haskell Compilation System, version 8.10.7
$ stack exec -- which ghc
~/.ghcup/ghc/8.10.7/bin/ghc
```
```shell
$ which haskell-language-server-wrapper
~/.ghcup/bin/haskell-language-server-wrapper
$ haskell-language-server-wrapper
Found "...unison/hie.yaml" for "...unison/a"
Run entered for haskell-language-server-wrapper(haskell-language-server-wrapper) Version 1.7.0.0 aarch64 ghc-9.2.2
Current directory: ...unison
Operating system: darwin
Arguments: []
Cradle directory: ...unison
Cradle type: Stack
Tool versions found on the $PATH
cabal: 3.6.2.0
stack: 2.9.1
ghc: 8.10.7
```
If you're a VS Code user, you can download the Haskell extension for IDE support. You may need to configure it in `settings.json`.
```json
"haskell.manageHLS": "GHCup",
"haskell.toolchain": {
"stack": "2.9.1",
"ghc": "8.10.7",
"cabal": "recommended",
"hls": "1.7.0.0"
}
```
These setting blocks say that the VS Code extension will use GHCup for your Haskell language server distribution, and sets the versions for elements in the toolchain.
## Troubleshooting:
The VS Code extension has compiled a helpful list of troubleshooting steps here: https://github.com/haskell/vscode-haskell#troubleshooting
### "Couldn't figure out LLVM version" or "failed to compile a sanity check" errors
```
<no location info>: error:
Warning: Couldn't figure out LLVM version!
Make sure you have installed LLVM between [9 and 13)
ghc: could not execute: opt
```
Or
```
ld: symbol(s) not found for architecture x86_64
clang: error: linker command failed with exit code 1 (use -v to see invocation)
`gcc' failed in phase `Linker'. (Exit code: 1)
```
Try installing llvm version 12
`brew install llvm@12`
and prepend it to your path
```
export PATH="$(brew --prefix)/opt/llvm@12/bin:$PATH"
```
(The GHC version 8.10.7 mentions it supports LLVM versions up to 12. https://www.haskell.org/ghc/download_ghc_8_10_7.html)
### "GHC ABIs don't match!"
Follow the steps here:
https://github.com/haskell/vscode-haskell#ghc-abis-dont-match
We found some success telling Stack to use the system's GHC instead of managing its own version of GHC. You can try this by setting the following two configuration flags in ~/.stack/config.yaml
```
system-ghc: true
install-ghc: false
```
This is telling Stack to use the GHC executable that it finds on your $PATH. Make sure the ghc being provided is the proper version, 8.10.7, from ghcup.
Note that you may need to clean the cache for the project after this failure with `stack clean --full` if you have previously built things with a different stack distribution.
### "stack" commands like "stack build" cause a segfault:
1. Make sure your stack state is clean. `stack clean --full` removes the project's stack work directories (things in .stack-work).
2. [Wait for this bug to be fixed (or help fix this bug!)](https://github.com/commercialhaskell/stack/issues/5607)
3. Or subshell out your stack commands `$(stack commandHere)`
4. Or use bash instead of zsh
### Help! Everything is broken and I want to start over
Warning, the following will remove ghcup, configuration files, cached packages, and versions of the toolchain.
```
ghcup nuke
rm -rf ~/.ghcup
rm -rf ~/.stack
rm -rf ~/.cabal
```

7
editor-support/vim/ftplugin/unison.vim
View File

@ -4,4 +4,9 @@ if exists("b:did_ftplugin")
endif
let b:did_ftplugin = 1
call unison#SetBufferDefaults()
setlocal commentstring=--\ %s
setlocal iskeyword+=!,'
" setlocal tabstop=2
" setlocal softtabstop=2
" setlocal shiftwidth=2
" setlocal completefunc=syntaxcomplete#Complete

140
editor-support/vim/syntax/unison.vim
View File

@ -17,7 +17,7 @@
" u_allow_hash_operator - Don't highlight seemingly incorrect C
" preprocessor directives but assume them to be
" operators
"
" 2023 Jan 6: Update for current syntax (dt)
" 2018 Aug 23: Adapt Haskell highlighting to Unison, cleanup.
" 2004 Feb 19: Added C preprocessor directive handling, corrected eol comments
" cleaned away literate unison support (should be entirely in
@ -34,20 +34,12 @@ elseif exists("b:current_syntax")
finish
endif
" (Qualified) identifiers (no default highlighting)
syn match ConId "\(\<[A-Z][a-zA-Z0-9_']*\.\)\=\<[A-Z][a-zA-Z0-9_']*\>"
syn match VarId "\(\<[A-Z][a-zA-Z0-9_']*\.\)\=\<[a-z][a-zA-Z0-9_']*\>"
syntax include @markdown $VIMRUNTIME/syntax/markdown.vim
" Infix operators--most punctuation characters and any (qualified) identifier
" enclosed in `backquotes`. An operator starting with : is a constructor,
" others are variables (e.g. functions).
syn match uVarSym "\(\<[A-Z][a-zA-Z0-9_']*\.\)\=[-!#$%&\*\+/<=>\?@\\^|~.][-!#$%&\*\+/<=>\?@\\^|~:.]*"
syn match uConSym "\(\<[A-Z][a-zA-Z0-9_']*\.\)\=:[-!#$%&\*\+./<=>\?@\\^|~:]*"
syn match uVarSym "`\(\<[A-Z][a-zA-Z0-9_']*\.\)\=[a-z][a-zA-Z0-9_']*`"
syn match uConSym "`\(\<[A-Z][a-zA-Z0-9_']*\.\)\=[A-Z][a-zA-Z0-9_']*`"
syn cluster markdownLikeDocs contains=markdownBold,markdownItalic,markdownLinkText,markdownListMarker,markdownOrderedListMarker,markdownH1,markdownH2,markdownH3,markdownH4,markdownH5,markdownH6
" Reserved symbols--cannot be overloaded.
syn match uDelimiter "(\|)\|\[\|\]\|,\|_\|{\|}"
syn match uOperator "[-!#$%&\*\+/<=>\?@\\^|~]"
syn match uDelimiter "[\[\](){},.]"
" Strings and constants
syn match uSpecialChar contained "\\\([0-9]\+\|o[0-7]\+\|x[0-9a-fA-F]\+\|[\"\\'&\\abfnrtv]\|^[A-Z^_\[\\\]]\)"
@ -62,45 +54,42 @@ syn match uFloat "\<[0-9]\+\.[0-9]\+\([eE][-+]\=[0-9]\+\)\=\>"
" Keyword definitions. These must be patterns instead of keywords
" because otherwise they would match as keywords at the start of a
" "literate" comment (see lu.vim).
syn match uModule "\<module\>"
syn match uModule "\<namespace\>"
syn match uImport "\<use\>"
syn match uInfix "\<\(infix\|infixl\|infixr\)\>"
syn match uTypedef "\<\(∀\|forall\)\>"
syn match uStatement "\<\(unique\|ability\|type\|where\|match\|cases\|;\|let\|with\|handle\)\>"
syn match uTypedef "\<\(unique\|structural\|∀\|forall\)\>"
syn match uStatement "\<\(ability\|do\|type\|where\|match\|cases\|;\|let\|with\|handle\)\>"
syn match uConditional "\<\(if\|else\|then\)\>"
" Not real keywords, but close.
if exists("u_highlight_boolean")
" Boolean constants from the standard prelude.
syn match uBoolean "\<\(true\|false\)\>"
endif
if exists("u_highlight_types")
" Primitive types from the standard prelude and libraries.
syn match uType "\<\(Float\|Nat\|Int\|Boolean\|Remote\|Text\)\>"
endif
if exists("u_highlight_more_types")
" Types from the standard prelude libraries.
syn match uType "\<\(Optional\|Either\|Sequence\|Effect\)\>"
syn match uMaybe "\<None\>"
syn match uExitCode "\<\(ExitSuccess\)\>"
syn match uOrdering "\<\(GT\|LT\|EQ\)\>"
endif
if exists("u_highlight_debug")
" Debugging functions from the standard prelude.
syn match uDebug "\<\(undefined\|error\|trace\)\>"
endif
syn match uBoolean "\<\(true\|false\)\>"
syn match uType "\<\C[A-Z][0-9A-Za-z_'!]*\>"
syn match uName "\<\C[a-z_][0-9A-Za-z_'!]*\>"
" Comments
syn match uLineComment "---*\([^-!#$%&\*\+./<=>\?@\\^|~].*\)\?$"
syn region uBlockComment start="{-" end="-}" contains=uBlockComment
syn region uPragma start="{-#" end="#-}"
syn region uBelowFold start="^---" skip="." end="." contains=uBelowFold
syn region uPragma start="{-#" end="#-}"
syn region uBelowFold start="^---" skip="." end="." contains=uBelowFold
" Docs
syn region uDocBlock start="\[:" end=":]" contains=uLink,uDocDirective
syn match uLink contained "@\([A-Z][a-zA-Z0-9_']*\.\)\=\<[a-z][a-zA-Z0-9_'.]*\>"
syn match uDocDirective contained "@\[\([A-Z][a-zA-Z0-9_']*\.\)\=\<[a-z][a-zA-Z0-9_'.]*\>] \(\<[A-Z][a-zA-Z0-9_']*\.\)\=\<[a-z][a-zA-Z0-9_'.]*\>"
syn region uDocBlock matchgroup=unisonDoc start="{{" end="}}" contains=uDocTypecheck,uDocQuasiquote,uDocDirective,uDocCode,uDocCodeInline,uDocCodeRaw,uDocMono,@markdownLikeDocs
syn region uDocQuasiquote contained matchgroup=unisonDocQuote start="{{" end= "}}" contains=TOP
syn region uDocCode contained matchgroup=unisonDocCode start="^\s*```\s*$" end="^\s*```\s*$" contains=TOP
syn region uDocTypecheck contained matchgroup=unisonDocCode start="^\s*@typecheck\s*```\s*$" end="^\s*```\s*$" contains=TOP
syn region uDocCodeRaw contained matchgroup=unisonDocCode start="^\s*```\s*raw\s*$" end="^\s*```\s*$" contains=NoSyntax
syn region uDocCodeInline contained matchgroup=unisonDocCode start="`\@<!``" end="`\@<!``" contains=TOP
syn match uDocMono "''[^']*''"
syn region uDocDirective contained matchgroup=unisonDocDirective start="\(@\([a-zA-Z0-9_']*\)\)\?{{\@!" end="}" contains=TOP
syn match uDebug "\<\(todo\|bug\|Debug.trace\)\>"
" things like
" > my_func 1 3
" test> Function.tap.tests.t1 = check let
" use Nat == +
" ( 99, 100 ) === (withInitialValue 0 do
" : : :
syn match uWatch "^[A-Za-z]*>"
" Define the default highlighting.
" For version 5.7 and earlier: only when not done already
@ -112,40 +101,41 @@ if version >= 508 || !exists("did_u_syntax_inits")
else
command -nargs=+ HiLink hi def link <args>
endif
HiLink uWatch Debug
HiLink uDocMono Delimiter
HiLink unisonDocDirective Import
HiLink unisonDocQuote Delimiter
HiLink unisonDocCode Delimiter
HiLink unisonDoc String
HiLink uBelowFold Comment
HiLink uBlockComment Comment
HiLink uBoolean Boolean
HiLink uCharacter Character
HiLink uComment Comment
HiLink uConditional Conditional
HiLink uConditional Conditional
HiLink uDebug Debug
HiLink uDelimiter Delimiter
HiLink uDocBlock String
HiLink uDocDirective Import
HiLink uDocIncluded Import
HiLink uFloat Float
HiLink uImport Include
HiLink uLineComment Comment
HiLink uLink Type
HiLink uName Identifier
HiLink uNumber Number
HiLink uOperator Operator
HiLink uPragma SpecialComment
HiLink uSpecialChar SpecialChar
HiLink uSpecialCharError Error
HiLink uStatement Statement
HiLink uString String
HiLink uType Type
HiLink uTypedef Typedef
HiLink uImport Include
HiLink uInfix PreProc
HiLink uStatement Statement
HiLink uConditional Conditional
HiLink uSpecialChar SpecialChar
HiLink uTypedef Typedef
HiLink uVarSym uOperator
HiLink uConSym uOperator
HiLink uOperator Operator
HiLink uDelimiter Delimiter
HiLink uSpecialCharError Error
HiLink uString String
HiLink uCharacter Character
HiLink uNumber Number
HiLink uFloat Float
HiLink uConditional Conditional
HiLink uLiterateComment uComment
HiLink uBlockComment uComment
HiLink uLineComment uComment
HiLink uComment Comment
HiLink uBelowFold Comment
HiLink uDocBlock String
HiLink uLink uType
HiLink uDocDirective uImport
HiLink uPragma SpecialComment
HiLink uBoolean Boolean
HiLink uType Type
HiLink uMaybe uEnumConst
HiLink uOrdering uEnumConst
HiLink uEnumConst Constant
HiLink uDebug Debug
delcommand HiLink
delcommand HiLink
endif

43
flake.lock Normal file
View File

@ -0,0 +1,43 @@
{
"nodes": {
"flake-utils": {
"locked": {
"lastModified": 1667395993,
"narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1678703398,
"narHash": "sha256-Y1mW3dBsoWLHpYm+UIHb5VZ7rx024NNHaF16oZBx++o=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "67f26c1cfc5d5783628231e776a81c1ade623e0b",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "nixos-22.11",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"flake-utils": "flake-utils",
"nixpkgs": "nixpkgs"
}
}
},
"root": "root",
"version": 7
}

149
flake.nix Normal file
View File

@ -0,0 +1,149 @@
{
description = "A common environment for unison development";
inputs = {
flake-utils.url = "github:numtide/flake-utils";
nixpkgs.url = "github:NixOS/nixpkgs/nixos-22.11";
};
outputs = { self, flake-utils, nixpkgs }:
let
ghc-version = "8107";
systemAttrs = flake-utils.lib.eachDefaultSystem (system:
let
pkgs = nixpkgs.legacyPackages."${system}".extend self.overlay;
ghc-version = "8107";
ghc = pkgs.haskell.packages."ghc${ghc-version}";
nativePackages = pkgs.lib.optionals pkgs.stdenv.isDarwin
(with pkgs.darwin.apple_sdk.frameworks; [ Cocoa ]);
unison-env = pkgs.mkShell {
packages = let exports = self.packages."${system}";
in with pkgs;
[
exports.stack
exports.hls
exports.ormolu
exports.ghc
pkg-config
zlib
] ++ nativePackages;
# workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/11042
shellHook = ''
export LD_LIBRARY_PATH=${pkgs.zlib}/lib:$LD_LIBRARY_PATH
'';
};
in {
apps.repl = flake-utils.lib.mkApp {
drv =
nixpkgs.legacyPackages."${system}".writeShellScriptBin "repl" ''
confnix=$(mktemp)
echo "builtins.getFlake (toString $(git rev-parse --show-toplevel))" >$confnix
trap "rm $confnix" EXIT
nix repl $confnix
'';
};
pkgs = pkgs;
devShells.default = unison-env;
packages = {
hls = pkgs.unison-hls;
hls-call-hierarchy-plugin = ghc.hls-call-hierarchy-plugin;
ormolu = pkgs.ormolu;
ghc = pkgs.haskell.compiler."ghc${ghc-version}".override {
useLLVM = pkgs.stdenv.isAarch64;
};
stack = pkgs.unison-stack;
devShell = self.devShells."${system}".default;
};
defaultPackage = self.packages."${system}".devShell;
});
topLevelAttrs = {
overlay = final: prev: {
ormolu = prev.haskell.lib.justStaticExecutables
final.haskell.packages."ghc${ghc-version}".ormolu;
haskell = with prev.haskell.lib;
prev.haskell // {
packages = prev.haskell.packages // {
"ghc${ghc-version}" = prev.haskell.packages.ghc8107.extend
(hfinal: hprev: {
mkDerivation = drv:
hprev.mkDerivation (drv // {
doCheck = false;
doHaddock = false;
doBenchmark = false;
enableLibraryProfiling = false;
enableExecutableProfiling = false;
});
aeson = hfinal.aeson_2_1_1_0;
lens-aeson = hfinal.lens-aeson_1_2_2;
Cabal = hfinal.Cabal_3_6_3_0;
ormolu = hfinal.ormolu_0_5_0_1;
ghc-lib-parser = hfinal.ghc-lib-parser_9_2_5_20221107;
# avoid deprecated version https://github.com/Avi-D-coder/implicit-hie/issues/50
implicit-hie = hfinal.callHackageDirect {
pkg = "implicit-hie";
ver = "0.1.4.0";
sha256 =
"15qy9vwm8vbnyv47vh6kd50m09vc4vhqbbrhf8gdifrvlxhad69l";
} { };
haskell-language-server = let
p = prev.haskell.lib.overrideCabal
hprev.haskell-language-server (drv: {
# undo terrible nixpkgs hacks
buildDepends =
prev.lib.filter (x: x != hprev.hls-brittany-plugin)
drv.buildDepends;
configureFlags = drv.configureFlags ++ [
"-f-brittany"
"-f-fourmolu"
"-f-floskell"
"-f-stylishhaskell"
"-f-hlint"
];
});
in p.overrideScope (lfinal: lprev: {
# undo all of the horrible overrideScope in
# nixpkgs configuration files
ormolu = hfinal.ormolu;
ghc-lib-parser = hfinal.ghc-lib-parser;
ghc-lib-parser-ex = hfinal.ghc-lib-parser-ex;
ghc-paths = hfinal.ghc-paths;
aeson = hfinal.aeson;
lsp-types = hfinal.lsp-types;
# null out some dependencies that we drop with cabal flags
hls-fourmolu-plugin = null;
hls-floskell-plugin = null;
hls-brittany-plugin = hfinal.hls-brittany-plugin;
hls-stylish-haskell-plugin = null;
hls-hlint-plugin = null;
});
});
};
};
unison-hls = final.haskell-language-server.override {
haskellPackages = final.haskell.packages."ghc${ghc-version}";
dynamic = true;
supportedGhcVersions = [ ghc-version ];
};
unison-stack = prev.symlinkJoin {
name = "stack";
paths = [ final.stack ];
buildInputs = [ final.makeWrapper ];
postBuild = let
flags = [ "--no-nix" "--system-ghc" "--no-install-ghc" ];
add-flags =
"--add-flags '${prev.lib.concatStringsSep " " flags}'";
in ''
wrapProgram "$out/bin/stack" ${add-flags}
'';
};
};
};
in systemAttrs // topLevelAttrs;
}

18
hie.yaml
View File

@ -21,6 +21,18 @@ cradle:
- path: "codebase2/util-term/./"
component: "unison-util-term:lib"
- path: "lib/unison-hash/src"
component: "unison-hash:lib"
- path: "lib/unison-hash-orphans-aeson/src"
component: "unison-hash-orphans-aeson:lib"
- path: "lib/unison-hash-orphans-sqlite/src"
component: "unison-hash-orphans-sqlite:lib"
- path: "lib/unison-hashing/src"
component: "unison-hashing:lib"
- path: "lib/unison-prelude/src"
component: "unison-prelude:lib"
@ -39,12 +51,6 @@ cradle:
- path: "lib/unison-util-base32hex/src"
component: "unison-util-base32hex:lib"
- path: "lib/unison-util-base32hex-orphans-aeson/src"
component: "unison-util-base32hex-orphans-aeson:lib"
- path: "lib/unison-util-base32hex-orphans-sqlite/src"
component: "unison-util-base32hex-orphans-sqlite:lib"
- path: "lib/unison-util-bytes/src"
component: "unison-util-bytes:lib"

5
lib/unison-util-base32hex-orphans-aeson/package.yaml → lib/unison-hash-orphans-aeson/package.yaml
View File

@ -1,17 +1,18 @@
name: unison-util-base32hex-orphans-aeson
name: unison-hash-orphans-aeson
github: unisonweb/unison
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
library:
when:
- condition: false
other-modules: Paths_unison_util_base32hex_orphans_aeson
other-modules: Paths_unison_hash_orphans_aeson
source-dirs: src
dependencies:
- aeson
- base
- text
- unison-hash
- unison-util-base32hex
ghc-options:

4
lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs → lib/unison-hash-orphans-aeson/src/Unison/Hash32/Orphans/Aeson.hs
View File

@ -1,11 +1,11 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module U.Util.Hash32.Orphans.Aeson () where
module Unison.Hash32.Orphans.Aeson () where
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
import Data.Text (Text)
import U.Util.Base32Hex (Base32Hex (..))
import U.Util.Hash32 (Hash32 (..))
import Unison.Hash32 (Hash32 (..))
deriving via Text instance FromJSON Hash32

5
lib/unison-util-base32hex-orphans-aeson/unison-util-base32hex-orphans-aeson.cabal → lib/unison-hash-orphans-aeson/unison-hash-orphans-aeson.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
name: unison-util-base32hex-orphans-aeson
name: unison-hash-orphans-aeson
version: 0.0.0
homepage: https://github.com/unisonweb/unison#readme
bug-reports: https://github.com/unisonweb/unison/issues
@ -17,7 +17,7 @@ source-repository head
library
exposed-modules:
U.Util.Hash32.Orphans.Aeson
Unison.Hash32.Orphans.Aeson
hs-source-dirs:
src
default-extensions:
@ -49,5 +49,6 @@ library
aeson
, base
, text
, unison-hash
, unison-util-base32hex
default-language: Haskell2010

5
lib/unison-util-base32hex-orphans-sqlite/package.yaml → lib/unison-hash-orphans-sqlite/package.yaml
View File

@ -1,17 +1,18 @@
name: unison-util-base32hex-orphans-sqlite
name: unison-hash-orphans-sqlite
github: unisonweb/unison
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
library:
when:
- condition: false
other-modules: Paths_unison_util_base32hex_orphans_sqlite
other-modules: Paths_unison_hash_orphans_sqlite
source-dirs: src
dependencies:
- base
- sqlite-simple
- text
- unison-hash
- unison-util-base32hex
ghc-options:

4
lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs → lib/unison-hash-orphans-sqlite/src/Unison/Hash32/Orphans/Sqlite.hs
View File

@ -1,12 +1,12 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module U.Util.Hash32.Orphans.Sqlite () where
module Unison.Hash32.Orphans.Sqlite () where
import Data.Text (Text)
import Database.SQLite.Simple.FromField (FromField)
import Database.SQLite.Simple.ToField (ToField)
import U.Util.Base32Hex (Base32Hex (..))
import U.Util.Hash32 (Hash32 (..))
import Unison.Hash32 (Hash32 (..))
deriving via Text instance ToField Hash32

5
lib/unison-util-base32hex-orphans-sqlite/unison-util-base32hex-orphans-sqlite.cabal → lib/unison-hash-orphans-sqlite/unison-hash-orphans-sqlite.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
name: unison-util-base32hex-orphans-sqlite
name: unison-hash-orphans-sqlite
version: 0.0.0
homepage: https://github.com/unisonweb/unison#readme
bug-reports: https://github.com/unisonweb/unison/issues
@ -17,7 +17,7 @@ source-repository head
library
exposed-modules:
U.Util.Hash32.Orphans.Sqlite
Unison.Hash32.Orphans.Sqlite
hs-source-dirs:
src
default-extensions:
@ -49,5 +49,6 @@ library
base
, sqlite-simple
, text
, unison-hash
, unison-util-base32hex
default-language: Haskell2010

46
lib/unison-hash/package.yaml Normal file
View File

@ -0,0 +1,46 @@
name: unison-hash
github: unisonweb/unison
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures
dependencies:
- base
- bytestring
- text
- unison-prelude
- unison-util-base32hex
library:
source-dirs: src
when:
- condition: false
other-modules: Paths_unison_hash
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- DeriveAnyClass
- DeriveFunctor
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- DerivingVia
- DoAndIfThenElse
- DuplicateRecordFields
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
- OverloadedStrings
- PatternSynonyms
- RankNTypes
- ScopedTypeVariables
- StandaloneDeriving
- TupleSections
- TypeApplications
- TypeFamilies
- ViewPatterns

92
lib/unison-util-base32hex/src/U/Util/Hash.hs → lib/unison-hash/src/Unison/Hash.hs
View File

@ -1,59 +1,67 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module U.Util.Hash
( Hash (Hash, toShort),
unsafeFromBase32HexText,
fromBase32HexText,
fromBase32Hex,
fromByteString,
toBase32Hex,
toBase32HexText,
toByteString,
module Unison.Hash
( Hash (Hash),
HashFor (..),
-- ** ShortByteString conversions
toShort,
-- ** ByteString conversions
fromByteString,
toByteString,
-- ** Base32Hex conversions
fromBase32Hex,
toBase32Hex,
-- ** Base32Hex Text conversions
fromBase32HexText,
unsafeFromBase32HexText,
toBase32HexText,
)
where
import Data.ByteString (ByteString)
import Data.ByteString.Short (ShortByteString, fromShort)
import Data.ByteString.Short (ShortByteString)
import qualified Data.ByteString.Short as B.Short
import Data.Text (Text)
import GHC.Generics (Generic)
import U.Util.Base32Hex (Base32Hex)
import qualified U.Util.Base32Hex as Base32Hex
import Unison.Prelude
-- | Hash which uniquely identifies a Unison type or term
newtype Hash = Hash {toShort :: ShortByteString} deriving (Eq, Ord, Generic)
-- | A hash.
newtype Hash = Hash {toShort :: ShortByteString}
deriving stock (Eq, Ord, Generic)
toBase32Hex :: Hash -> Base32Hex
toBase32Hex = Base32Hex.fromByteString . toByteString
instance Show Hash where
show = show . toBase32HexText
toBase32HexText :: Hash -> Text
toBase32HexText = Base32Hex.toText . toBase32Hex
fromBase32Hex :: Base32Hex -> Hash
fromBase32Hex = Hash . B.Short.toShort . Base32Hex.toByteString
-- | Constructs a hash from base32 checks without any validation.
-- Note that this converts Text -> ByteString -> ShortByteString and so is slower than
-- we'd prefer.
unsafeFromBase32HexText :: Text -> Hash
unsafeFromBase32HexText = fromBase32Hex . Base32Hex.UnsafeFromText
fromBase32HexText :: Text -> Maybe Hash
fromBase32HexText = fmap fromBase32Hex . Base32Hex.fromText
-- | A hash tagged with the type it's a hash of, useful for maintaining type safety guarantees.
newtype HashFor t = HashFor {genericHash :: Hash}
deriving newtype (Show, Eq, Ord, Generic)
-- | Convert a hash to a byte string.
toByteString :: Hash -> ByteString
toByteString = fromShort . toShort
toByteString = B.Short.fromShort . toShort
-- | Convert a byte string to a hash.
fromByteString :: ByteString -> Hash
fromByteString = Hash . B.Short.toShort
instance Show Hash where
show h = (show . toBase32HexText) h
-- | Convert base32 hex to a hash.
fromBase32Hex :: Base32Hex -> Hash
fromBase32Hex = fromByteString . Base32Hex.toByteString
-- | A hash tagged with the type it's a hash of, useful for maintaining type safety
-- guarantees.
newtype HashFor t = HashFor {genericHash :: Hash}
deriving newtype (Show, Eq, Ord, Generic)
-- | Convert a hash to base32 hex.
toBase32Hex :: Hash -> Base32Hex
toBase32Hex = Base32Hex.fromByteString . toByteString
-- | Produce a 'Hash' from a base32hex-encoded version of its binary representation
fromBase32HexText :: Text -> Maybe Hash
fromBase32HexText = fmap fromBase32Hex . Base32Hex.fromText
-- | Convert a hash from base32 hex without any validation.
unsafeFromBase32HexText :: Text -> Hash
unsafeFromBase32HexText = fromBase32Hex . Base32Hex.UnsafeFromText
-- | Return the lowercase unpadded base32Hex encoding of this 'Hash'.
-- Multibase prefix would be 'v', see https://github.com/multiformats/multibase
toBase32HexText :: Hash -> Text
toBase32HexText = Base32Hex.toText . toBase32Hex

6
lib/unison-util-base32hex/src/U/Util/Hash32.hs → lib/unison-hash/src/Unison/Hash32.hs
View File

@ -1,5 +1,5 @@
-- | A 512-bit hash, internally represented as base32hex.
module U.Util.Hash32
module Unison.Hash32
( -- * Hash32 type
Hash32 (..),
@ -19,8 +19,8 @@ module U.Util.Hash32
where
import U.Util.Base32Hex (Base32Hex (..))
import U.Util.Hash (Hash)
import qualified U.Util.Hash as Hash
import Unison.Hash (Hash)
import qualified Unison.Hash as Hash
import Unison.Prelude
-- | A 512-bit hash, internally represented as base32hex.

58
lib/unison-hash/unison-hash.cabal Normal file
View File

@ -0,0 +1,58 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
--
-- see: https://github.com/sol/hpack
name: unison-hash
version: 0.0.0
homepage: https://github.com/unisonweb/unison#readme
bug-reports: https://github.com/unisonweb/unison/issues
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
build-type: Simple
source-repository head
type: git
location: https://github.com/unisonweb/unison
library
exposed-modules:
Unison.Hash
Unison.Hash32
hs-source-dirs:
src
default-extensions:
ApplicativeDo
BangPatterns
BlockArguments
DeriveAnyClass
DeriveFunctor
DeriveGeneric
DeriveTraversable
DerivingStrategies
DerivingVia
DoAndIfThenElse
DuplicateRecordFields
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
OverloadedStrings
PatternSynonyms
RankNTypes
ScopedTypeVariables
StandaloneDeriving
TupleSections
TypeApplications
TypeFamilies
ViewPatterns
ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures
build-depends:
base
, bytestring
, text
, unison-prelude
, unison-util-base32hex
default-language: Haskell2010

43
lib/unison-hashing/package.yaml Normal file
View File

@ -0,0 +1,43 @@
name: unison-hashing
github: unisonweb/unison
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures
dependencies:
- base
- unison-hash
library:
source-dirs: src
when:
- condition: false
other-modules: Paths_unison_hashing
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- DeriveAnyClass
- DeriveFunctor
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- DerivingVia
- DoAndIfThenElse
- DuplicateRecordFields
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
- OverloadedStrings
- PatternSynonyms
- RankNTypes
- ScopedTypeVariables
- StandaloneDeriving
- TupleSections
- TypeApplications
- TypeFamilies
- ViewPatterns

39
lib/unison-hashing/src/Unison/Hashing/ContentAddressable.hs Normal file
View File

@ -0,0 +1,39 @@
module Unison.Hashing.ContentAddressable
( ContentAddressable (..),
)
where
import Unison.Hash (Hash)
-- | A type class that is inhabited by types that can compute a hash of their content.
--
-- The base instances of this class should only live in dedicated "hashing packages" such as @unison-hashing-v2@, whose
-- types and implementations should never change.
--
-- Trivial wrapper instances can be written around these, but note these pipelines from
-- @MyType ==> SomeHashingType ==> Hash@ must take care not to change the @MyType ==> SomeHashingType@ conversion, once
-- written.
--
-- For example, we might have a representation of some namespace in memory
--
-- @
-- data Namespace = Namespace Terms Types OtherStuff CachesAndWhatnot
-- @
--
-- with a somewhat equivalent "hashing" type in some "hashing package", with a ContentAddressable instance
--
-- @
-- data HashingNamespace = Namespace Terms Types
-- @
--
-- We can of course make our own convenience instance
--
-- @
-- instance ContentAddressable Namespace where
-- contentHash = contentHash . namespaceToHashingNamespace
-- @
--
-- But we must make sure that the implementation of @namespaceToHashingNamespace@ never changes the fields in the
-- corresponding @HashingNamespace@, even as features are added to or removed from @Namespace@.
class ContentAddressable a where
contentHash :: a -> Hash

54
lib/unison-hashing/unison-hashing.cabal Normal file
View File

@ -0,0 +1,54 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
--
-- see: https://github.com/sol/hpack
name: unison-hashing
version: 0.0.0
homepage: https://github.com/unisonweb/unison#readme
bug-reports: https://github.com/unisonweb/unison/issues
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
build-type: Simple
source-repository head
type: git
location: https://github.com/unisonweb/unison
library
exposed-modules:
Unison.Hashing.ContentAddressable
hs-source-dirs:
src
default-extensions:
ApplicativeDo
BangPatterns
BlockArguments
DeriveAnyClass
DeriveFunctor
DeriveGeneric
DeriveTraversable
DerivingStrategies
DerivingVia
DoAndIfThenElse
DuplicateRecordFields
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
OverloadedStrings
PatternSynonyms
RankNTypes
ScopedTypeVariables
StandaloneDeriving
TupleSections
TypeApplications
TypeFamilies
ViewPatterns
ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures
build-depends:
base
, unison-hash
default-language: Haskell2010

3
lib/unison-prelude/src/U/Util/Text.hs
View File

@ -21,7 +21,8 @@ import Safe.Foldable (minimumMay)
stripMargin :: Text -> Text
stripMargin str =
let stripLen =
Data.Maybe.fromMaybe 0 . minimumMay
Data.Maybe.fromMaybe 0
. minimumMay
. map (Text.length . fst . Text.span (== ' '))
. filter (not . Text.all (Char.isSpace))
$ Text.lines str

26
lib/unison-prelude/src/Unison/Debug.hs
View File

@ -37,6 +37,10 @@ data DebugFlag
| -- | Useful for adding temporary debugging statements during development.
-- Remove uses of Debug.Temp before merging to keep things clean for the next person :)
Temp
| -- | Shows Annotations when printing terms
Annotations
| PatternCoverage
| PatternCoverageConstraintSolver
deriving (Eq, Ord, Show, Bounded, Enum)
debugFlags :: Set DebugFlag
@ -58,6 +62,9 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of
"LSP" -> pure LSP
"TIMING" -> pure Timing
"TEMP" -> pure Temp
"ANNOTATIONS" -> pure Annotations
"PATTERN_COVERAGE" -> pure PatternCoverage
"PATTERN_COVERAGE_CONSTRAINT_SOLVER" -> pure PatternCoverageConstraintSolver
_ -> empty
{-# NOINLINE debugFlags #-}
@ -101,13 +108,25 @@ debugTemp :: Bool
debugTemp = Temp `Set.member` debugFlags
{-# NOINLINE debugTemp #-}
debugAnnotations :: Bool
debugAnnotations = Annotations `Set.member` debugFlags
{-# NOINLINE debugAnnotations #-}
debugPatternCoverage :: Bool
debugPatternCoverage = PatternCoverage `Set.member` debugFlags
{-# NOINLINE debugPatternCoverage #-}
debugPatternCoverageConstraintSolver :: Bool
debugPatternCoverageConstraintSolver = PatternCoverageConstraintSolver `Set.member` debugFlags
{-# NOINLINE debugPatternCoverageConstraintSolver #-}
-- | Use for trace-style selective debugging.
-- E.g. 1 + (debug Git "The second number" 2)
--
-- Or, use in pattern matching to view arguments.
-- E.g.
-- myFunc (debug Git "argA" -> argA) = ...
debug :: Show a => DebugFlag -> String -> a -> a
debug :: (Show a) => DebugFlag -> String -> a -> a
debug flag msg a =
if shouldDebug flag
then pTraceShowId (pTrace (msg <> ":\n") a)
@ -135,7 +154,7 @@ debugLogM flag msg =
whenDebug flag $ pTraceM msg
-- | A 'when' block which is triggered if the given flag is being debugged.
whenDebug :: Monad m => DebugFlag -> m () -> m ()
whenDebug :: (Monad m) => DebugFlag -> m () -> m ()
whenDebug flag action = do
when (shouldDebug flag) action
@ -151,3 +170,6 @@ shouldDebug = \case
LSP -> debugLSP
Timing -> debugTiming
Temp -> debugTemp
Annotations -> debugAnnotations
PatternCoverage -> debugPatternCoverage
PatternCoverageConstraintSolver -> debugPatternCoverageConstraintSolver

24
lib/unison-prelude/src/Unison/Prelude.hs
View File

@ -89,43 +89,43 @@ altMap f = altSum . fmap f . toList
-- @@
-- onNothing (throwIO MissingPerson) $ mayThing
-- @@
onNothing :: Applicative m => m a -> Maybe a -> m a
onNothing :: (Applicative m) => m a -> Maybe a -> m a
onNothing m may = maybe m pure may
onNothingM :: Monad m => m a -> m (Maybe a) -> m a
onNothingM :: (Monad m) => m a -> m (Maybe a) -> m a
onNothingM =
flip whenNothingM
-- | E.g. @maybePerson `whenNothing` throwIO MissingPerson@
whenNothing :: Applicative m => Maybe a -> m a -> m a
whenNothing :: (Applicative m) => Maybe a -> m a -> m a
whenNothing may m = maybe m pure may
whenNothingM :: Monad m => m (Maybe a) -> m a -> m a
whenNothingM :: (Monad m) => m (Maybe a) -> m a -> m a
whenNothingM mx my =
mx >>= maybe my pure
whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
whenJust :: (Applicative m) => Maybe a -> (a -> m ()) -> m ()
whenJust mx f =
maybe (pure ()) f mx
whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m ()
whenJustM :: (Monad m) => m (Maybe a) -> (a -> m ()) -> m ()
whenJustM mx f = do
mx >>= maybe (pure ()) f
onLeft :: Applicative m => (a -> m b) -> Either a b -> m b
onLeft :: (Applicative m) => (a -> m b) -> Either a b -> m b
onLeft =
flip whenLeft
onLeftM :: Monad m => (a -> m b) -> m (Either a b) -> m b
onLeftM :: (Monad m) => (a -> m b) -> m (Either a b) -> m b
onLeftM =
flip whenLeftM
whenLeft :: Applicative m => Either a b -> (a -> m b) -> m b
whenLeft :: (Applicative m) => Either a b -> (a -> m b) -> m b
whenLeft = \case
Left a -> \f -> f a
Right b -> \_ -> pure b
whenLeftM :: Monad m => m (Either a b) -> (a -> m b) -> m b
whenLeftM :: (Monad m) => m (Either a b) -> (a -> m b) -> m b
whenLeftM m f =
m >>= \case
Left x -> f x
@ -146,7 +146,7 @@ throwEitherM = throwEitherMWith id
throwEitherMWith :: forall e e' m a. (MonadIO m, Exception e') => (e -> e') -> m (Either e a) -> m a
throwEitherMWith f action = throwExceptT . withExceptT f $ (ExceptT action)
tShow :: Show a => a -> Text
tShow :: (Show a) => a -> Text
tShow = Text.pack . show
-- | Strictly read an entire file decoding UTF8.
@ -206,5 +206,5 @@ reportBug bugId msg =
]
{-# WARNING wundefined "You left this wundefined." #-}
wundefined :: HasCallStack => a
wundefined :: (HasCallStack) => a
wundefined = undefined

6
lib/unison-prelude/src/Unison/Util/Alternative.hs
View File

@ -1,6 +1,7 @@
module Unison.Util.Alternative
( whenM
) where
( whenM,
)
where
import Control.Applicative (Alternative (empty))
@ -8,4 +9,3 @@ whenM :: (Monad m, Alternative m) => m Bool -> a -> m a
whenM m a = do
b <- m
if b then pure a else empty

10
lib/unison-prelude/src/Unison/Util/Map.hs
View File

@ -25,7 +25,7 @@ import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Unison.Prelude
bimap :: Ord a' => (a -> a') -> (b -> b') -> Map a b -> Map a' b'
bimap :: (Ord a') => (a -> a') -> (b -> b') -> Map a b -> Map a' b'
bimap fa fb = Map.fromList . map (B.bimap fa fb) . Map.toList
bitraverse :: (Applicative f, Ord a') => (a -> f a') -> (b -> f b') -> Map a b -> f (Map a' b')
@ -36,12 +36,12 @@ bitraversed keyT valT f m =
bitraverse (keyT f) (valT f) m
-- | 'swap' throws away data if the input contains duplicate values
swap :: Ord b => Map a b -> Map b a
swap :: (Ord b) => Map a b -> Map b a
swap =
Map.foldlWithKey' (\z a b -> Map.insert b a z) mempty
-- | Upsert an element into a map.
upsert :: Ord k => (Maybe v -> v) -> k -> Map k v -> Map k v
upsert :: (Ord k) => (Maybe v -> v) -> k -> Map k v -> Map k v
upsert f =
Map.alter (Just . f)
@ -50,7 +50,7 @@ valuesVector =
Vector.fromList . Map.elems
-- | Like 'Map.delete', but returns the value as well.
deleteLookup :: Ord k => k -> Map k v -> (Maybe v, Map k v)
deleteLookup :: (Ord k) => k -> Map k v -> (Maybe v, Map k v)
deleteLookup =
Map.alterF (,Nothing)
@ -85,7 +85,7 @@ unionWithM f m1 m2 =
-- @
-- remap f = Map.fromList . map f . Map.toList
-- @
remap :: Ord k1 => ((k0, v0) -> (k1, v1)) -> Map k0 v0 -> Map k1 v1
remap :: (Ord k1) => ((k0, v0) -> (k1, v1)) -> Map k0 v0 -> Map k1 v1
remap f =
Map.fromList . map f . Map.toList

4
lib/unison-prelude/src/Unison/Util/Monoid.hs
View File

@ -22,11 +22,11 @@ intercalateMap separator renderer elements =
intercalateMapM :: (Traversable t, Monad m, Monoid a) => a -> (b -> m a) -> t b -> m a
intercalateMapM separator renderer = traverse renderer >=> return . intercalateMap separator id
fromMaybe :: Monoid a => Maybe a -> a
fromMaybe :: (Monoid a) => Maybe a -> a
fromMaybe Nothing = mempty
fromMaybe (Just a) = a
whenM, unlessM :: Monoid a => Bool -> a -> a
whenM, unlessM :: (Monoid a) => Bool -> a -> a
whenM True a = a
whenM False _ = mempty
unlessM = whenM . not

8
lib/unison-prelude/src/Unison/Util/Set.hs
View File

@ -21,22 +21,22 @@ asSingleton xs =
if Set.size xs == 1 then Just (Set.findMin xs) else Nothing
-- | Set difference, but return @Nothing@ if the difference is empty.
difference1 :: Ord a => Set a -> Set a -> Maybe (Set a)
difference1 :: (Ord a) => Set a -> Set a -> Maybe (Set a)
difference1 xs ys =
if null zs then Nothing else Just zs
where
zs = Set.difference xs ys
symmetricDifference :: Ord a => Set a -> Set a -> Set a
symmetricDifference :: (Ord a) => Set a -> Set a -> Set a
symmetricDifference a b = (a `Set.difference` b) `Set.union` (b `Set.difference` a)
mapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b
mapMaybe :: (Ord b) => (a -> Maybe b) -> Set a -> Set b
mapMaybe f = Set.fromList . Maybe.mapMaybe f . Set.toList
traverse :: (Applicative f, Ord b) => (a -> f b) -> Set a -> f (Set b)
traverse f = fmap Set.fromList . Prelude.traverse f . Set.toList
flatMap :: Ord b => (a -> Set b) -> Set a -> Set b
flatMap :: (Ord b) => (a -> Set b) -> Set a -> Set b
flatMap f = Set.unions . fmap f . Set.toList
filterM :: (Ord a, Monad m) => (a -> m Bool) -> Set a -> m (Set a)

4
lib/unison-prelude/src/Unison/Util/Timing.hs
View File

@ -12,7 +12,7 @@ import System.IO.Unsafe (unsafePerformIO)
import qualified Unison.Debug as Debug
import UnliftIO (MonadIO, liftIO)
time :: MonadIO m => String -> m a -> m a
time :: (MonadIO m) => String -> m a -> m a
time label ma =
if Debug.shouldDebug Debug.Timing
then do
@ -29,7 +29,7 @@ time label ma =
else ma
-- Mitchell says: this function doesn't look like it would work at all; let's just delete it
unsafeTime :: Monad m => String -> m a -> m a
unsafeTime :: (Monad m) => String -> m a -> m a
unsafeTime label ma =
if Debug.shouldDebug Debug.Timing
then do

8
lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs
View File

@ -182,10 +182,10 @@ snipWithContext margin source =
text', text2' :: [String]
(text', text2') =
splitAt takeLineCount (drop dropLineCount (lines (text source)))
in AnnotatedExcerpt startLine' (unlines text') group' :
snipWithContext
margin
(AnnotatedExcerpt (endLine' + 1) (unlines text2') rest')
in AnnotatedExcerpt startLine' (unlines text') group'
: snipWithContext
margin
(AnnotatedExcerpt (endLine' + 1) (unlines text2') rest')
where
withinMargin :: Range -> Range -> Bool
withinMargin (Range _start1 (Pos end1 _)) (Range (Pos start2 _) _end2) =

2
lib/unison-pretty-printer/src/Unison/Util/Less.hs
View File

@ -48,7 +48,7 @@ less str = do
lessArgs :: [String]
lessArgs =
[ "--no-init", -- don't clear the screen on exit
"--raw-control-chars", -- pass through colors and stuff
"--RAW-CONTROL-CHARS", -- pass through colors and stuff
"--prompt=[less] Use space/arrow keys to navigate, or 'q' to return to ucm:",
"--quit-if-one-screen" -- self-explanatory
]

58
lib/unison-pretty-printer/src/Unison/Util/Pretty.hs
View File

@ -187,7 +187,7 @@ data F s r
| Append (Seq r)
deriving (Eq, Show, Foldable, Traversable, Functor)
isEmpty :: Eq s => IsString s => Pretty s -> Bool
isEmpty :: (Eq s) => (IsString s) => Pretty s -> Bool
isEmpty s = out s == Empty || out s == Lit ""
mapLit :: (s -> t) -> F s r -> F t r
@ -211,7 +211,7 @@ orElses :: [Pretty s] -> Pretty s
orElses [] = mempty
orElses ps = foldr1 orElse ps
wrapImpl :: IsString s => [Pretty s] -> Pretty s
wrapImpl :: (IsString s) => [Pretty s] -> Pretty s
wrapImpl [] = mempty
wrapImpl (p : ps) =
wrap_ . Seq.fromList $
@ -241,7 +241,7 @@ wrapString s = wrap (lit $ fromString s)
paragraphyText :: (LL.ListLike s Char, IsString s) => Text -> Pretty s
paragraphyText = sep "\n" . fmap (wrapPreserveSpaces . text) . Text.splitOn "\n"
wrap' :: IsString s => (s -> [Pretty s]) -> Pretty s -> Pretty s
wrap' :: (IsString s) => (s -> [Pretty s]) -> Pretty s -> Pretty s
wrap' wordify p = wrapImpl (toLeaves [p])
where
toLeaves [] = []
@ -383,22 +383,22 @@ render availableWidth p = go mempty [Right p]
SingleLine c -> SingleLine (min c (availableWidth - 1))
MultiLine fc lc mc -> MultiLine fc lc (min mc (availableWidth - 1))
newline :: IsString s => Pretty s
newline :: (IsString s) => Pretty s
newline = "\n"
lineSkip :: IsString s => Pretty s
lineSkip :: (IsString s) => Pretty s
lineSkip = newline <> newline
spaceIfNeeded :: Eq s => IsString s => Pretty s -> Pretty s -> Pretty s
spaceIfNeeded :: (Eq s) => (IsString s) => Pretty s -> Pretty s -> Pretty s
spaceIfNeeded a b = if isEmpty a then b else a <> " " <> b
spaceIfBreak :: IsString s => Pretty s
spaceIfBreak :: (IsString s) => Pretty s
spaceIfBreak = "" `orElse` " "
spacesIfBreak :: IsString s => Int -> Pretty s
spacesIfBreak :: (IsString s) => Int -> Pretty s
spacesIfBreak n = "" `orElse` fromString (replicate n ' ')
softbreak :: IsString s => Pretty s
softbreak :: (IsString s) => Pretty s
softbreak = " " `orElse` newline
spaced :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s
@ -460,12 +460,12 @@ sepNonEmpty :: (Foldable f, IsString s) => Pretty s -> f (Pretty s) -> Pretty s
sepNonEmpty between ps = sep between (nonEmpty ps)
-- if list is too long, adds `... 22 more` to the end
excerptSep :: IsString s => Maybe Int -> Pretty s -> [Pretty s] -> Pretty s
excerptSep :: (IsString s) => Maybe Int -> Pretty s -> [Pretty s] -> Pretty s
excerptSep maxCount =
excerptSep' maxCount (\i -> group ("... " <> shown i <> " more"))
excerptSep' ::
IsString s =>
(IsString s) =>
Maybe Int ->
(Int -> Pretty s) ->
Pretty s ->
@ -474,7 +474,7 @@ excerptSep' ::
excerptSep' maxCount summarize s ps = case maxCount of
Just max
| length ps > max ->
sep s (take max ps) <> summarize (length ps - max)
sep s (take max ps) <> summarize (length ps - max)
_ -> sep s ps
nonEmpty :: (Foldable f, IsString s) => f (Pretty s) -> [Pretty s]
@ -483,10 +483,10 @@ nonEmpty (toList -> l) = case l of
h : t -> h : nonEmpty t
[] -> []
parenthesize :: IsString s => Pretty s -> Pretty s
parenthesize :: (IsString s) => Pretty s -> Pretty s
parenthesize p = group $ "(" <> p <> ")"
parenthesizeIf :: IsString s => Bool -> Pretty s -> Pretty s
parenthesizeIf :: (IsString s) => Bool -> Pretty s -> Pretty s
parenthesizeIf False s = s
parenthesizeIf True s = parenthesize s
@ -564,10 +564,10 @@ numberedColumnNHeader headers rows =
in columnNHeader ("" : headers) (zipWith (:) numbers rows)
-- Opinionated `numbered` that uses bold numbers in front
numberedList :: Foldable f => f (Pretty ColorText) -> Pretty ColorText
numberedList :: (Foldable f) => f (Pretty ColorText) -> Pretty ColorText
numberedList = numbered (\i -> hiBlack . fromString $ show i <> ".")
leftPad, rightPad :: IsString s => Width -> Pretty s -> Pretty s
leftPad, rightPad :: (IsString s) => Width -> Pretty s -> Pretty s
leftPad n p =
let rem = n - preferredWidth p
in if rem > 0 then fromString (replicate (widthToInt rem) ' ') <> p else p
@ -584,7 +584,7 @@ excerptColumn2Headed ::
excerptColumn2Headed max hd cols = case max of
Just max
| len > max ->
lines [column2 (hd : take max cols), "... " <> shown (len - max) <> " more"]
lines [column2 (hd : take max cols), "... " <> shown (len - max) <> " more"]
_ -> column2 (hd : cols)
where
len = length cols
@ -771,13 +771,13 @@ align' rows = alignedRows
| (col0, col1) <- rows
]
text :: IsString s => Text -> Pretty s
text :: (IsString s) => Text -> Pretty s
text t = fromString (Text.unpack t)
num :: (Show n, Num n, IsString s) => n -> Pretty s
num n = fromString (show n)
string :: IsString s => String -> Pretty s
string :: (IsString s) => String -> Pretty s
string = fromString
shown :: (Show a, IsString s) => a -> Pretty s
@ -912,7 +912,7 @@ indentAfterNewline by = flatMap f
-- or other extra info attached to the original `s`
lit (LL.take (LL.length hd) s0) <> "\n" <> by <> f (LL.drop 1 s)
instance IsString s => IsString (Pretty s) where
instance (IsString s) => IsString (Pretty s) where
fromString s = lit' (foldMap chDelta s) (fromString s)
instance Semigroup (Pretty s) where
@ -1022,7 +1022,7 @@ background f p =
_ -> p
plural ::
Foldable f =>
(Foldable f) =>
f a ->
Pretty ColorText ->
Pretty ColorText
@ -1068,7 +1068,7 @@ type BoxStyle s =
(Pretty s, Pretty s) -- singleton
)
lBoxStyle1, lBoxStyle2, rBoxStyle2 :: IsString s => BoxStyle s
lBoxStyle1, lBoxStyle2, rBoxStyle2 :: (IsString s) => BoxStyle s
lBoxStyle1 =
( ("┌ ", "│ "), -- first
("├ ", "│ "), -- middle
@ -1143,23 +1143,23 @@ fatalCallout = callout "❗️"
okCallout = callout "✅"
blockedCallout = callout "🚫"
backticked :: IsString s => Pretty s -> Pretty s
backticked :: (IsString s) => Pretty s -> Pretty s
backticked p = group ("`" <> p <> "`")
-- | Attach some punctuation after the closing backtick.
backticked' :: IsString s => Pretty s -> Pretty s -> Pretty s
backticked' :: (IsString s) => Pretty s -> Pretty s -> Pretty s
backticked' p end = group ("`" <> p <> "`" <> end)
singleQuoted :: IsString s => Pretty s -> Pretty s
singleQuoted :: (IsString s) => Pretty s -> Pretty s
singleQuoted p = "'" <> p <> "'"
singleQuoted' :: IsString s => Pretty s -> Pretty s -> Pretty s
singleQuoted' :: (IsString s) => Pretty s -> Pretty s -> Pretty s
singleQuoted' p end = "'" <> p <> "'" <> end
instance Show s => Show (Pretty s) where
instance (Show s) => Show (Pretty s) where
show p = render 80 (metaPretty p)
metaPretty :: Show s => Pretty s -> Pretty String
metaPretty :: (Show s) => Pretty s -> Pretty String
metaPretty = go (0 :: Int)
where
go prec p = case out p of
@ -1175,7 +1175,7 @@ metaPretty = go (0 :: Int)
"OrElse" `hang` spaced [go 1 a, go 1 b]
Append s -> surroundCommas "[" "]" (go 1 <$> s)
map :: LL.ListLike s2 Char => (s -> s2) -> Pretty s -> Pretty s2
map :: (LL.ListLike s2 Char) => (s -> s2) -> Pretty s -> Pretty s2
map f p = case out p of
Append ps -> foldMap (map f) ps
Empty -> mempty

2
lib/unison-pretty-printer/tests/Unison/Test/ColorText.hs
View File

@ -65,7 +65,7 @@ ex4 =
(Range (Pos 1 1) (Pos 1 5), Green)
]
ex :: Ord a => AnnotatedExcerpt a
ex :: (Ord a) => AnnotatedExcerpt a
ex =
[r|The Tempest | Act 1, Scene 1

24
lib/unison-sqlite/src/Unison/Sqlite/Connection.hs
View File

@ -101,7 +101,7 @@ import UnliftIO.Exception
-- does not automatically enforce foreign key integrity, because it elected to maintain backwards compatibility with
-- code that was written before the foreign key integrity feature was implemented.
withConnection ::
MonadUnliftIO m =>
(MonadUnliftIO m) =>
-- | Connection name, for debugging.
String ->
-- | Path to SQLite database file.
@ -168,7 +168,7 @@ logQuery sql params result =
-- Without results, with parameters
execute :: Sqlite.ToRow a => Connection -> Sql -> a -> IO ()
execute :: (Sqlite.ToRow a) => Connection -> Sql -> a -> IO ()
execute conn@(Connection _ _ conn0) s params = do
logQuery s (Just params) Nothing
Sqlite.execute conn0 (coerce s) params `catch` \(exception :: Sqlite.SQLError) ->
@ -180,7 +180,7 @@ execute conn@(Connection _ _ conn0) s params = do
sql = s
}
executeMany :: Sqlite.ToRow a => Connection -> Sql -> [a] -> IO ()
executeMany :: (Sqlite.ToRow a) => Connection -> Sql -> [a] -> IO ()
executeMany conn@(Connection _ _ conn0) s = \case
[] -> pure ()
params -> do
@ -397,7 +397,7 @@ queryOneColCheck conn s params check =
-- With results, without parameters, without checks
queryListRow_ :: Sqlite.FromRow a => Connection -> Sql -> IO [a]
queryListRow_ :: (Sqlite.FromRow a) => Connection -> Sql -> IO [a]
queryListRow_ conn@(Connection _ _ conn0) s = do
result <-
Sqlite.query_ conn0 (coerce s)
@ -412,28 +412,28 @@ queryListRow_ conn@(Connection _ _ conn0) s = do
logQuery s Nothing (Just result)
pure result
queryListCol_ :: forall a. Sqlite.FromField a => Connection -> Sql -> IO [a]
queryListCol_ :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO [a]
queryListCol_ conn s =
coerce @(IO [Sqlite.Only a]) @(IO [a]) (queryListRow_ conn s)
queryMaybeRow_ :: Sqlite.FromRow a => Connection -> Sql -> IO (Maybe a)
queryMaybeRow_ :: (Sqlite.FromRow a) => Connection -> Sql -> IO (Maybe a)
queryMaybeRow_ conn s =
queryListRowCheck_ conn s \case
[] -> Right Nothing
[x] -> Right (Just x)
xs -> Left (SomeSqliteExceptionReason (ExpectedAtMostOneRowException (anythingToString xs)))
queryMaybeCol_ :: forall a. Sqlite.FromField a => Connection -> Sql -> IO (Maybe a)
queryMaybeCol_ :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO (Maybe a)
queryMaybeCol_ conn s =
coerce @(IO (Maybe (Sqlite.Only a))) @(IO (Maybe a)) (queryMaybeRow_ conn s)
queryOneRow_ :: Sqlite.FromRow a => Connection -> Sql -> IO a
queryOneRow_ :: (Sqlite.FromRow a) => Connection -> Sql -> IO a
queryOneRow_ conn s =
queryListRowCheck_ conn s \case
[x] -> Right x
xs -> Left (SomeSqliteExceptionReason (ExpectedExactlyOneRowException (anythingToString xs)))
queryOneCol_ :: forall a. Sqlite.FromField a => Connection -> Sql -> IO a
queryOneCol_ :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO a
queryOneCol_ conn s =
coerce @(IO (Sqlite.Only a)) @(IO a) (queryOneRow_ conn s)
@ -443,7 +443,7 @@ queryListRowCheck_ :: (Sqlite.FromRow a, SqliteExceptionReason e) => Connection
queryListRowCheck_ conn s check =
gqueryListCheck_ conn s (mapLeft SomeSqliteExceptionReason . check)
gqueryListCheck_ :: Sqlite.FromRow a => Connection -> Sql -> ([a] -> Either SomeSqliteExceptionReason r) -> IO r
gqueryListCheck_ :: (Sqlite.FromRow a) => Connection -> Sql -> ([a] -> Either SomeSqliteExceptionReason r) -> IO r
gqueryListCheck_ conn s check = do
xs <- queryListRow_ conn s
case check xs of
@ -523,7 +523,7 @@ vacuum conn =
Right () -> pure True
-- | @VACUUM INTO@
vacuumInto :: Connection -> Text -> IO ()
vacuumInto :: Connection -> FilePath -> IO ()
vacuumInto conn file =
execute conn "VACUUM INTO ?" (Sqlite.Only file)
@ -550,7 +550,7 @@ rollback conn =
execute_ conn "ROLLBACK"
-- | Perform an action within a named savepoint. The action is provided a rollback action.
withSavepoint :: MonadUnliftIO m => Connection -> Text -> (m () -> m a) -> m a
withSavepoint :: (MonadUnliftIO m) => Connection -> Text -> (m () -> m a) -> m a
withSavepoint conn name action =
withRunInIO \runInIO ->
withSavepointIO conn name \rollback ->

4
lib/unison-sqlite/src/Unison/Sqlite/Exception.hs
View File

@ -52,7 +52,7 @@ import UnliftIO.Exception
-- When actions are run on an untrusted codebase, e.g. one downloaded from a remote server, it is sufficient to catch
-- just one exception type, @SomeSqliteException@.
data SomeSqliteException
= forall e. Exception e => SomeSqliteException e
= forall e. (Exception e) => SomeSqliteException e
deriving anyclass (Exception)
instance Show SomeSqliteException where
@ -155,7 +155,7 @@ throwSqliteQueryException SqliteQueryExceptionInfo {connection, exception, param
}
data SomeSqliteExceptionReason
= forall e. SqliteExceptionReason e => SomeSqliteExceptionReason e
= forall e. (SqliteExceptionReason e) => SomeSqliteExceptionReason e
deriving anyclass (SqliteExceptionReason)
instance Show SomeSqliteExceptionReason where

4
lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs
View File

@ -32,7 +32,7 @@ journalModeFromText = \case
"off" -> Just JournalMode'OFF
_ -> Nothing
unsafeJournalModeFromText :: HasCallStack => Text -> JournalMode
unsafeJournalModeFromText :: (HasCallStack) => Text -> JournalMode
unsafeJournalModeFromText s =
fromMaybe (error ("Unknown journal mode: " ++ Text.unpack s)) (journalModeFromText s)
@ -45,7 +45,7 @@ journalModeToText = \case
JournalMode'WAL -> "wal"
JournalMode'OFF -> "off"
trySetJournalMode :: MonadIO m => Connection -> JournalMode -> m ()
trySetJournalMode :: (MonadIO m) => Connection -> JournalMode -> m ()
trySetJournalMode conn mode0 = liftIO do
queryOneRowCheck_
conn

22
lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs
View File

@ -86,7 +86,7 @@ unsafeGetConnection :: Transaction Connection
unsafeGetConnection = Transaction pure
-- | Run a transaction on the given connection.
runTransaction :: MonadIO m => Connection -> Transaction a -> m a
runTransaction :: (MonadIO m) => Connection -> Transaction a -> m a
runTransaction conn (Transaction f) = liftIO do
uninterruptibleMask \restore -> do
Connection.begin conn
@ -111,7 +111,7 @@ runTransaction conn (Transaction f) = liftIO do
--
-- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. If the transaction does
-- attempt a write and gets SQLITE_BUSY, it's your fault!
runReadOnlyTransaction :: MonadUnliftIO m => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
runReadOnlyTransaction :: (MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
runReadOnlyTransaction conn f =
withRunInIO \runInIO ->
runReadOnlyTransaction_ conn (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn))))
@ -134,7 +134,7 @@ runReadOnlyTransaction_ conn action = do
-- BEGIN/COMMIT statements.
--
-- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions.
runWriteTransaction :: MonadUnliftIO m => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
runWriteTransaction :: (MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
runWriteTransaction conn f =
withRunInIO \runInIO ->
uninterruptibleMask \restore ->
@ -197,11 +197,11 @@ unsafeIO action =
-- Without results, with parameters
execute :: Sqlite.ToRow a => Sql -> a -> Transaction ()
execute :: (Sqlite.ToRow a) => Sql -> a -> Transaction ()
execute s params = do
Transaction \conn -> Connection.execute conn s params
executeMany :: Sqlite.ToRow a => Sql -> [a] -> Transaction ()
executeMany :: (Sqlite.ToRow a) => Sql -> [a] -> Transaction ()
executeMany s params =
Transaction \conn -> Connection.executeMany conn s params
@ -324,27 +324,27 @@ queryOneColCheck s params check =
-- With results, without parameters, without checks
queryListRow_ :: Sqlite.FromRow a => Sql -> Transaction [a]
queryListRow_ :: (Sqlite.FromRow a) => Sql -> Transaction [a]
queryListRow_ s =
Transaction \conn -> Connection.queryListRow_ conn s
queryListCol_ :: Sqlite.FromField a => Sql -> Transaction [a]
queryListCol_ :: (Sqlite.FromField a) => Sql -> Transaction [a]
queryListCol_ s =
Transaction \conn -> Connection.queryListCol_ conn s
queryMaybeRow_ :: Sqlite.FromRow a => Sql -> Transaction (Maybe a)
queryMaybeRow_ :: (Sqlite.FromRow a) => Sql -> Transaction (Maybe a)
queryMaybeRow_ s =
Transaction \conn -> Connection.queryMaybeRow_ conn s
queryMaybeCol_ :: Sqlite.FromField a => Sql -> Transaction (Maybe a)
queryMaybeCol_ :: (Sqlite.FromField a) => Sql -> Transaction (Maybe a)
queryMaybeCol_ s =
Transaction \conn -> Connection.queryMaybeCol_ conn s
queryOneRow_ :: Sqlite.FromRow a => Sql -> Transaction a
queryOneRow_ :: (Sqlite.FromRow a) => Sql -> Transaction a
queryOneRow_ s =
Transaction \conn -> Connection.queryOneRow_ conn s
queryOneCol_ :: Sqlite.FromField a => Sql -> Transaction a
queryOneCol_ :: (Sqlite.FromField a) => Sql -> Transaction a
queryOneCol_ s =
Transaction \conn -> Connection.queryOneCol_ conn s

4
lib/unison-sqlite/src/Unison/Sqlite/Values.hs
View File

@ -16,7 +16,7 @@ newtype Values a
= Values (List.NonEmpty a)
deriving stock (Show)
instance Sqlite.Simple.ToRow a => Sqlite.Simple.ToRow (Values a) where
instance (Sqlite.Simple.ToRow a) => Sqlite.Simple.ToRow (Values a) where
toRow (Values values) =
foldMap Sqlite.Simple.toRow values
@ -26,7 +26,7 @@ instance Sqlite.Simple.ToRow a => Sqlite.Simple.ToRow (Values a) where
-- @
-- VALUES (?, ?), (?, ?), (?, ?)
-- @
valuesSql :: Sqlite.Simple.ToRow a => Values a -> Sql
valuesSql :: (Sqlite.Simple.ToRow a) => Values a -> Sql
valuesSql (Values values) =
Sql ("VALUES " <> Text.intercalate "," (replicate (length values) (valueSql columns)))
where

2
lib/unison-util-base32hex/unison-util-base32hex.cabal
View File

@ -18,8 +18,6 @@ source-repository head
library
exposed-modules:
U.Util.Base32Hex
U.Util.Hash
U.Util.Hash32
hs-source-dirs:
src
default-extensions:

8
lib/unison-util-bytes/src/Unison/Util/Bytes.hs
View File

@ -115,10 +115,10 @@ fromByteString b = snoc empty (byteStringToChunk b)
toByteString :: Bytes -> B.ByteString
toByteString b = B.concat (map chunkToByteString (chunks b))
toArray :: BA.ByteArray b => Bytes -> b
toArray :: (BA.ByteArray b) => Bytes -> b
toArray b = chunkToArray $ V.concat (chunks b)
fromArray :: BA.ByteArrayAccess b => b -> Bytes
fromArray :: (BA.ByteArrayAccess b) => b -> Bytes
fromArray b = snoc empty (arrayToChunk b)
byteStringToChunk, chunkFromByteString :: B.ByteString -> Chunk
@ -341,7 +341,7 @@ toBase16 bs = foldl' step empty (chunks bs)
BE.convertToBase BE.Base16 (chunkToArray @BA.Bytes b)
)
chunkToArray, arrayFromChunk :: BA.ByteArray b => Chunk -> b
chunkToArray, arrayFromChunk :: (BA.ByteArray b) => Chunk -> b
chunkToArray bs = BA.allocAndFreeze (V.length bs) $ \ptr ->
let go !ind =
if ind < V.length bs
@ -350,7 +350,7 @@ chunkToArray bs = BA.allocAndFreeze (V.length bs) $ \ptr ->
in go 0
arrayFromChunk = chunkToArray
arrayToChunk, chunkFromArray :: BA.ByteArrayAccess b => b -> Chunk
arrayToChunk, chunkFromArray :: (BA.ByteArrayAccess b) => b -> Chunk
arrayToChunk bs = case BA.convert bs :: Block Word8 of
Block bs -> V.Vector 0 n (ByteArray bs)
where

6
lib/unison-util-bytes/test/Main.hs
View File

@ -42,8 +42,10 @@ test =
scope "<>" . expect' $
Bytes.toArray (b1s <> b2s <> b3s) == b1 <> b2 <> b3
scope "Ord" . expect' $
(b1 <> b2 <> b3) `compare` b3
== (b1s <> b2s <> b3s) `compare` b3s
(b1 <> b2 <> b3)
`compare` b3
== (b1s <> b2s <> b3s)
`compare` b3s
scope "take" . expect' $
Bytes.toArray (Bytes.take k (b1s <> b2s)) == BS.take k (b1 <> b2)
scope "drop" . expect' $

27
lib/unison-util-cache/src/Unison/Util/Cache.hs
View File

@ -1,13 +1,14 @@
module Unison.Util.Cache
( Cache
, cache
, nullCache
, semispaceCache
, lookup
, insert
, apply
, applyDefined
) where
module Unison.Util.Cache
( Cache,
cache,
nullCache,
semispaceCache,
lookup,
insert,
apply,
applyDefined,
)
where
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
@ -22,10 +23,10 @@ data Cache k v = Cache
insert_ :: k -> v -> IO ()
}
lookup :: MonadIO m => Cache k v -> k -> m (Maybe v)
lookup :: (MonadIO m) => Cache k v -> k -> m (Maybe v)
lookup c k = liftIO (lookup_ c k)
insert :: MonadIO m => Cache k v -> k -> v -> m ()
insert :: (MonadIO m) => Cache k v -> k -> v -> m ()
insert c k v = liftIO (insert_ c k v)
-- Create a cache of unbounded size.
@ -80,7 +81,7 @@ semispaceCache maxSize = do
-- Cached function application: if a key `k` is not in the cache,
-- calls `f` and inserts `f k` results in the cache.
apply :: MonadIO m => Cache k v -> (k -> m v) -> k -> m v
apply :: (MonadIO m) => Cache k v -> (k -> m v) -> k -> m v
apply c f k =
lookup c k >>= \case
Just v -> pure v

26
lib/unison-util-relation/src/Unison/Util/Relation.hs
View File

@ -360,19 +360,19 @@ delete x y r = r {domain = domain', range = range'}
erase e s = if S.singleton e == s then Nothing else Just $ S.delete e s
-- | The Set of values associated with a value in the domain.
lookupDom' :: Ord a => a -> Relation a b -> Maybe (Set b)
lookupDom' :: (Ord a) => a -> Relation a b -> Maybe (Set b)
lookupDom' x r = M.lookup x (domain r)
-- | The Set of values associated with a value in the range.
lookupRan' :: Ord b => b -> Relation a b -> Maybe (Set a)
lookupRan' :: (Ord b) => b -> Relation a b -> Maybe (Set a)
lookupRan' y r = M.lookup y (range r)
-- | True if the element @ x @ exists in the domain of @ r @.
memberDom :: Ord a => a -> Relation a b -> Bool
memberDom :: (Ord a) => a -> Relation a b -> Bool
memberDom x r = isJust $ lookupDom' x r
-- | True if the element exists in the range.
memberRan :: Ord b => b -> Relation a b -> Bool
memberRan :: (Ord b) => b -> Relation a b -> Bool
memberRan y r = isJust $ lookupRan' y r
filterDom :: (Ord a, Ord b) => (a -> Bool) -> Relation a b -> Relation a b
@ -417,10 +417,10 @@ notMember :: (Ord a, Ord b) => a -> b -> Relation a b -> Bool
notMember x y r = not $ member x y r
-- | True if a value appears more than one time in the relation.
manyDom :: Ord a => a -> Relation a b -> Bool
manyDom :: (Ord a) => a -> Relation a b -> Bool
manyDom a = (> 1) . S.size . lookupDom a
manyRan :: Ord b => b -> Relation a b -> Bool
manyRan :: (Ord b) => b -> Relation a b -> Bool
manyRan b = (> 1) . S.size . lookupRan b
-- | Returns the domain in the relation, as a Set, in its entirety.
@ -441,7 +441,7 @@ ran r = M.keysSet (range r)
-- The cases of 'Nothing' are purged.
--
-- It is similar to 'concat'.
compactSet :: Ord a => Set (Maybe (Set a)) -> Set a
compactSet :: (Ord a) => Set (Maybe (Set a)) -> Set a
compactSet = S.fold (S.union . fromMaybe S.empty) S.empty
-- $selectops
@ -566,10 +566,10 @@ insertManyDom ::
(Foldable f, Ord a, Ord b) => f a -> b -> Relation a b -> Relation a b
insertManyDom as b r = foldl' (flip $ flip insert b) r as
lookupRan :: Ord b => b -> Relation a b -> Set a
lookupRan :: (Ord b) => b -> Relation a b -> Set a
lookupRan b r = fromMaybe S.empty $ lookupRan' b r
lookupDom :: Ord a => a -> Relation a b -> Set b
lookupDom :: (Ord a) => a -> Relation a b -> Set b
lookupDom a r = fromMaybe S.empty $ lookupDom' a r
-- Efficiently locate the `Set b` for which the corresponding `a` tests
@ -708,7 +708,7 @@ toMultimap :: Relation a b -> Map a (Set b)
toMultimap = domain
-- Returns Nothing if Relation isn't one-to-one.
toMap :: Ord a => Relation a b -> Maybe (Map a b)
toMap :: (Ord a) => Relation a b -> Maybe (Map a b)
toMap r =
let mm = toMultimap r
in if all (\s -> S.size s == 1) mm
@ -752,12 +752,12 @@ instance (Ord a, Ord b) => Semigroup (Relation a b) where
(<>) = union
toUnzippedMultimap ::
Ord a => Ord b => Ord c => Relation a (b, c) -> Map a (Set b, Set c)
(Ord a) => (Ord b) => (Ord c) => Relation a (b, c) -> Map a (Set b, Set c)
toUnzippedMultimap r = (\s -> (S.map fst s, S.map snd s)) <$> toMultimap r
collectRan ::
Ord a =>
Ord c =>
(Ord a) =>
(Ord c) =>
(b -> Maybe c) ->
Relation a b ->
Relation a c

12
lib/unison-util-relation/src/Unison/Util/Relation3.hs
View File

@ -94,6 +94,10 @@ mapD2Monotonic f Relation3 {d1, d2, d3} =
member :: (Ord a, Ord b, Ord c) => a -> b -> c -> Relation3 a b c -> Bool
member a b c = R.member b c . lookupD1 a
memberD2 :: (Ord b) => b -> Relation3 a b c -> Bool
memberD2 b =
Map.member b . d2
lookupD1 :: (Ord a, Ord b, Ord c) => a -> Relation3 a b c -> Relation b c
lookupD1 a = fromMaybe mempty . Map.lookup a . d1
@ -150,10 +154,10 @@ insert a b c Relation3 {..} =
insertAll,
deleteAll ::
Foldable f =>
Ord a =>
Ord b =>
Ord c =>
(Foldable f) =>
(Ord a) =>
(Ord b) =>
(Ord c) =>
f (a, b, c) ->
Relation3 a b c ->
Relation3 a b c

33
lib/unison-util-relation/src/Unison/Util/Relation4.hs
View File

@ -55,6 +55,12 @@ fromList xs = insertAll xs empty
filter :: (Ord a, Ord b, Ord c, Ord d) => ((a, b, c, d) -> Bool) -> Relation4 a b c d -> Relation4 a b c d
filter f = fromList . Prelude.filter f . toList
memberD13 :: (Ord a, Ord c) => a -> c -> Relation4 a b c d -> Bool
memberD13 a c r4 =
case Map.lookup a (d1 r4) of
Nothing -> False
Just r3 -> R3.memberD2 c r3
selectD3 ::
(Ord a, Ord b, Ord c, Ord d) =>
c ->
@ -93,12 +99,21 @@ keys :: Relation4 a b c d -> (Set a, Set b, Set c, Set d)
keys Relation4 {d1, d2, d3, d4} =
(Map.keysSet d1, Map.keysSet d2, Map.keysSet d3, Map.keysSet d4)
d1set :: Ord a => Relation4 a b c d -> Set a
lookupD1 :: (Ord a, Ord b, Ord c, Ord d) => a -> Relation4 a b c d -> Relation3 b c d
lookupD1 a = fromMaybe mempty . Map.lookup a . d1
lookupD2 :: (Ord a, Ord b, Ord c, Ord d) => b -> Relation4 a b c d -> Relation3 a c d
lookupD2 b = fromMaybe mempty . Map.lookup b . d2
d1set :: (Ord a) => Relation4 a b c d -> Set a
d1set = Map.keysSet . d1
d12 :: (Ord a, Ord b) => Relation4 a b c d -> Relation a b
d12 = R.fromMultimap . fmap (Map.keysSet . R3.d1) . d1
d13 :: (Ord a, Ord c) => Relation4 a b c d -> Relation a c
d13 = R.fromMultimap . fmap (Map.keysSet . R3.d2) . d1
d34 :: (Ord c, Ord d) => Relation4 a b c d -> Relation c d
d34 = R.fromMultimap . fmap (Map.keysSet . R3.d3) . d3
@ -124,6 +139,12 @@ d234 Relation4 {d2, d3, d4} =
d12s :: (Ord a, Ord b) => Relation4 a b c d -> [(a, b)]
d12s = nubOrd . fmap (\(a, (b, _)) -> (a, b)) . toNestedList
d3s :: Relation4 a b c d -> Set c
d3s = Map.keysSet . d3
d4s :: Relation4 a b c d -> Set d
d4s = Map.keysSet . d4
-- e.g. Map.toList (d1 r) >>= \(a, r3) -> (a,) <$> Map.keys (R3.d1 r3)
insert,
@ -175,11 +196,11 @@ mapD2Monotonic f Relation4 {d1, d2, d3, d4} =
}
insertAll ::
Foldable f =>
Ord a =>
Ord b =>
Ord c =>
Ord d =>
(Foldable f) =>
(Ord a) =>
(Ord b) =>
(Ord c) =>
(Ord d) =>
f (a, b, c, d) ->
Relation4 a b c d ->
Relation4 a b c d

24
lib/unison-util-rope/src/Unison/Util/Rope.hs
View File

@ -40,7 +40,7 @@ data Rope a
chunks :: Rope a -> [a]
chunks = toList
singleton, one :: Sized a => a -> Rope a
singleton, one :: (Sized a) => a -> Rope a
one a | size a == 0 = Empty
one a = One a
singleton = one
@ -49,7 +49,7 @@ singleton = one
-- be used unless the function is "roughly" size-preserving.
-- So converting from text to utf-8 encoded text chunks is okay,
-- wherease filtering out 95% of the chunks will lead to a size-unbalanced tree
map :: Sized b => (a -> b) -> Rope a -> Rope b
map :: (Sized b) => (a -> b) -> Rope a -> Rope b
map f = \case
Empty -> Empty
One a -> one (f a)
@ -73,16 +73,16 @@ class Index a elem where unsafeIndex :: Int -> a -> elem
class Reverse a where reverse :: a -> a
instance Sized a => Sized (Rope a) where
instance (Sized a) => Sized (Rope a) where
size = \case
Empty -> 0
One a -> size a
Two n _ _ -> n
null :: Sized a => Rope a -> Bool
null :: (Sized a) => Rope a -> Bool
null r = size r == 0
flatten :: Monoid a => Rope a -> a
flatten :: (Monoid a) => Rope a -> a
flatten = mconcat . toList
instance (Sized a, Semigroup a) => Semigroup (Rope a) where
@ -100,7 +100,7 @@ instance (Sized a, Semigroup a) => Monoid (Rope a) where
mempty = Empty
-- size-balanced append, leaving the left tree as is
appendL :: Sized a => Int -> Rope a -> Rope a -> Rope a
appendL :: (Sized a) => Int -> Rope a -> Rope a -> Rope a
appendL 0 _ a = a
appendL _ l Empty = l
appendL szl l r@(One a) = Two (szl + size a) l r
@ -109,7 +109,7 @@ appendL szl l r@(Two szr r1 r2)
| otherwise = Two (szl + szr) (appendL szl l r1) r2
-- size-balanced append, leaving the right tree as is
appendR :: Sized a => Rope a -> Int -> Rope a -> Rope a
appendR :: (Sized a) => Rope a -> Int -> Rope a -> Rope a
appendR a 0 _ = a
appendR Empty _ r = r
appendR l@(One a) szr r = Two (size a + szr) l r
@ -151,13 +151,13 @@ snoc' as szN aN = go as
| szN >= sz -> Two (sz + szN) as (One aN)
| otherwise -> appendL (size l) l (go r)
instance Reverse a => Reverse (Rope a) where
instance (Reverse a) => Reverse (Rope a) where
reverse = \case
One a -> One (reverse a)
Two sz l r -> Two sz (reverse r) (reverse l)
Empty -> Empty
two :: Sized a => Rope a -> Rope a -> Rope a
two :: (Sized a) => Rope a -> Rope a -> Rope a
two r1 r2 = Two (size r1 + size r2) r1 r2
-- Cutoff for when `snoc` or `cons` will create a new subtree
@ -204,7 +204,7 @@ instance (Sized a, Semigroup a, Drop a) => Drop (Rope a) where
| otherwise -> two (drop n l) r -- don't rebalance
Empty -> Empty
uncons :: Sized a => Rope a -> Maybe (a, Rope a)
uncons :: (Sized a) => Rope a -> Maybe (a, Rope a)
uncons = \case
Empty -> Nothing
One a -> Just (a, Empty)
@ -212,7 +212,7 @@ uncons = \case
Nothing -> uncons r
Just (hd, tl) -> Just (hd, two tl r)
unsnoc :: Sized a => Rope a -> Maybe (Rope a, a)
unsnoc :: (Sized a) => Rope a -> Maybe (Rope a, a)
unsnoc = \case
Empty -> Nothing
One a -> Just (Empty, a)
@ -249,7 +249,7 @@ instance (Sized a, Take a, Drop a, Eq a) => Eq (Rope a) where
instance (Sized a, Take a, Drop a, Ord a) => Ord (Rope a) where
b1 `compare` b2 = uncurry compare (alignChunks (chunks b1) (chunks b2))
instance NFData a => NFData (Rope a) where
instance (NFData a) => NFData (Rope a) where
rnf Empty = ()
rnf (One a) = rnf a
rnf (Two _ l r) = rnf l `seq` rnf r

8
parser-typechecker/package.yaml
View File

@ -8,10 +8,15 @@ flags:
optimized:
manual: true
default: true
arraychecks:
manual: true
default: false
when:
- condition: flag(optimized)
ghc-options: -funbox-strict-fields -O2
- condition: flag(arraychecks)
cpp-options: -DARRAY_CHECK
dependencies:
- ListLike
@ -19,6 +24,7 @@ dependencies:
- aeson
- ansi-terminal
- async
- atomic-primops
- base
- base16 >= 0.2.1.0
- base64-bytestring
@ -64,6 +70,7 @@ dependencies:
- monad-validate
- mtl
- mutable-containers
- murmur-hash
- mwc-random
- natural-transformation
- network
@ -108,6 +115,7 @@ dependencies:
- unison-codebase-sync
- unison-core
- unison-core1
- unison-hash
- unison-hashing-v2
- unison-prelude
- unison-pretty-printer

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