puck/zilch
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

(zilch): document most exported symbols

Browse source 
Change-Id: I6a6a6964d3be7b8c6306a21d810c639f30253d38
This commit is contained in:
puck 2025-06-23 12:22:20 +00:00
parent 6a1efc6a92
commit a80266d9d8
13 changed files with 186 additions and 81 deletions
Download patch file Download diff file Expand all files Collapse all files

11
core/src/file.sld
View file

@ -1,3 +1,4 @@
;; Helpers to create store paths that contain files, symlinks, and/or directories.
(define-library (zilch file) (define-library (zilch file)
(import (import
(scheme base) (scheme case-lambda) (scheme base) (scheme case-lambda)
@ -17,8 +18,8 @@
(define-record-printer (<z-file> file out) (define-record-printer (<z-file> file out)
(if (z-file-executable file) (if (z-file-executable file)
(fprintf out "#<z-file (executable)>") (fprintf out "#<z-file ~S (executable)>" (z-file-contents file))
(fprintf out "#<z-file>"))) (fprintf out "#<z-file ~S>" (z-file-contents file))))
(define-record-type <z-directory> (define-record-type <z-directory>
(make-z-directory contents cache) (make-z-directory contents cache)
@ -43,13 +44,13 @@
(define (env-pair<? l r) (string<? (car l) (car r))) (define (env-pair<? l r) (string<? (car l) (car r)))
;; Create a `<z-file>` object with given contents and optional `executable` flag. ;; Create a `<z-file>` object with given contents and optional `executable` flag.
;; The contents may either be a string or a `<zexp>`. ;; The contents may either be a string or a `zexp`.
(define zfile (define zfile
(case-lambda (case-lambda
((contents) (make-z-file contents #f #f)) ((contents) (make-z-file contents #f #f))
((contents executable) (make-z-file contents executable #f)))) ((contents executable) (make-z-file contents executable #f))))
;; Create a `<z-symlink>` record. The target may be any string, *or* a `<zexp>` containing one. ;; Create a `<z-symlink>` record. The target may be any string, or a `<zexp>` of a string.
(define (zsymlink target) (make-z-symlink target #f)) (define (zsymlink target) (make-z-symlink target #f))
;; Create a `<z-directory>` record. The contents is an alist of file name -> zfile/zsymlink/zdir. ;; Create a `<z-directory>` record. The contents is an alist of file name -> zfile/zsymlink/zdir.
@ -188,7 +189,7 @@
;; Serialize a file-like (`zfile`, `zsymlink`, `zdir`) to a `<store-path>`. ;; Serialize a file-like (`zfile`, `zsymlink`, `zdir`) to a `<store-path>`.
;; This function should not depend on the system of the builder. ;; This function should not depend on the system of the builder.
;; ;;
;; TODO(puck): due to limitations, whatever you pass in ends up at `<store-path>/-` instead. ;; Due to limitations, whatever you pass in ends up at `<store-path>/-` instead.
(define (zfile->store val) (define (zfile->store val)
(define cached (define cached
(cond (cond

32
core/src/lib/getopt.sld
View file

@ -7,7 +7,7 @@
; (single-char char) (required? bool) (value bool) (predicate func) ; (single-char char) (required? bool) (value bool) (predicate func)
(define (is-long-option value) (and (> (string-length value) 3) (string=? (string-copy value 0 2) "--"))) (define (is-long-option value) (and (> (string-length value) 3) (string=? (string-copy value 0 2) "--")))
(define (is-short-option value) (and (> (string-length value) 1) (char=? (string-ref value 0) #\-) (not (char=? (string-ref value 1) #\-)))) (define (is-short-option value) (and (> (string-length value) 1) (char=? (string-ref value 0) #\-) (not (char=? (string-ref value 1) #\-))))
(define (find-long-option options val) (define (find-long-option options val)
(cond (cond
((eq? options '()) #f) ((eq? options '()) #f)
@ -20,6 +20,34 @@
((and (> (length (car options)) 2) (list-ref (car options) 2) (char=? (list-ref (car options) 2) val)) (car options)) ((and (> (length (car options)) 2) (list-ref (car options) 2) (char=? (list-ref (car options) 2) val)) (car options))
(else (find-short-option (cdr options) val)))) (else (find-short-option (cdr options) val))))
;; Implements a variant of getopt.
;;
;; - `options`: a list of arguments that can be set, in the format
;; `(long-name takes-argument [short-char])`.
;; - `vals`: A vector of strings forming the command line arguments.
;; - `help`: A procedure which is called with an error string when an
;; unknown option is encountered.
;;
;; Returns an alist of long-name to their values (or `#f`), and a list of
;; non-option arguments. Arguments can be passed multiple times; the
;; resulting alist will then contain multiple pairs with the same `car`.
;;
;; ====
;; [,scheme]
;; ----
;; (define-values
;; (args rest)
;; (getopt '((foo #t)
;; (bar #f)
;; (baz #f #\z))
;; #("--foo" "quux" "hi" "--bar" "--bar" "-zz" "--" "--foo")
;; (lambda (msg) (error msg))))
;; ;; args -> ((baz . #f) (baz . #f)
;; ;; (bar . #f) (bar . #f)
;; ;; (foo . "quux")))))
;; ;; rest -> ("hi" "--foo")
;; ----
;; ====
(define (getopt options vals help) (define (getopt options vals help)
(do ((i 0 (+ i 1)) (outputs '() outputs) (rest '() rest)) (do ((i 0 (+ i 1)) (outputs '() outputs) (rest '() rest))
((>= i (vector-length vals)) (values outputs (reverse rest))) ((>= i (vector-length vals)) (values outputs (reverse rest)))
@ -52,5 +80,3 @@
(set! i (+ i 1))) (set! i (+ i 1)))
(set! outputs (cons (cons (car option) #f) outputs))))) (set! outputs (cons (cons (car option) #f) outputs)))))
(else (set! rest (cons val rest)))))))) (else (set! rest (cons val rest))))))))

7
core/src/lib/hash.scm
View file

@ -7,12 +7,13 @@
(begin (begin
(foreign-declare "#include <sodium/crypto_hash_sha256.h>") (foreign-declare "#include <sodium/crypto_hash_sha256.h>")
(define sodium-sha256 (foreign-lambda void "crypto_hash_sha256" nonnull-u8vector nonnull-u8vector unsigned-integer64)) (define sodium-sha256 (foreign-lambda void "crypto_hash_sha256" nonnull-u8vector nonnull-u8vector unsigned-integer64))
(define sodium-sha256-init (foreign-lambda void "crypto_hash_sha256_init" (nonnull-scheme-pointer "crypto_hash_sha256_state"))) (define sodium-sha256-init (foreign-lambda void "crypto_hash_sha256_init" (nonnull-scheme-pointer "crypto_hash_sha256_state")))
(define sodium-sha256-update (foreign-lambda void "crypto_hash_sha256_update" (nonnull-scheme-pointer "crypto_hash_sha256_state") nonnull-u8vector unsigned-integer64)) (define sodium-sha256-update (foreign-lambda void "crypto_hash_sha256_update" (nonnull-scheme-pointer "crypto_hash_sha256_state") nonnull-u8vector unsigned-integer64))
(define sodium-sha256-final (foreign-lambda void "crypto_hash_sha256_final" (nonnull-scheme-pointer "crypto_hash_sha256_state") nonnull-u8vector)) (define sodium-sha256-final (foreign-lambda void "crypto_hash_sha256_final" (nonnull-scheme-pointer "crypto_hash_sha256_state") nonnull-u8vector))
;; Calculate the sha256 of a bytevector.
(define (sha256 buf) (define (sha256 buf)
(define out (make-bytevector 32)) (define out (make-bytevector 32))
(cond (cond
@ -29,9 +30,11 @@
(sodium-sha256-update state bbuf bytes-read)))) (sodium-sha256-update state bbuf bytes-read))))
(else (error "unknown object type passed to ((zilch lib hash) sha256)"))) (else (error "unknown object type passed to ((zilch lib hash) sha256)")))
out) out)
(define hexit "0123456789abcdef") (define hexit "0123456789abcdef")
;; Returns a string containing the hexadecimal representation of the
;; bytevector.
(define (hex bv) (define (hex bv)
(define out (make-string (* (bytevector-length bv) 2) #\!)) (define out (make-string (* (bytevector-length bv) 2) #\!))
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))

25
core/src/magic.sld
View file

@ -1,6 +1,11 @@
;; Defines procedures to interact with the Nix store by way of zexpressions. ;; Defines procedures to interact with the Nix store by way of zexps.
;; This library defines the `<store-path>` record type, which can be used in zexps. ;; This library defines the `<store-path>` record type, which can be used in zexps.
;; A `<store-path>` unquotes in `zexp`s as its store path. ;;
;; A `<store-path>` can be unquoted in a `zexp`, and has its store path as a value.
;;
;; This library also implements the logic necessary to build a `zexp` and its context;
;; and should be used wherever a `zexp` needs to be built, as it handles resolving CA
;; derivations and their post-build/fallback hooks.
(define-library (zilch magic) (define-library (zilch magic)
(import (import
(scheme base) (scheme file) (scheme lazy) (scheme base) (scheme file) (scheme lazy)
@ -198,7 +203,7 @@
(define drv (make-ca-derivation name platform input-drvs input-srcs (zexp-evaluation-value collected-builder) (zexp-evaluation-value collected-env) outputs)) (define drv (make-ca-derivation name platform input-drvs input-srcs (zexp-evaluation-value collected-builder) (zexp-evaluation-value collected-env) outputs))
(map (lambda (l) (cons (car l) (make-store-path drv (car l) #f))) (derivation-outputs drv))) (map (lambda (l) (cons (car l) (make-store-path drv (car l) #f))) (derivation-outputs drv)))
;; Calls either `store-path-for-ca-drv` or `store-path-for-drv` depending on `*use-ca*`. ;; Calls either `store-path-for-ca-drv` or `store-path-for-drv` depending on ``++*use-ca*++``'s value.
(define (store-path-for-ca-drv* name platform builder env outputs) (define (store-path-for-ca-drv* name platform builder env outputs)
(if (*use-ca*) (store-path-for-ca-drv name platform builder env outputs) (if (*use-ca*) (store-path-for-ca-drv name platform builder env outputs)
(store-path-for-drv name platform builder env outputs))) (store-path-for-drv name platform builder env outputs)))
@ -262,6 +267,9 @@
(for-each (lambda (output) (set! has-placeholder (or has-placeholder (derivation-output-placeholder? (cdr (assoc output (derivation-outputs drv))))))) outputs) (for-each (lambda (output) (set! has-placeholder (or has-placeholder (derivation-output-placeholder? (cdr (assoc output (derivation-outputs drv))))))) outputs)
(or has-placeholder (zexp-ctx-has-placeholder (cdr drv-context)))))) (or has-placeholder (zexp-ctx-has-placeholder (cdr drv-context))))))
;; Represents whether a derivation can be safely stored in the Nix store.
;; A content-addressed derivation is one that is CA, _or_ is a fixed-output
;; derivation whose dependencies contains a CA derivation.
(define (drv-is-ca drv) (define (drv-is-ca drv)
(define is-ca #f) (define is-ca #f)
(for-each (lambda (out) (when (eq? (derivation-output-hash (cdr out)) 'floating) (set! is-ca #t))) (derivation-outputs drv)) (for-each (lambda (out) (when (eq? (derivation-output-hash (cdr out)) 'floating) (set! is-ca #t))) (derivation-outputs drv))
@ -317,6 +325,7 @@
(define-record-printer (<pending-item> item out) (define-record-printer (<pending-item> item out)
(fprintf out "#<pending-item ~A - awaiting ~S>" (derivation-path (pending-item-init-ca-drv item)) (pending-item-awaiting-count item))) (fprintf out "#<pending-item ~A - awaiting ~S>" (derivation-path (pending-item-init-ca-drv item)) (pending-item-awaiting-count item)))
;; Amount of threads that should be used whilst resolving CA derivations.
(define ca-thread-count (make-parameter 4)) (define ca-thread-count (make-parameter 4))
; This function is a bit of a misnomer. ; This function is a bit of a misnomer.
@ -564,6 +573,9 @@
(raise build-error) (raise build-error)
(error "CA build failed"))) (error "CA build failed")))
root-pend) root-pend)
;; Takes a content-addressed derivation, and rewrites it to use input-addressed derivations, and builds it.
;; Returns an alist of output name to store path, or `#f` if the derivation is not CA.
(define (drv-resolve-ca drv outputs) (define (drv-resolve-ca drv outputs)
(if (drv-is-ca drv) (if (drv-is-ca drv)
(pending-item-resolved-paths (rewrite-ca-stack drv)) (pending-item-resolved-paths (rewrite-ca-stack drv))
@ -587,6 +599,7 @@
(error "store-path-devirtualise: expression has dependencies on placeholder context, but isn't a string" (list zexpr val)))) (error "store-path-devirtualise: expression has dependencies on placeholder context, but isn't a string" (list zexpr val))))
(list val drvs srcs)) (list val drvs srcs))
;; Returns a `zexp` representing `zexpr` after CA derivations have been built.
(define (store-path-devirtualise zexpr) (define (store-path-devirtualise zexpr)
(define inner (delay (devirtualise-inner zexpr))) (define inner (delay (devirtualise-inner zexpr)))
(make-zexp (make-zexp
@ -597,6 +610,7 @@
(lambda (out) (lambda (out)
(fprintf out "#<devirtualised ~S>" zexpr)))) (fprintf out "#<devirtualised ~S>" zexpr))))
;; Evaluates `path` (a `<store-path>` or zexp), and returns its contents, after ensuring it and all its dependencies are built.
(define (store-path-realised path) (define (store-path-realised path)
(define devirt (devirtualise-inner path)) (define devirt (devirtualise-inner path))
(define to-build (list)) (define to-build (list))
@ -612,6 +626,8 @@
(daemon-wop-build-paths (*daemon*) (list->vector to-build))) (daemon-wop-build-paths (*daemon*) (list->vector to-build)))
val) val)
;; Registers a thunk to be called when the `<store-path>` `path` is failed to build. Should return a new
;; `<store-path>` or `<derivation>` with the same outputs as this one.
(define (store-path-register-fallback path fallback-thunk) (define (store-path-register-fallback path fallback-thunk)
(define (wrap-fallback) (define (wrap-fallback)
(define new (fallback-thunk)) (define new (fallback-thunk))
@ -622,7 +638,8 @@
(set-derivation-meta! (store-path-drv path) (cons (cons 'fallback wrap-fallback) (or (derivation-meta (store-path-drv path)) '()))) (set-derivation-meta! (store-path-drv path) (cons (cons 'fallback wrap-fallback) (or (derivation-meta (store-path-drv path)) '())))
path) path)
; Note: this post-build hook is called with a mutex taken. ;; Registers a thunk to be called when the `<store-path>` `path` is successfully built.
;; Only works for CA derivations.
(define (store-path-register-post-build path callback) (define (store-path-register-post-build path callback)
(set-derivation-meta! (store-path-drv path) (cons (cons 'post-build callback) (or (derivation-meta (store-path-drv path)) '()))) (set-derivation-meta! (store-path-drv path) (cons (cons 'post-build callback) (or (derivation-meta (store-path-drv path)) '())))
path) path)

62
core/src/nix/daemon.sld
View file

@ -16,22 +16,24 @@
daemon-write-bytevector daemon-read-bytevector daemon-write-bytevector daemon-read-bytevector
daemon-write-string daemon-read-string daemon-write-string daemon-read-string
*logger*
daemon-wop-handshake daemon-wop-set-options
daemon-wop-add-text-to-store daemon-wop-build-paths
daemon-wop-query-derivation-output-map
daemon-wop-query-path-info
daemon-wop-nar-from-path
daemon-wop-add-to-store-nar
<nix-activity> nix-activity? <nix-activity> nix-activity?
nix-activity-id nix-activity-log-level nix-activity-type nix-activity-id nix-activity-log-level nix-activity-type
nix-activity-string nix-activity-fields nix-activity-parent-id nix-activity-string nix-activity-fields nix-activity-parent-id
*logger*
daemon-wop-handshake daemon-wop-set-options
daemon-wop-add-text-to-store daemon-wop-build-paths
daemon-wop-query-derivation-output-map
daemon-wop-nar-from-path
daemon-wop-add-to-store-nar
<valid-path-info> valid-path-info? <valid-path-info> valid-path-info?
valid-path-info-deriver valid-path-info-nar-hash valid-path-info-references valid-path-info-deriver valid-path-info-nar-hash valid-path-info-references
valid-path-info-registration-time valid-path-info-nar-size valid-path-info-ultimate valid-path-info-registration-time valid-path-info-nar-size valid-path-info-ultimate
valid-path-info-sigs valid-path-info-ca) valid-path-info-sigs valid-path-info-ca
daemon-wop-query-path-info)
(begin (begin
@ -51,6 +53,8 @@
(daemon-version daemon-link-daemon-version set-daemon-link-daemon-version!) (daemon-version daemon-link-daemon-version set-daemon-link-daemon-version!)
(settings daemon-link-settings)) (settings daemon-link-settings))
;; Creates a new `<daemon-link>`, setting the internal settings to default
;; (verbosity at 3, job count at 32, use-substitutes `#t`)
(define (make-daemon-link in-port out-port) (define (make-daemon-link in-port out-port)
(internal-make-daemon-link in-port out-port #f #f (make-daemon-link-settings 3 32 #t))) (internal-make-daemon-link in-port out-port #f #f (make-daemon-link-settings 3 32 #t)))
@ -62,6 +66,8 @@
(define (daemon-read-u64 link) (port-read-u64 (daemon-link-in-port link))) (define (daemon-read-u64 link) (port-read-u64 (daemon-link-in-port link)))
(define (daemon-read-bytevector link) (port-read-bytevector (daemon-link-in-port link))) (define (daemon-read-bytevector link) (port-read-bytevector (daemon-link-in-port link)))
(define (daemon-read-string link) (port-read-string (daemon-link-in-port link))) (define (daemon-read-string link) (port-read-string (daemon-link-in-port link)))
;; Flushes the ``<daemon-link>``'s output port.
(define (daemon-flush link) (flush-output-port (daemon-link-out-port link))) (define (daemon-flush link) (flush-output-port (daemon-link-out-port link)))
(define build-activity #f) (define build-activity #f)
@ -85,9 +91,9 @@
(when (or (> done-builds 0) (> total-builds 1) (> running-builds 0)) (when (or (> done-builds 0) (> total-builds 1) (> running-builds 0))
(printf "[~S/~S builds, ~S running]\n" done-builds total-builds running-builds)))))))) (printf "[~S/~S builds, ~S running]\n" done-builds total-builds running-builds))))))))
;; Reads a list of log events until STDERR_LAST is called. ;; Reads a list of log events until `STDERR_LAST` is seen.
;; This is the client-side equivalent of startWorking / stopWorking on the ;; This is the client-side equivalent of `startWorking` / `stopWorking` in the
;; server. ;; Nix daemon.
(define (daemon-read-log-events link) (define (daemon-read-log-events link)
(define val (daemon-read-u64 link)) (define val (daemon-read-u64 link))
(case val (case val
@ -175,7 +181,8 @@
(#x1f . "Nix 2.4pre") (#x1f . "Nix 2.4pre")
(#x1f . "Nix 2.4pre") (#x1f . "Nix 2.4pre")
(#x20 . "Nix 2.4-2.6"))) (#x20 . "Nix 2.4-2.6")))
;; Send a Nix worker protocol handshake.
;; Sends the Nix worker protocol handshake, then sends the default options.
(define (daemon-wop-handshake link) (define (daemon-wop-handshake link)
(daemon-write-u64 link #x6e697863) (daemon-write-u64 link #x6e697863)
(daemon-flush link) (daemon-flush link)
@ -199,6 +206,11 @@
(daemon-read-log-events link) (daemon-read-log-events link)
(daemon-wop-set-options link)) (daemon-wop-set-options link))
;; Sets some of the daemon's settings.
;;
;; - `verbosity` is the verbosity (amount of `-v` arguments in Nix)
;; - `max-build-jobs` is the amount of concurrent build jobs for this connection.
;; - `use-substitutes` defines whether the Nix daemon should check if the output of a Derivation is available in the binary cache.
(define daemon-wop-set-options (define daemon-wop-set-options
(case-lambda (case-lambda
((link) ((link)
@ -250,8 +262,8 @@
(daemon-read-log-events link) (daemon-read-log-events link)
(daemon-read-u64 link))) (daemon-read-u64 link)))
;; Write a simple text file to the store. REFS is expected to be sorted. ;; Write a simple text file to the store. `refs` is expected to be sorted.
;; Returns the store path at which the file has been created. ;; Returns the (string) store path at which the file has been created.
(define (daemon-wop-add-text-to-store link suffix s refs) (define (daemon-wop-add-text-to-store link suffix s refs)
(daemon-write-u64 link 8) (daemon-write-u64 link 8)
(daemon-write-string link suffix) (daemon-write-string link suffix)
@ -262,6 +274,7 @@
(daemon-read-log-events link) (daemon-read-log-events link)
(daemon-read-string link)) (daemon-read-string link))
;; Contains the information Nix stores about a valid store path.
(define-record-type <valid-path-info> (define-record-type <valid-path-info>
(make-valid-path-info deriver nar-hash references registration-time nar-size ultimate sigs ca) (make-valid-path-info deriver nar-hash references registration-time nar-size ultimate sigs ca)
valid-path-info? valid-path-info?
@ -296,6 +309,7 @@
references registration-time nar-size (= ultimate 1) sigs references registration-time nar-size (= ultimate 1) sigs
(if (string=? ca "") #f ca))) (if (string=? ca "") #f ca)))
;; Requests the information the Nix daemon has about a specified store path. Returns a `<valid-path-info>`.
(define (daemon-wop-query-path-info link store-path) (define (daemon-wop-query-path-info link store-path)
(daemon-write-u64 link 26) (daemon-write-u64 link 26)
(daemon-write-string link store-path) (daemon-write-string link store-path)
@ -306,16 +320,25 @@
(daemon-read-valid-path-info link) (daemon-read-valid-path-info link)
#f)) #f))
; You are responsible for reading exactly the right amount of bytes from ;; Requests the daemon send over the contents of a NAR file. The file is not multiplexed, and of unspecified size.
; the daemon after this. My condolences. ;; When you call this, you take responsibility to read exactly `nar-size` (from `<valid-path-info>`) bytes, or one valid NAR file,
;; from the `daemon-link-in-port`.
(define (daemon-wop-nar-from-path link store-path) (define (daemon-wop-nar-from-path link store-path)
(daemon-write-u64 link 38) (daemon-write-u64 link 38)
(daemon-write-string link store-path) (daemon-write-string link store-path)
(daemon-flush link) (daemon-flush link)
(daemon-read-log-events link)) (daemon-read-log-events link))
; `proc` is a procedure taking one argument, which is used to write data into the daemon. ;; Adds a NAR to the daemon's Nix store.
; The write-blob procedure passed to `proc` looks like (write-blob bv [start [end]]). ;;
;; - `store-path` is the path this nar file should be stored at, and must correspond to the rest of the information provided.
;; - `deriver` is the (optional) store path containing the information used to derive this store path (usually a `.drv`).
;; - `nar-hash` is a string containing the nixbase16 representation of the sha256 hash of the NAR.
;; - `references` is a (sorted) list of store paths that this nar depends on.
;; - `nar-size` is the amountt of bytes this nar takes up.
;; - `ca`, if not `#f` is a Nix-style hash describing the content-addressed hash type and hash value.
;; - `proc` is a procedure taking one argument (`write-blob`), which is used to write data into the daemon.
;; `write-blob` takes three arguments: a bytevector, and an optional start and end index into it.
(define (daemon-wop-add-to-store-nar link store-path deriver nar-hash references nar-size ca proc) (define (daemon-wop-add-to-store-nar link store-path deriver nar-hash references nar-size ca proc)
(daemon-write-u64 link 39) (daemon-write-u64 link 39)
(daemon-write-string link store-path) (daemon-write-string link store-path)
@ -348,6 +371,7 @@
(daemon-read-log-events link) (daemon-read-log-events link)
(thread-join! data-thread)) (thread-join! data-thread))
;; Requests an alist of output name to output store path for the derivation at `store-path`.
(define (daemon-wop-query-derivation-output-map link store-path) (define (daemon-wop-query-derivation-output-map link store-path)
(daemon-write-u64 link 41) (daemon-write-u64 link 41)
(daemon-write-string link store-path) (daemon-write-string link store-path)

43
core/src/nix/drv.sld
View file

@ -7,20 +7,17 @@
(chicken base) (chicken format)) (chicken base) (chicken format))
(export (export
<derivation> derivation?
derivation-name derivation-outputs derivation-input-drvs
derivation-input-src derivation-system derivation-builder
derivation-args derivation-env derivation-equal?
derivation-meta set-derivation-meta!
%derivation-compatible %derivation-compatible
<derivation-output> derivation-output? <derivation-output> derivation-output?
derivation-output-path derivation-output-hash derivation-output-path derivation-output-hash
derivation-output-algo derivation-output-recursive derivation-output-algo derivation-output-recursive
derivation-output-placeholder? derivation-output-path-length derivation-output-placeholder? derivation-output-path-length
write-quoted-string
<derivation> derivation?
derivation-name derivation-outputs derivation-input-drvs
derivation-input-src derivation-system derivation-builder
derivation-args derivation-env derivation-equal?
derivation-meta set-derivation-meta!
drv-is-fod drv-is-fod
derivation-serialize derivation-path-references derivation-path derivation-read read-drv-path derivation-serialize derivation-path-references derivation-path derivation-read read-drv-path
@ -28,7 +25,7 @@
modulo-hash-drv-contents) modulo-hash-drv-contents)
(begin (begin
;; If `#t`, outputs environment variables not used by Nix, but required for compatibility with Nix's output. ;; If `#t`, `make-[..]-derivation` will output environment variables not used by Nix, but required for compatibility with Nix's output.
;; This adds `name`, `builder`, and `system` to the environment; as well as `outputHash`, `outputHashAlgo`, ;; This adds `name`, `builder`, and `system` to the environment; as well as `outputHash`, `outputHashAlgo`,
;; and `outputHashMode` for fixed-output derivations. ;; and `outputHashMode` for fixed-output derivations.
(define %derivation-compatible (make-parameter #t)) (define %derivation-compatible (make-parameter #t))
@ -37,11 +34,10 @@
;; whether or not it the hash is of the NAR file, if it is a content-addressed output. ;; whether or not it the hash is of the NAR file, if it is a content-addressed output.
;; The path can be read using `(derivation-output-path)`. ;; The path can be read using `(derivation-output-path)`.
;; ;;
;; - `(path #u8() "" #f)` is an input-addressed derivation output. TODO(puck): empty bytevector? ;; - `(path #u8() "" #f)` is an input-addressed derivation output.
;; - `(path #f #f #f)` is an input-addressed derivation output. TODO(puck): empty bytevector? ;; - `(path #f #f #f)` is an input-addressed derivation output.
;; - `(path hash-value hash-algo rec)` is a content-addressed derivation output. ;; - `(path hash-value hash-algo rec)` is a content-addressed derivation output.
;; - `(#f 'floating hash-algo rec)` is a floating content-addressed derivation output. ;; - `(#f 'floating hash-algo rec)` is a floating content-addressed derivation output.
;; - `(#f 'impure hash-algo rec)` is an impure content-addressed derivation output.
(define-record-type <derivation-output> (define-record-type <derivation-output>
(make-derivation-output path hash algo recursive) (make-derivation-output path hash algo recursive)
derivation-output? derivation-output?
@ -57,9 +53,11 @@
(derivation-output-algo drvout) (derivation-output-algo drvout)
(derivation-output-recursive drvout))) (derivation-output-recursive drvout)))
;; Returns whether the `derivation-output-path` of this output is a placeholder (floating hash)
(define (derivation-output-placeholder? drvout) (define (derivation-output-placeholder? drvout)
(member (derivation-output-hash drvout) '(floating))) (member (derivation-output-hash drvout) '(floating)))
;; Returns the final (post-placeholder substitution) length of a derivation's output.
(define (derivation-output-path-length drv output-name) (define (derivation-output-path-length drv output-name)
; /nix/store/a0a3n97c93ckfg3a920aqnycxdznbbmi-module-output ; /nix/store/a0a3n97c93ckfg3a920aqnycxdznbbmi-module-output
(+ (string-length (%store-dir)) 34 (string-length (derivation-name drv)) (if (string=? output-name "out") 0 (+ 1 (string-length output-name))))) (+ (string-length (%store-dir)) 34 (string-length (derivation-name drv)) (if (string=? output-name "out") 0 (+ 1 (string-length output-name)))))
@ -74,9 +72,10 @@
(serialized derivation-metadata-serialized set-derivation-metadata-serialized!) (serialized derivation-metadata-serialized set-derivation-metadata-serialized!)
(meta derivation-metadata-meta set-derivation-metadata-meta!)) (meta derivation-metadata-meta set-derivation-metadata-meta!))
;; An arbitrary Scheme object stored in the `<derivation>`.
(define (derivation-meta drv) (define (derivation-meta drv)
(derivation-metadata-meta (derivation-metadata drv))) (derivation-metadata-meta (derivation-metadata drv)))
;; Sets the object stored within the `<derivation>`.
(define (set-derivation-meta! drv meta) (define (set-derivation-meta! drv meta)
(set-derivation-metadata-meta! (derivation-metadata drv) meta)) (set-derivation-metadata-meta! (derivation-metadata drv) meta))
@ -88,9 +87,11 @@
(not (not (derivation-metadata-serialized drv))))) (not (not (derivation-metadata-serialized drv)))))
;; An entire derivation. ;; An entire derivation.
;; `outputs` is stored as an alist of output name to `<derivation-output>` object. ;;
;; `input-drvs` is stored as an alist of `<derivation>` to a (sorted) list of its outputs that are used. ;; - `outputs` is an alist of output name to `<derivation-output>` record.
;; The `outputs`, `input-drvs`, `input-src`, and `env` are expected to be sorted. ;; - `input-drvs` is an alist of `<derivation>` to a (sorted) list of the outputs of said derivation that are depended on.
;;
;; `outputs`, `input-drvs`, `input-src`, and `env` are expected to be sorted.
(define-record-type <derivation> (define-record-type <derivation>
(make-derivation name outputs input-drvs input-src system builder args env metadata) (make-derivation name outputs input-drvs input-src system builder args env metadata)
derivation? derivation?
@ -182,7 +183,7 @@
(define (env-pair< left right) (define (env-pair< left right)
(string<? (car left) (car right))) (string<? (car left) (car right)))
;; Calculate the "modulo" contents (that will have to be hashed) of a derivation. ;; Calculate the "modulo" contents of a derivation. The modulo hash of a derivation is used in the store paths of the outputs of said derivation.
(define (modulo-hash-drv-contents drv) (define (modulo-hash-drv-contents drv)
(cond (cond
((drv-is-fod drv) ((drv-is-fod drv)
@ -310,6 +311,7 @@
path) path)
(derivation-metadata-path (derivation-metadata drv)))) (derivation-metadata-path (derivation-metadata drv))))
;; Equality comparison for a `<derivation>`. Checks whether the argument represent the same derivation, not just referential equality.
(define (derivation-equal? left right) (define (derivation-equal? left right)
(define left-cached-path (derivation-metadata-path (derivation-metadata left))) (define left-cached-path (derivation-metadata-path (derivation-metadata left)))
(define right-cached-path (derivation-metadata-path (derivation-metadata right))) (define right-cached-path (derivation-metadata-path (derivation-metadata right)))
@ -494,8 +496,9 @@
(write-bracket-list (lambda (l) (write-paren-list write-quoted-string (list (car l) (cdr l)))) (derivation-env drv)) (write-bracket-list (lambda (l) (write-paren-list write-quoted-string (list (car l) (cdr l)))) (derivation-env drv))
(write-u8 #x29))) (write-u8 #x29)))
;; Writes the derivation to the specified port, or current-output-port if none is supplied. ;; Writes the derivation to the specified port, or `(current-output-port)` if none is supplied.
;; If masked is set, writes the derivation using the passed-in input derivations, rather than the default one. ;; If `masked` is set, writes the derivation using it as `input-drvs` value, rather than the one stored in the `<derivation>`.
;; This is used for generating the modulo-hashed derivation.
(define derivation-serialize (define derivation-serialize
(case-lambda (case-lambda
((drv) (derivation-serialize drv (current-output-port))) ((drv) (derivation-serialize drv (current-output-port)))

4
core/src/nix/hash.sld
View file

@ -13,7 +13,7 @@
((= i (bytevector-length hash)) output-hash) ((= i (bytevector-length hash)) output-hash)
(bytevector-u8-set! output-hash (floor-remainder i 20) (bitwise-xor (bytevector-u8-ref output-hash (floor-remainder i 20)) (bytevector-u8-ref hash i))))) (bytevector-u8-set! output-hash (floor-remainder i 20) (bitwise-xor (bytevector-u8-ref output-hash (floor-remainder i 20)) (bytevector-u8-ref hash i)))))
;; Turns bytevector HASH to a Nix-style (reversed base32) format. ;; Turns bytevector `hash` to a Nix-style (reversed base32, custom alphabet) string.
(define (as-base32 hash) (define (as-base32 hash)
(do ((len (+ (floor-quotient (- (* 8 (bytevector-length hash)) 1) 5) 1)) (tail '()) (i 0 (+ i 1))) (do ((len (+ (floor-quotient (- (* 8 (bytevector-length hash)) 1) 5) 1)) (tail '()) (i 0 (+ i 1)))
((= i len) (list->string tail)) ((= i len) (list->string tail))
@ -31,7 +31,7 @@
(when (= i 32) (error "unknown character in nixbase32 string" chr)) (when (= i 32) (error "unknown character in nixbase32 string" chr))
i))) i)))
;; Returns a nix-base32 string decoded into a bytevector. ;; Returns a bytevector containing `hash` decoded (using reversed base32, custom alphabet)
(define (from-base32 hash) (define (from-base32 hash)
(do ((i 0 (+ i 1)) (do ((i 0 (+ i 1))
(strlen (string-length hash)) (strlen (string-length hash))

21
core/src/nix/path.sld
View file

@ -1,6 +1,7 @@
;; A series of helpers that help create store paths. ;; A series of helpers that help create store paths.
;; ;;
;; These helpers all use the `%store-dir` parameter as base store directory. ;; These helpers all use the `%store-dir` parameter as base store directory.
;; Where `hash-value` is used, a bytevector containing the raw hash is expected.
(define-library (zilch nix path) (define-library (zilch nix path)
(import (import
(scheme base) (srfi 152) (scheme base) (srfi 152)
@ -8,7 +9,7 @@
(export (export
%store-dir %store-dir
impure-placeholder make-upstream-output-placeholder make-placeholder make-upstream-output-placeholder make-placeholder
make-store-path-from-parts make-text-path make-fixed-output-path make-output-path make-store-path-from-parts make-text-path make-fixed-output-path make-output-path
make-fixed-output-with-references) make-fixed-output-with-references)
@ -16,12 +17,15 @@
;; The path to the store dir, as a parameter. ;; The path to the store dir, as a parameter.
(define %store-dir (make-parameter "/nix/store")) (define %store-dir (make-parameter "/nix/store"))
(define impure-placeholder (sha256 "impure")) ;; Calculates a string placeholder for a derivation.
;;
;; - `drv-hash-string` is the hash part of the derivation's store path
;; - `drv-name` is the name of the derivation
;; - `output-name` is the output to calculuate the placeholder for
(define (make-upstream-output-placeholder drv-hash-string drv-name output-name) (define (make-upstream-output-placeholder drv-hash-string drv-name output-name)
(string-append "/" (as-base32 (sha256 (string-append "nix-upstream-output:" drv-hash-string ":" drv-name (if (string=? output-name "out") "" (string-append "-" output-name))))))) (string-append "/" (as-base32 (sha256 (string-append "nix-upstream-output:" drv-hash-string ":" drv-name (if (string=? output-name "out") "" (string-append "-" output-name)))))))
;; Makes a placeholder path, which is substituted with the path of the output. ;; Makes a placeholder path, which is substituted at build-time to be the corresponding output store path for that derivation.
(define (make-placeholder output-name) (define (make-placeholder output-name)
(string-append "/" (as-base32 (sha256 (string->utf8 (string-append "nix-output:" output-name)))))) (string-append "/" (as-base32 (sha256 (string->utf8 (string-append "nix-output:" output-name))))))
@ -32,15 +36,15 @@
((eqv? references '()) collected) ((eqv? references '()) collected)
(else (fold-references (cdr references) (string-append collected ":" (car references)))))) (else (fold-references (cdr references) (string-append collected ":" (car references))))))
;; Creates an arbitrary Nix store path. ;; Creates an arbitrary Nix store path from its constituent parts.
(define (make-store-path-from-parts type hash-algo hash-val name) (define (make-store-path-from-parts type hash-algo hash-val name)
(let* (let*
((inner (string-append type ":" hash-algo ":" (hex hash-val) ":" (%store-dir) ":" name)) ((inner (string-append type ":" hash-algo ":" (hex hash-val) ":" (%store-dir) ":" name))
(hashed (as-base32 (hash-compress (sha256 (string->utf8 inner)))))) (hashed (as-base32 (hash-compress (sha256 (string->utf8 inner))))))
(string-append (%store-dir) "/" hashed "-" name))) (string-append (%store-dir) "/" hashed "-" name)))
;; Creates a store path belonging to a derivation output. HASH-ALGO and ;; Creates a store path belonging to a derivation output. `hash-algo` and
;; HASH-VAL encode the (masked) modulo hash of the derivation. ;; `hash-val` encode the (masked) modulo hash of the derivation.
(define (make-output-path hash-algo hash-val output-name name) (define (make-output-path hash-algo hash-val output-name name)
(make-store-path-from-parts (make-store-path-from-parts
(string-append "output:" output-name) (string-append "output:" output-name)
@ -49,7 +53,7 @@
;; Creates a store path belonging to a text file. Text files may only ;; Creates a store path belonging to a text file. Text files may only
;; depend on other text files, and are used in input-srcs rather than ;; depend on other text files, and are used in input-srcs rather than
;; input-drvs. refs is expected to be sorted. ;; input-drvs. `refs` is expected to be sorted.
(define (make-text-path hash-algo hash-value name refs) (define (make-text-path hash-algo hash-value name refs)
(make-store-path-from-parts (fold-references refs "text") hash-algo hash-value name)) (make-store-path-from-parts (fold-references refs "text") hash-algo hash-value name))
@ -64,6 +68,7 @@
(string-append "fixed:out:" (if recursive "r:" "") hash-algo ":" (hex hash-value) ":"))) (string-append "fixed:out:" (if recursive "r:" "") hash-algo ":" (hex hash-value) ":")))
name))) name)))
;; Creates a fixed-output store path, that has references to other store paths.
(define (make-fixed-output-with-references hash-value name references self-references) (define (make-fixed-output-with-references hash-value name references self-references)
(make-store-path-from-parts (make-store-path-from-parts
(string-join (append (cons "source" references) (if self-references '("self") '())) ":") (string-join (append (cons "source" references) (if self-references '("self") '())) ":")

8
core/src/nixpkgs.sld
View file

@ -1,3 +1,4 @@
;; Procedures that interact with nixpkgs, and other non-Zilch Nix derivations and expressions.
(define-library (zilch nixpkgs) (define-library (zilch nixpkgs)
(import (import
(scheme base) (scheme lazy) (scheme read) (scheme base) (scheme lazy) (scheme read)
@ -69,6 +70,8 @@
data))) data)))
(define raw-eval-cache '()) (define raw-eval-cache '())
;; Evaluates some Nix code in the context of nixpkgs, and returns a `<derivation>` from the store path that the Nix code returned.
(define (nixpkgs-eval path) (define (nixpkgs-eval path)
(define val (assoc path raw-eval-cache)) (define val (assoc path raw-eval-cache))
(if (not (eq? val #f)) (if (not (eq? val #f))
@ -101,12 +104,15 @@
(car response)) (car response))
(values drvs paths (cadr response))) (values drvs paths (cadr response)))
;; Parse an arbitrary Nix expression and return it as a zexpr. ;; Evaluates an arbitrary Nix expression (that will be serialized to JSON) and returns it as a zexpr.
;; The zexpr will depend on the same derivations that the Nix expression does.
(define (nix-eval code) (define (nix-eval code)
(define data (delay (nix-eval-inner code))) (define data (delay (nix-eval-inner code)))
(make-zexp (lambda () (let-values (((drvs paths out) (force data))) (zexp-context-register-items drvs paths) out)) (make-zexp (lambda () (let-values (((drvs paths out) (force data))) (zexp-context-register-items drvs paths) out))
(lambda (p) (fprintf p "nix`~A`" code)))) (lambda (p) (fprintf p "nix`~A`" code))))
;; Returns a `zexp` containing an alist, representing the shell environment the derivation `drv` is executed in.
;; `drv` is expected to be a `<derivation>` or `<store-path>` of a Nixpkgs derivation using `stdenv`.
(define (environment-for-derivation drv) (define (environment-for-derivation drv)
(when (store-path? drv) (set! drv (store-path-drv drv))) (when (store-path? drv) (set! drv (store-path-drv drv)))
(define processor (define processor

11
core/src/semver.sld
View file

@ -1,14 +1,18 @@
;; Procedures to deal with Semantic Versions.
(define-library (zilch semver) (define-library (zilch semver)
(import (import
(scheme base) (scheme base)
(chicken base) (chicken format) (chicken base) (chicken format)
(srfi 152)) (srfi 152))
(export (export
<version>
make-version version-major version-minor version-patch version-prerelease version-build-metadata make-version version-major version-minor version-patch version-prerelease version-build-metadata
version-str parse-version version-str parse-version
version=? version<?) version=? version<?)
(begin (begin
;; A representation of a semantic version.
;; `prerelease` and `build-metadata` are lists.
(define-record-type <version> (define-record-type <version>
(make-version major minor patch prerelease build-metadata) (make-version major minor patch prerelease build-metadata)
version? version?
@ -17,7 +21,8 @@
(patch version-patch) (patch version-patch)
(prerelease version-prerelease) (prerelease version-prerelease)
(build-metadata version-build-metadata)) (build-metadata version-build-metadata))
;; Returns a string representation of a `<version>`.
(define (version-str vers) (define (version-str vers)
(define out (string-append (define out (string-append
(number->string (version-major vers)) (number->string (version-major vers))
@ -34,6 +39,7 @@
(define-record-printer (<version> version out) (define-record-printer (<version> version out)
(fprintf out "#<version ~A>" (version-str version))) (fprintf out "#<version ~A>" (version-str version)))
;; Parses a string into a `<version>`.
(define (parse-version version-string) (define (parse-version version-string)
(define version-string-length (string-length version-string)) (define version-string-length (string-length version-string))
(define separators '(#\. #\+ #\-)) (define separators '(#\. #\+ #\-))
@ -81,6 +87,7 @@
(make-version (string->number (list-ref version-parts 0)) (string->number (list-ref version-parts 1)) (string->number (list-ref version-parts 2)) prerelease-parts build-parts)) (make-version (string->number (list-ref version-parts 0)) (string->number (list-ref version-parts 1)) (string->number (list-ref version-parts 2)) prerelease-parts build-parts))
;; Returns whether `left` and `right` represent an identical version. This ignores the `build-metadata` part of the versions.
(define (version=? left right) (define (version=? left right)
(when (not (version? left)) (when (not (version? left))
(set! left (parse-version left))) (set! left (parse-version left)))
@ -128,6 +135,8 @@
((string-lexicographical<? (car left) (car right)) #t) ((string-lexicographical<? (car left) (car right)) #t)
((string=? (car left) (car right)) (compare-prerelease (cdr left) (cdr right))) ((string=? (car left) (car right)) (compare-prerelease (cdr left) (cdr right)))
(else #f)))))) (else #f))))))
;; Returns whether `left` is an earlier version than `right`, ignoring `build-metadata`.
(define (version<? left right) (define (version<? left right)
(when (not (version? left)) (when (not (version? left))
(set! left (parse-version left))) (set! left (parse-version left)))

5
core/src/statusbar.sld
View file

@ -1,3 +1,4 @@
;; Renders a statusbar at the bottom of stderr.
(define-library (zilch statusbar) (define-library (zilch statusbar)
(import (import
(scheme base) (scheme write) (scheme base) (scheme write)
@ -41,6 +42,10 @@
(mutex-unlock! mutex)))) (mutex-unlock! mutex))))
(make-output-port (lambda (str) (mutex-lock! mutex) (write-data (string->utf8 str) 0)) close-this-port)) (make-output-port (lambda (str) (mutex-lock! mutex) (write-data (string->utf8 str) 0)) close-this-port))
;; Creates a status bar. Ensures redraws are limited where necessary, and will erase itself before printing `stdout`. `stderr` output will be put in the statusbar.
;; if `print-logs` is `#t`, will output stderr to the display.
;;
;; Returns a replacement for `out-port`, a replacement for `err-port`, a procedure to set `print-logs`, and a `(zilch nix daemon)` `++*logger*++`.
(define (statusbar-logger out-port err-port print-logs) (define (statusbar-logger out-port err-port print-logs)
; Current status bar text ; Current status bar text
(define status-bar "[0/0 builds, 0 running] ...") (define status-bar "[0/0 builds, 0 running] ...")

17
core/src/vfs.sld
View file

@ -27,12 +27,13 @@
;; `contents` is a mapping whose keys are a pair (dir . filename) to file contents (e.g. zfile, or store path). ;; `contents` is a mapping whose keys are a pair (dir . filename) to file contents (e.g. zfile, or store path).
;; The file contents may be the symbol 'directory to indicate there's a directory. ;; The file contents may be the symbol 'directory to indicate there's a directory.
;; ;;
;; The root directory is specified by `dir` being an empty string. There are no trailing or leading slashes. ;; The root directory is specified by `dir` being an empty string. There are no trailing or leading slashes in directory paths.
(define-record-type <vfs> (define-record-type <vfs>
(make-vfs contents) (make-vfs contents)
vfs? vfs?
(contents vfs-contents)) (contents vfs-contents))
;; Returns an alist of all the files in the directory `dir` in `vfs`.
(define (vfs-dir-files vfs dir) (define (vfs-dir-files vfs dir)
(mapping-map->list (mapping-map->list
(lambda (k v) (cons (cdr k) v)) (lambda (k v) (cons (cdr k) v))
@ -41,11 +42,12 @@
(and (not (eq? val 'directory)) (string=? (car key) dir))) (and (not (eq? val 'directory)) (string=? (car key) dir)))
(vfs-contents vfs)))) (vfs-contents vfs))))
;; Returns the file at `dirname`/`filename`, or `#f` if it does not exist.
(define (vfs-file-ref vfs dirname filename) (define (vfs-file-ref vfs dirname filename)
(mapping-ref/default (vfs-contents vfs) (cons dirname filename) #f)) (mapping-ref/default (vfs-contents vfs) (cons dirname filename) #f))
;; Calls the filter with the dir, filename, and contents, for each file. ;; Calls the filter with the dir, filename, and contents, for each file.
;; If filter returns #f, the file in the vfs will be replaced by /dev/null. ;; If filter returns `#f`, the file in the vfs will be replaced by /dev/null.
(define (vfs-dir-filter vfs filter) (define (vfs-dir-filter vfs filter)
(make-vfs (make-vfs
(mapping-map/monotone (mapping-map/monotone
@ -54,7 +56,7 @@
(make-default-comparator) (make-default-comparator)
(vfs-contents vfs)))) (vfs-contents vfs))))
;; Calls the filter for each directory. If the filter returns #f, the directory's files are replaced with `/dev/null`. ;; Calls the filter for each directory. If the filter returns `#f`, the directory's files (and all its children directories' files) are replaced with symlinks to `/dev/null`.
(define (vfs-dir-filter-all filter vfs) (define (vfs-dir-filter-all filter vfs)
(define to-filter-out (set (make-default-comparator))) (define to-filter-out (set (make-default-comparator)))
(mapping-for-each (mapping-for-each
@ -93,7 +95,7 @@
(zdir contents)) (zdir contents))
(read-dir "")) (read-dir ""))
;; Creates a new VFS that is a subdirectory of the existing ;; Creates a new VFS that is rooted at the subdirectory of an existing
;; VFS. ;; VFS.
(define (vfs-subdir vfs subdir) (define (vfs-subdir vfs subdir)
(define subdirprefix (string-append subdir "/")) (define subdirprefix (string-append subdir "/"))
@ -134,6 +136,7 @@
(iter-dir "") (iter-dir "")
(make-vfs out)) (make-vfs out))
;; Creates a VFS from a store path.
(define (vfs-from-store store-path) (define (vfs-from-store store-path)
(if (vfs? store-path) (if (vfs? store-path)
store-path store-path
@ -153,6 +156,10 @@
(find (string-length strval)) (find (string-length strval))
(string-concatenate output-parts)) (string-concatenate output-parts))
;; Generates a string representation of the vfs.
;;
;; Each directory is represented by a string `mkdir foo/bar`, and each file is represented by `cp /source/path destination/path`, suffixed with newlines.
;; Strings are escaped by backslash-escaping spaces, newlines, and backslashes.
(define (vfs-to-string vfs) (define (vfs-to-string vfs)
(define output '()) (define output '())
(mapping-for-each (mapping-for-each
@ -176,7 +183,7 @@
(zexp ,(make-string (zexp-unquote output)))) (zexp ,(make-string (zexp-unquote output))))
;; Returns a new VFS, with one file added. ;; Returns a vfs with one file added.
(define (vfs-append-file vfs path contents) (define (vfs-append-file vfs path contents)
(define split (string-contains-right path "/")) (define split (string-contains-right path "/"))
(define dirname (if split (string-copy path 0 split) "")) (define dirname (if split (string-copy path 0 split) ""))

21
core/src/zexpr.sld
View file

@ -26,12 +26,13 @@
(begin (begin
;; A zexp (concept inspired from Guix g-expressions) is represented as a ;; A zexp (concept inspired from Guix g-expressions) is represented as a
;; thunk that returns the quoted value, and writes the metadata (e.g. string context) necessary ;; thunk that returns a value, and writes the metadata (e.g. string context) necessary
;; into `++*zexp-context*++`. ;; into `++*zexp-context*++`.
;; ;;
;; `(make-zexp thunk printer)` + ;; `(make-zexp thunk printer)`
;; `thunk` `(zexp-thunk zexp)` is the thunk called when evaluating the zexp. + ;;
;; `printer` `(zexp-printer zexp)` is a thunk that is called with a port to print a representation of the zexp. + ;; - `thunk` is the thunk called when evaluating the zexp.
;; - `printer` is a procedure that is called with a port, when a representation of the zexp is requested.
(define-record-type <zexp> (define-record-type <zexp>
(make-zexp thunk printer) (make-zexp thunk printer)
zexp? zexp?
@ -45,10 +46,9 @@
;; The context used to evaluate a zexp, stored in `++*zexp-context*++` during the evaluation. ;; The context used to evaluate a zexp, stored in `++*zexp-context*++` during the evaluation.
;; ;;
;; Stores a list of sources in `zexp-content-srcs` (settable using `set-zexp-context-srcs!`) ;; Stores a list of sources in `zexp-content-srcs` and an alist of derivations with a list of their outputs in `zexp-content-drvs`.
;; and an alist of derivations with a list of their outputs in `zexp-content-drvs` (settable using `set-zexp-context-drvs!`)
;; ;;
;; Prefer using zexp-context-register-items over directly interacting with this record. ;; Prefer using `zexp-context-register-items` over directly interacting with this record.
(define-record-type <zexp-context> (define-record-type <zexp-context>
(make-zexp-context srcs drvs zexp parent) (make-zexp-context srcs drvs zexp parent)
zexp-context? zexp-context?
@ -80,8 +80,7 @@
(zexp-evaluation-srcs zeval))) (zexp-evaluation-srcs zeval)))
;; Adds any new items from a list of sources and an alist of derivations to the current `++*zexp-context*++`. ;; Adds any new items from a list of sources and an alist of derivations to the current `++*zexp-context*++`.
;; drvs is an alist of derivation object to output. name. + ;; drvs is an alist of derivation object to output name.
;; TODO(puck): 'spensive?
(define (zexp-context-register-items drvs srcs) (define (zexp-context-register-items drvs srcs)
(define ctx (*zexp-context*)) (define ctx (*zexp-context*))
(define ctx-src (and ctx (zexp-context-srcs ctx))) (define ctx-src (and ctx (zexp-context-srcs ctx)))
@ -130,7 +129,7 @@
(iter-unquote-handler val (cdr handlers)) (iter-unquote-handler val (cdr handlers))
result)))) result))))
;; Used in the `zexp` macro to zexp-unquote values. ;; Unquotes a `zexp`. If used outside zexp evaluation context, loses dependencies. Used in the `zexp` macro to zexp-unquote values.
(define (zexp-unquote val) (define (zexp-unquote val)
(cond (cond
((pair? val) (cons (zexp-unquote (car val)) (zexp-unquote (cdr val)))) ((pair? val) (cons (zexp-unquote (car val)) (zexp-unquote (cdr val))))
@ -142,7 +141,7 @@
((or (boolean? val) (char? val) (null? val) (symbol? val) (bytevector? val) (eof-object? val) (number? val) (string? val)) val) ((or (boolean? val) (char? val) (null? val) (symbol? val) (bytevector? val) (eof-object? val) (number? val) (string? val)) val)
(else (iter-unquote-handler val zexp-unquote-handlers)))) (else (iter-unquote-handler val zexp-unquote-handlers))))
;; Unwraps a <zexp>, returning a <zexp-evaluation> containing the proper quoted expressions, and its dependencies. ;; Unwraps a <zexp>, returning a <zexp-evaluation> containing the contents of the evaluated zexp, along with its dependencies.
(define (zexp-unwrap val) (define (zexp-unwrap val)
(parameterize ((*zexp-context* (make-zexp-context '() '() val (*zexp-context*)))) (parameterize ((*zexp-context* (make-zexp-context '() '() val (*zexp-context*))))
(let ((nval (zexp-unquote val))) (let ((nval (zexp-unquote val)))